OpenGL-2.12.0.1/0000755000000000000000000000000012521420345011243 5ustar0000000000000000OpenGL-2.12.0.1/README.md0000644000000000000000000000032612521420345012523 0ustar0000000000000000[![Hackage](https://img.shields.io/hackage/v/OpenGL.svg)](https://hackage.haskell.org/package/OpenGL) [![Build Status](https://travis-ci.org/haskell-opengl/OpenGL.png)](https://travis-ci.org/haskell-opengl/OpenGL) OpenGL-2.12.0.1/LICENSE0000644000000000000000000000272212521420345012253 0ustar0000000000000000Copyright (c) 2002-2005, Sven Panne All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. OpenGL-2.12.0.1/Setup.hs0000644000000000000000000000005612521420345012700 0ustar0000000000000000import Distribution.Simple main = defaultMain OpenGL-2.12.0.1/OpenGL.cabal0000644000000000000000000001655312521420345013365 0ustar0000000000000000name: OpenGL version: 2.12.0.1 synopsis: A binding for the OpenGL graphics system description: A Haskell binding for the OpenGL graphics system (GL, version 4.5) and its accompanying utility library (GLU, version 1.3). . OpenGL is the industry's most widely used and supported 2D and 3D graphics application programming interface (API), incorporating a broad set of rendering, texture mapping, special effects, and other powerful visualization functions. For more information about OpenGL and its various extensions, please see and . homepage: http://www.haskell.org/haskellwiki/Opengl bug-reports: https://github.com/haskell-opengl/OpenGL/issues copyright: Copyright (C) 2002-2015 Sven Panne license: BSD3 license-file: LICENSE author: Sven Panne maintainer: Sven Panne , Jason Dagit category: Graphics build-type: Simple cabal-version: >= 1.10 extra-source-files: README.md library exposed-modules: Graphics.Rendering.OpenGL Graphics.Rendering.OpenGL.GL Graphics.Rendering.OpenGL.GL.Antialiasing Graphics.Rendering.OpenGL.GL.BeginEnd Graphics.Rendering.OpenGL.GL.Bitmaps Graphics.Rendering.OpenGL.GL.BufferObjects Graphics.Rendering.OpenGL.GL.Clipping Graphics.Rendering.OpenGL.GL.ColorSum Graphics.Rendering.OpenGL.GL.Colors Graphics.Rendering.OpenGL.GL.ConditionalRendering Graphics.Rendering.OpenGL.GL.CoordTrans Graphics.Rendering.OpenGL.GL.DebugOutput Graphics.Rendering.OpenGL.GL.DisplayLists Graphics.Rendering.OpenGL.GL.Evaluators Graphics.Rendering.OpenGL.GL.Feedback Graphics.Rendering.OpenGL.GL.FlushFinish Graphics.Rendering.OpenGL.GL.Fog Graphics.Rendering.OpenGL.GL.Framebuffer Graphics.Rendering.OpenGL.GL.FramebufferObjects Graphics.Rendering.OpenGL.GL.FramebufferObjects.Attachments Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjects Graphics.Rendering.OpenGL.GL.FramebufferObjects.Queries Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObjects Graphics.Rendering.OpenGL.GL.Hints Graphics.Rendering.OpenGL.GL.LineSegments Graphics.Rendering.OpenGL.GL.PerFragment Graphics.Rendering.OpenGL.GL.PixelRectangles Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable Graphics.Rendering.OpenGL.GL.PixelRectangles.Convolution Graphics.Rendering.OpenGL.GL.PixelRectangles.Histogram Graphics.Rendering.OpenGL.GL.PixelRectangles.Minmax Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelMap Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelStorage Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelTransfer Graphics.Rendering.OpenGL.GL.PixelRectangles.Rasterization Graphics.Rendering.OpenGL.GL.PixellikeObject Graphics.Rendering.OpenGL.GL.Points Graphics.Rendering.OpenGL.GL.Polygons Graphics.Rendering.OpenGL.GL.PrimitiveMode Graphics.Rendering.OpenGL.GL.QueryObjects Graphics.Rendering.OpenGL.GL.RasterPos Graphics.Rendering.OpenGL.GL.ReadCopyPixels Graphics.Rendering.OpenGL.GL.Rectangles Graphics.Rendering.OpenGL.GL.SavingState Graphics.Rendering.OpenGL.GL.Selection Graphics.Rendering.OpenGL.GL.Shaders Graphics.Rendering.OpenGL.GL.Shaders.Attribs Graphics.Rendering.OpenGL.GL.Shaders.Limits Graphics.Rendering.OpenGL.GL.Shaders.ProgramBinaries Graphics.Rendering.OpenGL.GL.Shaders.ProgramObjects Graphics.Rendering.OpenGL.GL.Shaders.ShaderBinaries Graphics.Rendering.OpenGL.GL.Shaders.ShaderObjects Graphics.Rendering.OpenGL.GL.Shaders.Uniform Graphics.Rendering.OpenGL.GL.StringQueries Graphics.Rendering.OpenGL.GL.SyncObjects Graphics.Rendering.OpenGL.GL.Tensor Graphics.Rendering.OpenGL.GL.Texturing Graphics.Rendering.OpenGL.GL.Texturing.Application Graphics.Rendering.OpenGL.GL.Texturing.Environments Graphics.Rendering.OpenGL.GL.Texturing.Objects Graphics.Rendering.OpenGL.GL.Texturing.Parameters Graphics.Rendering.OpenGL.GL.Texturing.Queries Graphics.Rendering.OpenGL.GL.Texturing.Specification Graphics.Rendering.OpenGL.GL.TransformFeedback Graphics.Rendering.OpenGL.GL.VertexArrayObjects Graphics.Rendering.OpenGL.GL.VertexArrays Graphics.Rendering.OpenGL.GL.VertexSpec Graphics.Rendering.OpenGL.GLU Graphics.Rendering.OpenGL.GLU.Errors Graphics.Rendering.OpenGL.GLU.Initialization Graphics.Rendering.OpenGL.GLU.Matrix Graphics.Rendering.OpenGL.GLU.Mipmapping Graphics.Rendering.OpenGL.GLU.NURBS Graphics.Rendering.OpenGL.GLU.Quadrics Graphics.Rendering.OpenGL.GLU.Tessellation other-modules: Graphics.Rendering.OpenGL.GL.BlendingFactor Graphics.Rendering.OpenGL.GL.BufferMode Graphics.Rendering.OpenGL.GL.ByteString Graphics.Rendering.OpenGL.GL.Capability Graphics.Rendering.OpenGL.GL.ComparisonFunction Graphics.Rendering.OpenGL.GL.ControlPoint Graphics.Rendering.OpenGL.GL.DataType Graphics.Rendering.OpenGL.GL.Domain Graphics.Rendering.OpenGL.GL.EdgeFlag Graphics.Rendering.OpenGL.GL.Exception Graphics.Rendering.OpenGL.GL.Face Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObject Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjectAttachment Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferTarget Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObject Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferTarget Graphics.Rendering.OpenGL.GL.GLboolean Graphics.Rendering.OpenGL.GL.IOState Graphics.Rendering.OpenGL.GL.PeekPoke Graphics.Rendering.OpenGL.GL.PixelData Graphics.Rendering.OpenGL.GL.PixelFormat Graphics.Rendering.OpenGL.GL.PixelRectangles.Reset Graphics.Rendering.OpenGL.GL.PixelRectangles.Sink Graphics.Rendering.OpenGL.GL.PointParameter Graphics.Rendering.OpenGL.GL.PolygonMode Graphics.Rendering.OpenGL.GL.PrimitiveModeInternal Graphics.Rendering.OpenGL.GL.QueryObject Graphics.Rendering.OpenGL.GL.QueryUtils Graphics.Rendering.OpenGL.GL.QueryUtils.PName Graphics.Rendering.OpenGL.GL.QueryUtils.VertexAttrib Graphics.Rendering.OpenGL.GL.RenderMode Graphics.Rendering.OpenGL.GL.Shaders.Program Graphics.Rendering.OpenGL.GL.Shaders.Shader Graphics.Rendering.OpenGL.GL.Shaders.Variables Graphics.Rendering.OpenGL.GL.Texturing.Filter Graphics.Rendering.OpenGL.GL.Texturing.PixelInternalFormat Graphics.Rendering.OpenGL.GL.Texturing.TexParameter Graphics.Rendering.OpenGL.GL.Texturing.TextureObject Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget Graphics.Rendering.OpenGL.GL.Texturing.TextureUnit Graphics.Rendering.OpenGL.GL.VertexAttributes Graphics.Rendering.OpenGL.GLU.ErrorsInternal hs-source-dirs: src ghc-options: -Wall build-depends: base >= 3 && < 5, bytestring >= 0.9 && < 0.11, text >= 0.1 && < 1.3, transformers >= 0.2 && < 0.5, ObjectName >= 1.1 && < 1.2, StateVar >= 1.1 && < 1.2, OpenGLRaw >= 2.1 && < 2.6, GLURaw >= 1.3 && < 1.6 default-language: Haskell2010 other-extensions: CPP DeriveDataTypeable KindSignatures TypeSynonymInstances if os(windows) if arch(i386) cpp-options: "-DCALLCONV=stdcall" else cpp-options: "-DCALLCONV=ccall" else cpp-options: "-DCALLCONV=ccall" source-repository head type: git location: https://github.com/haskell-opengl/OpenGL.git OpenGL-2.12.0.1/src/0000755000000000000000000000000012521420345012032 5ustar0000000000000000OpenGL-2.12.0.1/src/Graphics/0000755000000000000000000000000012521420345013572 5ustar0000000000000000OpenGL-2.12.0.1/src/Graphics/Rendering/0000755000000000000000000000000012521420345015507 5ustar0000000000000000OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL.hs0000644000000000000000000001247112521420345017174 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- A convenience module, combining the Haskell bindings for GL and GLU. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL ( -- * Supported Extensions -- $SupportedExtensions -- * Legal stuff -- $LegalStuff module Graphics.Rendering.OpenGL.GL , module Graphics.Rendering.OpenGL.GLU ) where import Graphics.Rendering.OpenGL.GL import Graphics.Rendering.OpenGL.GLU -------------------------------------------------------------------------------- -- $SupportedExtensions -- There is support for full OpenGL 4.4 (compatibility profile), plus some -- extensions: -- -- @ -- extension | core since -- -------------------------------+------------ -- GL_APPLE_packed_pixels | 1.2 -- GL_APPLE_ycbcr_422 | -- GL_ARB_copy_buffer | 3.1 -- GL_ARB_depth_buffer_float | 3.0 -- GL_ARB_depth_texture | 1.4 -- GL_ARB_half_float_pixel | 3.0 -- GL_ARB_imaging | -- GL_ARB_multisample | 1.3 -- GL_ARB_multitexture | 1.3 -- GL_ARB_occlusion_query | 1.5 -- GL_ARB_point_parameters | 1.4 -- GL_ARB_point_sprite | -- GL_ARB_shadow | 1.4 -- GL_ARB_texture_border_clamp | 1.3 -- GL_ARB_texture_compression | 1.3 -- GL_ARB_texture_cube_map | 1.3 -- GL_ARB_texture_env_add | 1.3 -- GL_ARB_texture_env_combine | 1.3 -- GL_ARB_texture_env_crossbar | 1.4 -- GL_ARB_texture_env_dot3 | 1.3 -- GL_ARB_texture_mirrored_repeat | 1.4 -- GL_ARB_texture_rectangle | 3.1 -- GL_ARB_transpose_matrix | 1.3 -- GL_ARB_vertex_buffer_object | 1.5 -- GL_ARB_vertex_shader | 2.0 -- GL_ARB_window_pos | 1.4 -- GL_EXT_abgr | -- GL_EXT_bgra | 1.2 -- GL_EXT_blend_color | 1.4 -- GL_EXT_blend_func_separate | 1.4 -- GL_EXT_blend_logic_op | 1.1 -- GL_EXT_blend_minmax | 1.4 -- GL_EXT_blend_subtract | 1.4 -- GL_EXT_color_subtable | -- GL_EXT_compiled_vertex_array | -- GL_EXT_convolution | -- GL_EXT_copy_texture | 1.1 -- GL_EXT_depth_bounds_test | -- GL_EXT_draw_range_elements | 1.2 -- GL_EXT_fog_coord | 1.4 -- GL_EXT_histogram | -- GL_EXT_multi_draw_arrays | 1.4 -- GL_EXT_packed_float | 3.0 -- GL_EXT_packed_pixels | 1.2 -- GL_EXT_polygon_offset | 1.1 -- GL_EXT_rescale_normal | 1.2 -- GL_EXT_secondary_color | 1.4 -- GL_EXT_separate_specular_color | 1.2 -- GL_EXT_shadow_funcs | 1.5 -- GL_EXT_stencil_two_side | -- GL_EXT_stencil_wrap | 1.4 -- GL_EXT_subtexture | 1.1 -- GL_EXT_texture | 1.1 -- GL_EXT_texture3D | 1.2 -- GL_EXT_texture_lod_bias | 1.4 -- GL_EXT_texture_shared_exponent | 3.0 -- GL_EXT_texture_object | 1.1 -- GL_EXT_vertex_array | 1.1 -- GL_HP_convolution_border_modes | -- GL_IBM_rasterpos_clip | -- GL_MESA_ycbcr_texture | -- GL_NV_blend_square | 1.4 -- GL_NV_depth_clamp | -- GL_NV_fog_distance | -- GL_NV_light_max_exponent | -- GL_NV_packed_depth_stencil | -- GL_NV_primitive_restart | -- GL_SGIS_generate_mipmap | 1.4 -- GL_SGIS_texture_edge_clamp | -- GL_SGIS_texture_lod | -- GL_SGI_color_matrix | -- GL_SGI_color_table | -- @ -------------------------------------------------------------------------------- -- $LegalStuff -- The documentation is loosely based on the man pages of the OpenGL Sample -- Implemenation from SGI, see: . It is -- used under the SGI Free Software License B. This license requires the -- following notice: -- -- /License Applicability/. Except to the extent portions of this file are made -- subject to an alternative license as permitted in the SGI Free Software -- License B, Version 1.1 (the \"License\"), the contents of this file are -- subject only to the provisions of the License. You may not use this file -- except in compliance with the License. You may obtain a copy of the License -- at Silicon Graphics, Inc., attn: Legal Services, 1600 Amphitheatre Parkway, -- Mountain View, CA 94043-1351, or at: . -- -- Note that, as provided in the License, the Software is distributed on an \"AS -- IS\" basis, with ALL EXPRESS AND IMPLIED WARRANTIES AND CONDITIONS -- DISCLAIMED, INCLUDING, WITHOUT LIMITATION, ANY IMPLIED WARRANTIES AND -- CONDITIONS OF MERCHANTABILITY, SATISFACTORY QUALITY, FITNESS FOR A PARTICULAR -- PURPOSE, AND NON-INFRINGEMENT. -- -- /Original Code/. The Original Code is: OpenGL Sample Implementation, Version -- 1.2.1, released January 26, 2000, developed by Silicon Graphics, Inc. The -- Original Code is Copyright (c) 1991-2002 Silicon Graphics, Inc. Copyright in -- any portions created by third parties is as indicated elsewhere herein. All -- Rights Reserved. OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/0000755000000000000000000000000012521420345016633 5ustar0000000000000000OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL.hs0000644000000000000000000001155612521420345017501 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- A Haskell binding for OpenGL, the industry\'s most widely used and -- supported 2D and 3D graphics API. -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL ( -- * OpenGL Fundamentals module Graphics.Rendering.OpenGL.Raw.Types, module Graphics.Rendering.OpenGL.GL.FlushFinish, module Data.ObjectName, -- * Event Model module Graphics.Rendering.OpenGL.GL.SyncObjects, module Graphics.Rendering.OpenGL.GL.QueryObjects, -- * Vertex Specification and Drawing Commands module Graphics.Rendering.OpenGL.GL.PrimitiveMode, module Graphics.Rendering.OpenGL.GL.BeginEnd, module Graphics.Rendering.OpenGL.GL.Rectangles, module Graphics.Rendering.OpenGL.GL.ConditionalRendering, -- * OpenGL Operation module Graphics.Rendering.OpenGL.GL.VertexSpec, module Graphics.Rendering.OpenGL.GL.VertexArrays, module Graphics.Rendering.OpenGL.GL.VertexArrayObjects, module Graphics.Rendering.OpenGL.GL.BufferObjects, module Graphics.Rendering.OpenGL.GL.CoordTrans, module Graphics.Rendering.OpenGL.GL.Clipping, module Graphics.Rendering.OpenGL.GL.RasterPos, module Graphics.Rendering.OpenGL.GL.Colors, module Graphics.Rendering.OpenGL.GL.Shaders, -- * Rasterization module Graphics.Rendering.OpenGL.GL.Antialiasing, module Graphics.Rendering.OpenGL.GL.FramebufferObjects, module Graphics.Rendering.OpenGL.GL.Points, module Graphics.Rendering.OpenGL.GL.LineSegments, module Graphics.Rendering.OpenGL.GL.Polygons, module Graphics.Rendering.OpenGL.GL.PixelRectangles, module Graphics.Rendering.OpenGL.GL.Bitmaps, module Graphics.Rendering.OpenGL.GL.Texturing, module Graphics.Rendering.OpenGL.GL.ColorSum, module Graphics.Rendering.OpenGL.GL.Fog, -- * Per-Fragment Operations and the Framebuffer module Graphics.Rendering.OpenGL.GL.PerFragment, module Graphics.Rendering.OpenGL.GL.Framebuffer, module Graphics.Rendering.OpenGL.GL.ReadCopyPixels, -- * Special Functions module Graphics.Rendering.OpenGL.GL.Evaluators, module Graphics.Rendering.OpenGL.GL.Selection, module Graphics.Rendering.OpenGL.GL.Feedback, module Graphics.Rendering.OpenGL.GL.DisplayLists, module Graphics.Rendering.OpenGL.GL.Hints, module Graphics.Rendering.OpenGL.GL.PixellikeObject, module Graphics.Rendering.OpenGL.GL.TransformFeedback, module Graphics.Rendering.OpenGL.GL.DebugOutput, -- * State and State Requests module Data.StateVar, module Graphics.Rendering.OpenGL.GL.Tensor, module Graphics.Rendering.OpenGL.GL.StringQueries, module Graphics.Rendering.OpenGL.GL.SavingState ) where import Graphics.Rendering.OpenGL.Raw.Types import Graphics.Rendering.OpenGL.GL.FlushFinish import Data.ObjectName import Data.StateVar import Graphics.Rendering.OpenGL.GL.SyncObjects import Graphics.Rendering.OpenGL.GL.QueryObjects import Graphics.Rendering.OpenGL.GL.PrimitiveMode import Graphics.Rendering.OpenGL.GL.BeginEnd import Graphics.Rendering.OpenGL.GL.Rectangles import Graphics.Rendering.OpenGL.GL.ConditionalRendering import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.GL.VertexArrays import Graphics.Rendering.OpenGL.GL.VertexArrayObjects import Graphics.Rendering.OpenGL.GL.BufferObjects import Graphics.Rendering.OpenGL.GL.CoordTrans import Graphics.Rendering.OpenGL.GL.Clipping import Graphics.Rendering.OpenGL.GL.RasterPos import Graphics.Rendering.OpenGL.GL.Colors import Graphics.Rendering.OpenGL.GL.Shaders import Graphics.Rendering.OpenGL.GL.Antialiasing import Graphics.Rendering.OpenGL.GL.FramebufferObjects import Graphics.Rendering.OpenGL.GL.Points import Graphics.Rendering.OpenGL.GL.LineSegments import Graphics.Rendering.OpenGL.GL.Polygons import Graphics.Rendering.OpenGL.GL.PixelRectangles import Graphics.Rendering.OpenGL.GL.Bitmaps import Graphics.Rendering.OpenGL.GL.Texturing import Graphics.Rendering.OpenGL.GL.ColorSum import Graphics.Rendering.OpenGL.GL.Fog import Graphics.Rendering.OpenGL.GL.PerFragment import Graphics.Rendering.OpenGL.GL.Framebuffer import Graphics.Rendering.OpenGL.GL.ReadCopyPixels import Graphics.Rendering.OpenGL.GL.Evaluators import Graphics.Rendering.OpenGL.GL.Selection import Graphics.Rendering.OpenGL.GL.Feedback import Graphics.Rendering.OpenGL.GL.DisplayLists import Graphics.Rendering.OpenGL.GL.Hints import Graphics.Rendering.OpenGL.GL.PixellikeObject import Graphics.Rendering.OpenGL.GL.TransformFeedback import Graphics.Rendering.OpenGL.GL.DebugOutput import Graphics.Rendering.OpenGL.GL.Tensor import Graphics.Rendering.OpenGL.GL.StringQueries import Graphics.Rendering.OpenGL.GL.SavingState OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GLU.hs0000644000000000000000000000226212521420345017620 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GLU -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- A Haskell binding for GLU, OpenGL\'s accompanying utility library. -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GLU ( module Graphics.Rendering.OpenGL.GLU.Initialization, module Graphics.Rendering.OpenGL.GLU.Mipmapping, module Graphics.Rendering.OpenGL.GLU.Matrix, module Graphics.Rendering.OpenGL.GLU.Tessellation, module Graphics.Rendering.OpenGL.GLU.Quadrics, module Graphics.Rendering.OpenGL.GLU.NURBS, module Graphics.Rendering.OpenGL.GLU.Errors ) where import Graphics.Rendering.OpenGL.GLU.Initialization import Graphics.Rendering.OpenGL.GLU.Mipmapping import Graphics.Rendering.OpenGL.GLU.Matrix import Graphics.Rendering.OpenGL.GLU.Tessellation import Graphics.Rendering.OpenGL.GLU.Quadrics import Graphics.Rendering.OpenGL.GLU.NURBS import Graphics.Rendering.OpenGL.GLU.Errors OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GLU/0000755000000000000000000000000012521420345017262 5ustar0000000000000000OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GLU/NURBS.hs0000644000000000000000000002761312521420345020520 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GLU.NURBS -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to chapter 7 (NURBS) of the GLU specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GLU.NURBS ( NURBSObj, withNURBSObj, NURBSBeginCallback, withNURBSBeginCallback, NURBSVertexCallback, withNURBSVertexCallback, NURBSNormalCallback, withNURBSNormalCallback, NURBSColorCallback, withNURBSColorCallback, NURBSEndCallback, withNURBSEndCallback, checkForNURBSError, nurbsBeginEndCurve, nurbsCurve, nurbsBeginEndSurface, nurbsSurface, TrimmingPoint, nurbsBeginEndTrim, pwlCurve, trimmingCurve, NURBSMode(..), setNURBSMode, setNURBSCulling, SamplingMethod(..), setSamplingMethod, loadSamplingMatrices, DisplayMode'(..), setDisplayMode' ) where import Control.Monad import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.GLU.Raw hiding ( NURBSBeginCallback, NURBSVertexCallback, NURBSNormalCallback, NURBSColorCallback, NURBSEndCallback ) import Graphics.Rendering.OpenGL.GL.Tensor import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.ControlPoint import Graphics.Rendering.OpenGL.GL.CoordTrans import Graphics.Rendering.OpenGL.GL.Exception import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.PrimitiveMode import Graphics.Rendering.OpenGL.GL.PrimitiveModeInternal import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- chapter 7.1: The NURBS Object -- an opaque pointer to a NURBS object type NURBSObj = Ptr GLUnurbs isNullNURBSObj :: NURBSObj -> Bool isNullNURBSObj = (nullPtr ==) withNURBSObj :: a -> (NURBSObj -> IO a) -> IO a withNURBSObj failureValue action = bracket gluNewNurbsRenderer safeDeleteNurbsRenderer (\nurbsObj -> if isNullNURBSObj nurbsObj then do recordOutOfMemory return failureValue else action nurbsObj) safeDeleteNurbsRenderer :: NURBSObj -> IO () safeDeleteNurbsRenderer nurbsObj = unless (isNullNURBSObj nurbsObj) $ gluDeleteNurbsRenderer nurbsObj -------------------------------------------------------------------------------- -- chapter 7.2: Callbacks (begin) type NURBSBeginCallback = PrimitiveMode -> IO () withNURBSBeginCallback :: NURBSObj -> NURBSBeginCallback -> IO a -> IO a withNURBSBeginCallback nurbsObj beginCallback action = bracket (makeNURBSBeginCallback (beginCallback . unmarshalPrimitiveMode)) freeHaskellFunPtr $ \callbackPtr -> do gluNurbsCallback nurbsObj glu_NURBS_BEGIN callbackPtr action -------------------------------------------------------------------------------- -- chapter 7.2: Callbacks (vertex) type NURBSVertexCallback = Vertex3 GLfloat -> IO () withNURBSVertexCallback :: NURBSObj -> NURBSVertexCallback -> IO a -> IO a withNURBSVertexCallback nurbsObj vertexCallback action = bracket (makeNURBSVertexCallback (\p -> peek (castPtr p) >>= vertexCallback)) freeHaskellFunPtr $ \callbackPtr -> do gluNurbsCallback nurbsObj glu_NURBS_VERTEX callbackPtr action -------------------------------------------------------------------------------- -- chapter 7.2: Callbacks (normal) type NURBSNormalCallback = Normal3 GLfloat -> IO () withNURBSNormalCallback :: NURBSObj -> NURBSNormalCallback -> IO a -> IO a withNURBSNormalCallback nurbsObj normalCallback action = bracket (makeNURBSNormalCallback (\p -> peek (castPtr p) >>= normalCallback)) freeHaskellFunPtr $ \callbackPtr -> do gluNurbsCallback nurbsObj glu_NURBS_NORMAL callbackPtr action -------------------------------------------------------------------------------- -- chapter 7.2: Callbacks (color) type NURBSColorCallback = Color4 GLfloat -> IO () withNURBSColorCallback :: NURBSObj -> NURBSColorCallback -> IO a -> IO a withNURBSColorCallback nurbsObj colorCallback action = bracket (makeNURBSColorCallback (\p -> peek (castPtr p) >>= colorCallback)) freeHaskellFunPtr $ \callbackPtr -> do gluNurbsCallback nurbsObj glu_NURBS_COLOR callbackPtr action -------------------------------------------------------------------------------- -- chapter 7.2: Callbacks (end) type NURBSEndCallback = IO () withNURBSEndCallback :: NURBSObj -> NURBSEndCallback -> IO a -> IO a withNURBSEndCallback nurbsObj endCallback action = bracket (makeNURBSEndCallback endCallback) freeHaskellFunPtr $ \callbackPtr -> do gluNurbsCallback nurbsObj glu_NURBS_END callbackPtr action -------------------------------------------------------------------------------- -- chapter 7.2: Callbacks (error) type ErrorCallback = GLenum -> IO () withErrorCallback :: NURBSObj -> ErrorCallback -> IO a -> IO a withErrorCallback nurbsObj errorCallback action = bracket (makeNURBSErrorCallback errorCallback) freeHaskellFunPtr $ \callbackPtr -> do gluNurbsCallback nurbsObj glu_NURBS_ERROR callbackPtr action checkForNURBSError :: NURBSObj -> IO a -> IO a checkForNURBSError nurbsObj = withErrorCallback nurbsObj recordErrorCode -------------------------------------------------------------------------------- -- chapter 7.3: NURBS Curves nurbsBeginEndCurve :: NURBSObj -> IO a -> IO a nurbsBeginEndCurve nurbsObj = bracket_ (gluBeginCurve nurbsObj) (gluEndCurve nurbsObj) nurbsCurve :: ControlPoint c => NURBSObj -> GLint -> Ptr GLfloat -> GLint -> Ptr (c GLfloat) -> GLint -> IO () nurbsCurve nurbsObj knotCount knots stride control order = gluNurbsCurve nurbsObj knotCount knots stride (castPtr control) order (map1Target (pseudoPeek control)) pseudoPeek :: Ptr (c GLfloat) -> c GLfloat pseudoPeek _ = undefined -------------------------------------------------------------------------------- -- chapter 7.4: NURBS Surfaces nurbsBeginEndSurface :: NURBSObj -> IO a -> IO a nurbsBeginEndSurface nurbsObj = bracket_ (gluBeginSurface nurbsObj) (gluEndSurface nurbsObj) nurbsSurface :: ControlPoint c => NURBSObj -> GLint -> Ptr GLfloat -> GLint -> Ptr GLfloat -> GLint -> GLint -> Ptr (c GLfloat) -> GLint -> GLint -> IO () nurbsSurface nurbsObj sKnotCount sKnots tKnotCount tKnots sStride tStride control sOrder tOrder = gluNurbsSurface nurbsObj sKnotCount sKnots tKnotCount tKnots sStride tStride (castPtr control) sOrder tOrder (map2Target (pseudoPeek control)) -------------------------------------------------------------------------------- -- chapter 7.5: Trimming class TrimmingPoint p where trimmingTarget :: p GLfloat -> GLenum instance TrimmingPoint Vertex2 where trimmingTarget = const glu_MAP1_TRIM_2 instance TrimmingPoint Vertex3 where trimmingTarget = const glu_MAP1_TRIM_3 nurbsBeginEndTrim :: NURBSObj -> IO a -> IO a nurbsBeginEndTrim nurbsObj = bracket_ (gluBeginTrim nurbsObj) (gluEndTrim nurbsObj) pwlCurve :: TrimmingPoint p => NURBSObj -> GLint -> Ptr (p GLfloat) -> GLint -> IO () pwlCurve nurbsObj count points stride = gluPwlCurve nurbsObj count (castPtr points) stride (trimmingTarget (pseudoPeek points)) trimmingCurve :: TrimmingPoint c => NURBSObj -> GLint -> Ptr GLfloat -> GLint -> Ptr (c GLfloat) -> GLint -> IO () trimmingCurve nurbsObj knotCount knots stride control order = gluNurbsCurve nurbsObj knotCount knots stride (castPtr control) order (trimmingTarget (pseudoPeek control)) -------------------------------------------------------------------------------- data NURBSMode = NURBSTessellator | NURBSRenderer deriving ( Eq, Ord, Show ) marshalNURBSMode :: NURBSMode -> GLfloat marshalNURBSMode x = fromIntegral $ case x of NURBSTessellator -> glu_NURBS_TESSELLATOR NURBSRenderer -> glu_NURBS_RENDERER setNURBSMode :: NURBSObj -> NURBSMode -> IO () setNURBSMode nurbsObj = gluNurbsProperty nurbsObj glu_NURBS_MODE . marshalNURBSMode -------------------------------------------------------------------------------- setNURBSCulling :: NURBSObj -> Capability -> IO () setNURBSCulling nurbsObj = gluNurbsProperty nurbsObj glu_CULLING . fromIntegral . marshalCapability -------------------------------------------------------------------------------- data SamplingMethod' = PathLength' | ParametricError' | DomainDistance' | ObjectPathLength' | ObjectParametricError' marshalSamplingMethod' :: SamplingMethod' -> GLfloat marshalSamplingMethod' x = fromIntegral $ case x of PathLength' -> glu_PATH_LENGTH ParametricError' -> glu_PARAMETRIC_TOLERANCE DomainDistance' -> glu_DOMAIN_DISTANCE ObjectPathLength' -> glu_OBJECT_PATH_LENGTH ObjectParametricError' -> glu_OBJECT_PARAMETRIC_ERROR setSamplingMethod' :: NURBSObj -> SamplingMethod' -> IO () setSamplingMethod' nurbsObj = gluNurbsProperty nurbsObj glu_SAMPLING_METHOD . marshalSamplingMethod' -------------------------------------------------------------------------------- data SamplingMethod = PathLength GLfloat | ParametricError GLfloat | DomainDistance GLfloat GLfloat | ObjectPathLength GLfloat | ObjectParametricError GLfloat deriving ( Eq, Ord, Show ) setSamplingMethod :: NURBSObj -> SamplingMethod -> IO () setSamplingMethod nurbsObj x = case x of PathLength s -> do gluNurbsProperty nurbsObj glu_SAMPLING_TOLERANCE s setSamplingMethod' nurbsObj PathLength' ParametricError p -> do gluNurbsProperty nurbsObj glu_PARAMETRIC_TOLERANCE p setSamplingMethod' nurbsObj ParametricError' DomainDistance u v -> do gluNurbsProperty nurbsObj glu_U_STEP u gluNurbsProperty nurbsObj glu_V_STEP v setSamplingMethod' nurbsObj DomainDistance' ObjectPathLength s -> do gluNurbsProperty nurbsObj glu_SAMPLING_TOLERANCE s setSamplingMethod' nurbsObj ObjectPathLength' ObjectParametricError p -> do gluNurbsProperty nurbsObj glu_PARAMETRIC_TOLERANCE p setSamplingMethod' nurbsObj ObjectParametricError' -------------------------------------------------------------------------------- setAutoLoadMatrix :: NURBSObj -> Bool -> IO () setAutoLoadMatrix nurbsObj = gluNurbsProperty nurbsObj glu_AUTO_LOAD_MATRIX . marshalGLboolean loadSamplingMatrices :: (Matrix m1, Matrix m2) => NURBSObj -> Maybe (m1 GLfloat, m2 GLfloat, (Position, Size)) -> IO () loadSamplingMatrices nurbsObj = maybe (setAutoLoadMatrix nurbsObj True) (\(mv, proj, (Position x y, Size w h)) -> do withMatrixColumnMajor mv $ \mvBuf -> withMatrixColumnMajor proj $ \projBuf -> withArray [x, y, fromIntegral w, fromIntegral h] $ \viewportBuf -> gluLoadSamplingMatrices nurbsObj mvBuf projBuf viewportBuf setAutoLoadMatrix nurbsObj False) withMatrixColumnMajor :: (Matrix m, MatrixComponent c) => m c -> (Ptr c -> IO a) -> IO a withMatrixColumnMajor mat act = withMatrix mat $ \order p -> if order == ColumnMajor then act p else do elems <- mapM (peekElemOff p) [ 0, 4, 8, 12, 1, 5, 9, 13, 2, 6, 10, 14, 3, 7, 11, 15 ] withArray elems act -------------------------------------------------------------------------------- data DisplayMode' = Fill' | OutlinePolygon | OutlinePatch deriving ( Eq, Ord, Show ) marshalDisplayMode' :: DisplayMode' -> GLfloat marshalDisplayMode' x = fromIntegral $ case x of Fill' -> glu_FILL OutlinePolygon -> glu_OUTLINE_POLYGON OutlinePatch -> glu_OUTLINE_PATCH setDisplayMode' :: NURBSObj -> DisplayMode' -> IO () setDisplayMode' nurbsObj = gluNurbsProperty nurbsObj glu_DISPLAY_MODE . marshalDisplayMode' OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GLU/Mipmapping.hs0000644000000000000000000000511212521420345021716 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GLU.Mipmapping -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to chapter 3 (Mipmapping) of the GLU specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GLU.Mipmapping ( scaleImage, build1DMipmaps, build2DMipmaps ) where import Graphics.Rendering.GLU.Raw import Graphics.Rendering.OpenGL.GL.CoordTrans ( Size(..) ) import Graphics.Rendering.OpenGL.GL.Texturing.PixelInternalFormat import Graphics.Rendering.OpenGL.GL.PixelData ( PixelData, withPixelData ) import Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget import Graphics.Rendering.OpenGL.GLU.ErrorsInternal ( recordInvalidValue ) import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- Section 3.1 (Image Scaling) scaleImage :: Size -> PixelData a -> Size -> PixelData b -> IO () scaleImage (Size widthIn heightIn) pdIn (Size widthOut heightOut) pdOut = withPixelData pdIn $ \fIn dIn pIn -> withPixelData pdOut $ \fOut dOut pOut -> if fIn == fOut then do _ <- gluScaleImage fIn widthIn heightIn dIn pIn widthOut heightOut dOut pOut return () -- TODO: Should we use the return value? else recordInvalidValue -------------------------------------------------------------------------------- -- Section 3.2 (Automatic Mipmapping) -- Missing for GLU 1.3: gluBuild3DMipmaps, gluBuild{1,2,3}DMipmapLevels build1DMipmaps :: TextureTarget1D -> PixelInternalFormat -> GLsizei -> PixelData a -> IO () build1DMipmaps target internalFormat height pd = do _ <- withPixelData pd $ gluBuild1DMipmaps (marshalGettableTextureTarget target) (marshalPixelInternalFormat internalFormat) height return () -- TODO: Should we use the return value? -------------------------------------------------------------------------------- build2DMipmaps :: TextureTarget2D -> PixelInternalFormat -> GLsizei -> GLsizei -> PixelData a -> IO () build2DMipmaps target internalFormat width height pd = do _ <- withPixelData pd $ gluBuild2DMipmaps (marshalGettableTextureTarget target) (marshalPixelInternalFormat internalFormat) width height return () -- TODO: Should we use the return value? OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GLU/Quadrics.hs0000644000000000000000000001236512521420345021400 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GLU.Quadrics -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to chapter 6 (Quadrics) of the GLU specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GLU.Quadrics ( QuadricNormal, QuadricTexture(..), QuadricOrientation(..), QuadricDrawStyle(..), QuadricStyle(..), Radius, Height, Angle, Slices, Stacks, Loops, QuadricPrimitive(..), renderQuadric ) where import Control.Monad ( unless ) import Foreign.Ptr ( Ptr, nullPtr, freeHaskellFunPtr ) import Graphics.Rendering.GLU.Raw import Graphics.Rendering.OpenGL.GL.Colors ( ShadingModel(Smooth,Flat) ) import Graphics.Rendering.OpenGL.GL.Exception ( bracket ) import Graphics.Rendering.OpenGL.GL.GLboolean ( marshalGLboolean ) import Graphics.Rendering.OpenGL.GLU.ErrorsInternal ( recordErrorCode, recordOutOfMemory ) import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data QuadricDrawStyle = PointStyle | LineStyle | FillStyle | SilhouetteStyle deriving ( Eq, Ord, Show ) marshalQuadricDrawStyle :: QuadricDrawStyle -> GLenum marshalQuadricDrawStyle x = case x of PointStyle -> glu_POINT LineStyle -> glu_LINE FillStyle -> glu_FILL SilhouetteStyle -> glu_SILHOUETTE -------------------------------------------------------------------------------- type QuadricNormal = Maybe ShadingModel marshalQuadricNormal :: QuadricNormal -> GLenum marshalQuadricNormal (Just Smooth) = glu_SMOOTH marshalQuadricNormal (Just Flat ) = glu_FLAT marshalQuadricNormal Nothing = glu_NONE -------------------------------------------------------------------------------- data QuadricOrientation = Outside | Inside deriving ( Eq, Ord, Show ) marshalQuadricOrientation :: QuadricOrientation -> GLenum marshalQuadricOrientation x = case x of Outside -> glu_OUTSIDE Inside -> glu_INSIDE -------------------------------------------------------------------------------- data QuadricTexture = NoTextureCoordinates | GenerateTextureCoordinates deriving ( Eq,Ord ) marshalQuadricTexture :: QuadricTexture -> GLboolean marshalQuadricTexture NoTextureCoordinates = marshalGLboolean False marshalQuadricTexture GenerateTextureCoordinates = marshalGLboolean True -------------------------------------------------------------------------------- data QuadricStyle = QuadricStyle QuadricNormal QuadricTexture QuadricOrientation QuadricDrawStyle deriving ( Eq,Ord ) -------------------------------------------------------------------------------- type Radius = GLdouble type Height = GLdouble type Angle = GLdouble type Slices = GLint type Stacks = GLint type Loops = GLint -------------------------------------------------------------------------------- data QuadricPrimitive = Sphere Radius Slices Stacks | Cylinder Radius Radius Height Slices Stacks | Disk Radius Radius Slices Loops | PartialDisk Radius Radius Slices Loops Angle Angle deriving ( Eq, Ord ) -------------------------------------------------------------------------------- renderQuadric :: QuadricStyle -> QuadricPrimitive -> IO () renderQuadric style prim = do withQuadricObj recordOutOfMemory $ \quadricObj -> withErrorCallback quadricObj recordErrorCode $ do setStyle quadricObj style renderPrimitive quadricObj prim withQuadricObj :: IO a -> (QuadricObj -> IO a) -> IO a withQuadricObj failure success = bracket gluNewQuadric safeDeleteQuadric (\quadricObj -> if isNullQuadricObj quadricObj then failure else success quadricObj) safeDeleteQuadric :: QuadricObj -> IO () safeDeleteQuadric quadricObj = unless (isNullQuadricObj quadricObj) $ gluDeleteQuadric quadricObj withErrorCallback :: QuadricObj -> QuadricCallback -> IO a -> IO a withErrorCallback quadricObj callback action = bracket (makeQuadricCallback callback) freeHaskellFunPtr $ \callbackPtr -> do gluQuadricCallback quadricObj glu_ERROR callbackPtr action setStyle :: QuadricObj -> QuadricStyle -> IO () setStyle quadricObj (QuadricStyle n t o d) = do gluQuadricNormals quadricObj (marshalQuadricNormal n) gluQuadricTexture quadricObj (marshalQuadricTexture t) gluQuadricOrientation quadricObj (marshalQuadricOrientation o) gluQuadricDrawStyle quadricObj (marshalQuadricDrawStyle d) renderPrimitive :: QuadricObj -> QuadricPrimitive -> IO () renderPrimitive quadricObj (Sphere r s n) = gluSphere quadricObj r s n renderPrimitive quadricObj (Cylinder b t h s n) = gluCylinder quadricObj b t h s n renderPrimitive quadricObj (Disk i o s l) = gluDisk quadricObj i o s l renderPrimitive quadricObj (PartialDisk i o s l a w) = gluPartialDisk quadricObj i o s l a w -------------------------------------------------------------------------------- type QuadricObj = Ptr GLUquadric isNullQuadricObj :: QuadricObj -> Bool isNullQuadricObj = (nullPtr ==) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GLU/ErrorsInternal.hs0000644000000000000000000001271612521420345022576 0ustar0000000000000000{-# OPTIONS_GHC -fno-cse #-} {-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GLU.ErrorsInternal -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module corresponding to some parts of section 2.5 -- (GL Errors) of the OpenGL 2.1 specs and chapter 8 (Errors) of the GLU specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GLU.ErrorsInternal ( Error(..), ErrorCategory(..), getErrors, recordErrorCode, recordInvalidEnum, recordInvalidValue, recordOutOfMemory ) where import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) import Foreign.C.String ( peekCString ) import Foreign.Ptr ( castPtr ) import Graphics.Rendering.GLU.Raw import Graphics.Rendering.OpenGL.Raw import System.IO.Unsafe ( unsafePerformIO ) -------------------------------------------------------------------------------- -- | GL\/GLU errors consist of a general error category and a description of -- what went wrong. data Error = Error ErrorCategory String deriving ( Eq, Ord, Show ) -------------------------------------------------------------------------------- -- | General GL\/GLU error categories data ErrorCategory = InvalidEnum | InvalidValue | InvalidOperation | InvalidFramebufferOperation | OutOfMemory | StackOverflow | StackUnderflow | TableTooLarge | TesselatorError | NURBSError deriving ( Eq, Ord, Show ) unmarshalErrorCategory :: GLenum -> ErrorCategory unmarshalErrorCategory c | isInvalidEnum c = InvalidEnum | isInvalidValue c = InvalidValue | isInvalidOperation c = InvalidOperation | isInvalidFramebufferOperation c = InvalidFramebufferOperation | isOutOfMemory c = OutOfMemory | isStackOverflow c = StackOverflow | isStackUnderflow c = StackUnderflow | isTableTooLarge c = TableTooLarge | isTesselatorError c = TesselatorError | isNURBSError c = NURBSError | otherwise = error "unmarshalErrorCategory" isInvalidEnum :: GLenum -> Bool isInvalidEnum c = c == gl_INVALID_ENUM || c == glu_INVALID_ENUM isInvalidValue :: GLenum -> Bool isInvalidValue c = c == gl_INVALID_VALUE || c == glu_INVALID_VALUE isInvalidOperation :: GLenum -> Bool isInvalidOperation c = c == gl_INVALID_OPERATION || c == glu_INVALID_OPERATION isInvalidFramebufferOperation :: GLenum -> Bool isInvalidFramebufferOperation c = c == gl_INVALID_FRAMEBUFFER_OPERATION isOutOfMemory :: GLenum -> Bool isOutOfMemory c = c == gl_OUT_OF_MEMORY || c == glu_OUT_OF_MEMORY isStackOverflow :: GLenum -> Bool isStackOverflow c = c == gl_STACK_OVERFLOW isStackUnderflow :: GLenum -> Bool isStackUnderflow c = c == gl_STACK_UNDERFLOW isTableTooLarge :: GLenum -> Bool isTableTooLarge c = c == gl_TABLE_TOO_LARGE isTesselatorError :: GLenum -> Bool isTesselatorError c = glu_TESS_ERROR1 <= c && c <= glu_TESS_ERROR8 isNURBSError :: GLenum -> Bool isNURBSError c = glu_NURBS_ERROR1 <= c && c <= glu_NURBS_ERROR37 -------------------------------------------------------------------------------- -- The returned error string is statically allocated, so peekCString -- does the right thing here. No malloc/free necessary here. makeError :: GLenum -> IO Error makeError e = do let category = unmarshalErrorCategory e ptr <- gluErrorString e description <- peekCString (castPtr ptr) return $ Error category description -------------------------------------------------------------------------------- -- This seems to be a common Haskell hack nowadays: A plain old global variable -- with an associated getter and mutator. Perhaps some language/library support -- is needed? {-# NOINLINE theRecordedErrors #-} theRecordedErrors :: IORef ([GLenum],Bool) theRecordedErrors = unsafePerformIO (newIORef ([], True)) getRecordedErrors :: IO ([GLenum],Bool) getRecordedErrors = readIORef theRecordedErrors setRecordedErrors :: ([GLenum],Bool) -> IO () setRecordedErrors = writeIORef theRecordedErrors -------------------------------------------------------------------------------- getGLErrors :: IO [GLenum] getGLErrors = getGLErrorsAux [] where getGLErrorsAux acc = do errorCode <- glGetError if isError errorCode then getGLErrorsAux (errorCode : acc) else return $ reverse acc isError :: GLenum -> Bool isError = (/= gl_NO_ERROR) -------------------------------------------------------------------------------- getErrors :: IO [Error] getErrors = do es <- getErrorCodesAux (const ([], True)) mapM makeError es recordErrorCode :: GLenum -> IO () recordErrorCode e = do -- We don't need the return value because this calls setRecordedErrors _ <- getErrorCodesAux (\es -> (if null es then [e] else [], False)) return () recordInvalidEnum :: IO () recordInvalidEnum = recordErrorCode gl_INVALID_ENUM recordInvalidValue :: IO () recordInvalidValue = recordErrorCode gl_INVALID_VALUE recordOutOfMemory :: IO () recordOutOfMemory = recordErrorCode gl_OUT_OF_MEMORY -- ToDo: Make this thread-safe getErrorCodesAux :: ([GLenum] -> ([GLenum],Bool)) -> IO [GLenum] getErrorCodesAux f = do (recordedErrors, useGLErrors) <- getRecordedErrors glErrors <- getGLErrors let es = if useGLErrors then recordedErrors ++ glErrors else recordedErrors setRecordedErrors (f es) return es OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GLU/Tessellation.hs0000644000000000000000000004564612521420345022303 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GLU.Tessellation -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to chapter 5 (Polygon Tessellation) of the GLU specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GLU.Tessellation ( -- * Polygon description AnnotatedVertex(..), ComplexContour(..), ComplexPolygon(..), -- * Combining vertices WeightedProperties(..), Combiner, -- * Tessellation parameters TessWinding(..), Tolerance, -- * Tessellator type Tessellator, -- * Contour extraction SimpleContour(..), PolygonContours(..), extractContours, -- * Triangulation TriangleVertex, Triangle(..), Triangulation(..), triangulate, -- * Tessellation into primitives Primitive(..), SimplePolygon(..), tessellate ) where import Control.Monad ( foldM_, unless ) import Data.IORef ( newIORef, readIORef, writeIORef, modifyIORef ) import Data.Maybe ( fromJust, fromMaybe ) import Foreign.Marshal.Alloc ( allocaBytes ) import Foreign.Marshal.Array ( peekArray, pokeArray ) import Foreign.Marshal.Pool ( Pool, withPool, pooledNew ) import Foreign.Ptr ( Ptr, nullPtr, plusPtr, castPtr, freeHaskellFunPtr ) import Foreign.Storable ( Storable(..) ) import Graphics.Rendering.GLU.Raw import Graphics.Rendering.OpenGL.GL.Tensor import Graphics.Rendering.OpenGL.GL.EdgeFlag ( unmarshalEdgeFlag ) import Graphics.Rendering.OpenGL.GL.Exception ( bracket ) import Graphics.Rendering.OpenGL.GL.GLboolean ( marshalGLboolean ) import Graphics.Rendering.OpenGL.GL.PrimitiveMode ( PrimitiveMode ) import Graphics.Rendering.OpenGL.GL.PrimitiveModeInternal ( unmarshalPrimitiveMode ) import Graphics.Rendering.OpenGL.GL.BeginEnd ( EdgeFlag(BeginsInteriorEdge) ) import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data TessWinding = TessWindingOdd | TessWindingNonzero | TessWindingPositive | TessWindingNegative | TessWindingAbsGeqTwo deriving ( Eq, Ord, Show ) marshalTessWinding :: TessWinding -> GLenum marshalTessWinding x = case x of TessWindingOdd -> glu_TESS_WINDING_ODD TessWindingNonzero -> glu_TESS_WINDING_NONZERO TessWindingPositive -> glu_TESS_WINDING_POSITIVE TessWindingNegative -> glu_TESS_WINDING_NEGATIVE TessWindingAbsGeqTwo -> glu_TESS_WINDING_ABS_GEQ_TWO -------------------------------------------------------------------------------- -- | The basic building block in tessellation is a 3D vertex with an associated -- property, e.g. color, texture coordinates, etc. data AnnotatedVertex v = AnnotatedVertex (Vertex3 GLdouble) v deriving ( Eq, Ord ) offsetOfProperty :: Storable v => v -> Int offsetOfProperty v = alignOffset v (3 * sizeOf x) where AnnotatedVertex (Vertex3 x _ _) _ = undefined alignOffset :: Storable a => a -> Int -> Int alignOffset x offset = n - (n `mod` a) where a = alignment x n = a + offset - 1 instance Storable v => Storable (AnnotatedVertex v) where sizeOf ~(AnnotatedVertex (Vertex3 x _ _) v) = alignOffset x (sizeOf v + offsetOfProperty v) alignment ~(AnnotatedVertex (Vertex3 x _ _) _) = alignment x peek ptr = do x <- peekElemOff (castPtr ptr) 0 y <- peekElemOff (castPtr ptr) 1 z <- peekElemOff (castPtr ptr) 2 let dummyElement :: Ptr (AnnotatedVertex v) -> v dummyElement = undefined v <- peekByteOff (castPtr ptr) (offsetOfProperty (dummyElement ptr)) return $ AnnotatedVertex (Vertex3 x y z) v poke ptr (AnnotatedVertex (Vertex3 x y z) v) = do pokeElemOff (castPtr ptr) 0 x pokeElemOff (castPtr ptr) 1 y pokeElemOff (castPtr ptr) 2 z pokeByteOff (castPtr ptr) (offsetOfProperty v) v -------------------------------------------------------------------------------- -- | A complex contour, which can be self-intersecting and\/or concave. newtype ComplexContour v = ComplexContour [AnnotatedVertex v] deriving ( Eq, Ord ) sizeOfComplexContour :: Storable v => ComplexContour v -> Int sizeOfComplexContour (ComplexContour vs) = length vs * sizeOf (head vs) pokeComplexContour :: Storable v => Ptr (ComplexContour v) -> ComplexContour v -> IO () pokeComplexContour ptr (ComplexContour vs) = pokeArray (castPtr ptr) vs -------------------------------------------------------------------------------- -- | A complex (possibly concave) polygon, represented by one or more complex -- and possibly intersecting contours. newtype ComplexPolygon v = ComplexPolygon [ComplexContour v] deriving ( Eq, Ord ) sizeOfComplexPolygon :: Storable v => ComplexPolygon v -> Int sizeOfComplexPolygon (ComplexPolygon complexContours) = sum (map sizeOfComplexContour complexContours) pokeComplexPolygon :: Storable v => Ptr (ComplexPolygon v) -> ComplexPolygon v -> IO () pokeComplexPolygon ptr (ComplexPolygon complexContours) = foldM_ pokeAndAdvance (castPtr ptr) complexContours >> return () where pokeAndAdvance p complexContour = do pokeComplexContour p complexContour return $ p `plusPtr` sizeOfComplexContour complexContour withComplexPolygon :: Storable v => ComplexPolygon v -> (Ptr (ComplexPolygon v) -> IO a) -> IO a withComplexPolygon complexPolygon f = allocaBytes (sizeOfComplexPolygon complexPolygon) $ \ptr -> do pokeComplexPolygon ptr complexPolygon f ptr -------------------------------------------------------------------------------- -- | Four vertex properties (cf. 'AnnotatedVertex') with associated weigths -- summing up to 1.0. data WeightedProperties v = WeightedProperties (GLfloat, v) (GLfloat, v) (GLfloat, v) (GLfloat, v) deriving ( Eq, Ord ) -- | A function combining given vertex properties into a property for a newly -- generated vertex type Combiner v = Vertex3 GLdouble -> WeightedProperties v -> v -------------------------------------------------------------------------------- -- | The relative tolerance under which two vertices can be combined (see -- 'Combiner'). Multiplication with the largest coordinate magnitude of all -- polygon vertices yields the maximum distance between two mergeable vertices. -- -- Note that merging is optional and the tolerance is only a hint. type Tolerance = GLdouble -------------------------------------------------------------------------------- -- | A general tessellator type. -- -- Before tessellation of a complex polygon, all its vertices are projected into -- a plane perpendicular to the given normal. If the given normal is -- @Normal3 0 0 0@, a fitting plane of all vertices is used. type Tessellator p v = TessWinding -> Tolerance -> Normal3 GLdouble -> Combiner v -> ComplexPolygon v -> IO (p v) -------------------------------------------------------------------------------- -- | A simple, non-self-intersecting contour newtype SimpleContour v = SimpleContour [AnnotatedVertex v] deriving ( Eq, Ord ) -- | The contours of a complex polygon, represented by one or more -- non-intersecting simple contours newtype PolygonContours v = PolygonContours [SimpleContour v] deriving ( Eq, Ord ) extractContours :: Storable v => Tessellator PolygonContours v extractContours windingRule tolerance theNormal combiner complexPoly = do vertices <- newIORef [] let addVertex v = modifyIORef vertices (v:) contours <- newIORef [] let finishContour = do vs <- readIORef vertices writeIORef vertices [] modifyIORef contours (SimpleContour (reverse vs) :) getContours = fmap (PolygonContours . reverse) (readIORef contours) withTessellatorObj (PolygonContours [])$ \tessObj -> do setTessellatorProperties tessObj windingRule tolerance theNormal True withVertexCallback tessObj addVertex $ withEndCallback tessObj finishContour $ checkForError tessObj $ withCombineCallback tessObj combiner $ do defineComplexPolygon tessObj complexPoly getContours -------------------------------------------------------------------------------- -- | A triangle vertex with additional information about the edge it begins type TriangleVertex v = AnnotatedVertex (v,EdgeFlag) -- | A triangle, represented by three triangle vertices data Triangle v = Triangle (TriangleVertex v) (TriangleVertex v) (TriangleVertex v) deriving ( Eq, Ord ) -- | A triangulation of a complex polygon newtype Triangulation v = Triangulation [Triangle v] deriving ( Eq, Ord ) triangulate :: Storable v => Tessellator Triangulation v triangulate windingRule tolerance theNormal combiner complexPoly = do edgeFlagState <- newIORef BeginsInteriorEdge let registerEdgeFlag = writeIORef edgeFlagState vertices <- newIORef [] let addVertex (AnnotatedVertex xyz v) = do ef <- readIORef edgeFlagState modifyIORef vertices (AnnotatedVertex xyz (v,ef) :) getTriangulation = do vs <- readIORef vertices return $ Triangulation (collectTriangles (reverse vs)) withTessellatorObj (Triangulation []) $ \tessObj -> do setTessellatorProperties tessObj windingRule tolerance theNormal False withEdgeFlagCallback tessObj registerEdgeFlag $ withVertexCallback tessObj addVertex $ checkForError tessObj $ withCombineCallback tessObj combiner $ do defineComplexPolygon tessObj complexPoly getTriangulation collectTriangles :: [TriangleVertex v] -> [Triangle v] collectTriangles [] = [] collectTriangles (a:b:c:rest) = Triangle a b c : collectTriangles rest collectTriangles _ = error "triangles left" -------------------------------------------------------------------------------- data Primitive v = Primitive PrimitiveMode [AnnotatedVertex v] deriving ( Eq, Ord ) newtype SimplePolygon v = SimplePolygon [Primitive v] deriving ( Eq, Ord ) tessellate :: Storable v => Tessellator SimplePolygon v tessellate windingRule tolerance theNormal combiner complexPoly = do beginModeState <- newIORef undefined let setPrimitiveMode = writeIORef beginModeState vertices <- newIORef [] let addVertex v = modifyIORef vertices (v:) primitives <- newIORef [] let finishPrimitive = do beginMode <- readIORef beginModeState vs <- readIORef vertices writeIORef vertices [] modifyIORef primitives (Primitive beginMode (reverse vs) :) getSimplePolygon = fmap (SimplePolygon . reverse) (readIORef primitives) withTessellatorObj (SimplePolygon []) $ \tessObj -> do setTessellatorProperties tessObj windingRule tolerance theNormal False withBeginCallback tessObj setPrimitiveMode $ withVertexCallback tessObj addVertex $ withEndCallback tessObj finishPrimitive $ checkForError tessObj $ withCombineCallback tessObj combiner $ do defineComplexPolygon tessObj complexPoly getSimplePolygon -------------------------------------------------------------------------------- -- chapter 5.1: The Tessellation Object -- an opaque pointer to a tessellator object type TessellatorObj = Ptr GLUtesselator isNullTesselatorObj :: TessellatorObj -> Bool isNullTesselatorObj = (nullPtr ==) withTessellatorObj :: a -> (TessellatorObj -> IO a) -> IO a withTessellatorObj failureValue action = bracket gluNewTess safeDeleteTess (\tessObj -> if isNullTesselatorObj tessObj then do recordOutOfMemory return failureValue else action tessObj) safeDeleteTess :: TessellatorObj -> IO () safeDeleteTess tessObj = unless (isNullTesselatorObj tessObj) $ gluDeleteTess tessObj -------------------------------------------------------------------------------- -- chapter 5.2: Polygon Definition (polygons) defineComplexPolygon :: Storable v => TessellatorObj -> ComplexPolygon v -> IO () defineComplexPolygon tessObj cp@(ComplexPolygon complexContours) = withComplexPolygon cp $ \ptr -> tessBeginEndPolygon tessObj nullPtr $ let loop _ [] = return () loop p (c:cs) = do defineComplexContour tessObj (castPtr p) c loop (p `plusPtr` sizeOfComplexContour c) cs in loop ptr complexContours tessBeginEndPolygon :: TessellatorObj -> Ptr p -> IO a -> IO a tessBeginEndPolygon tessObj ptr f = do gluTessBeginPolygon tessObj ptr res <- f gluTessEndPolygon tessObj return res -------------------------------------------------------------------------------- -- chapter 5.2: Polygon Definition (contours) defineComplexContour :: Storable v => TessellatorObj -> Ptr (ComplexContour v) -> ComplexContour v -> IO () defineComplexContour tessObj ptr (ComplexContour annotatedVertices) = tessBeginEndContour tessObj $ let loop _ [] = return () loop p (v:vs) = do defineVertex tessObj (castPtr p) loop (p `plusPtr` sizeOf v) vs in loop ptr annotatedVertices tessBeginEndContour :: TessellatorObj -> IO a -> IO a tessBeginEndContour tessObj f = do gluTessBeginContour tessObj res <- f gluTessEndContour tessObj return res -------------------------------------------------------------------------------- -- chapter 5.2: Polygon Definition (vertices) defineVertex :: TessellatorObj -> Ptr (AnnotatedVertex v) -> IO () defineVertex tessObj ptr = gluTessVertex tessObj (castPtr ptr) ptr -------------------------------------------------------------------------------- -- chapter 5.3: Callbacks (begin) type BeginCallback = PrimitiveMode -> IO () withBeginCallback :: TessellatorObj -> BeginCallback -> IO a -> IO a withBeginCallback tessObj beginCallback action = bracket (makeTessBeginCallback (beginCallback . unmarshalPrimitiveMode)) freeHaskellFunPtr $ \callbackPtr -> do gluTessCallback tessObj glu_TESS_BEGIN callbackPtr action -------------------------------------------------------------------------------- -- chapter 5.3: Callbacks (edgeFlag) type EdgeFlagCallback = EdgeFlag -> IO () withEdgeFlagCallback :: TessellatorObj -> EdgeFlagCallback -> IO a -> IO a withEdgeFlagCallback tessObj edgeFlagCallback action = bracket (makeTessEdgeFlagCallback (edgeFlagCallback . unmarshalEdgeFlag)) freeHaskellFunPtr $ \callbackPtr -> do gluTessCallback tessObj glu_TESS_EDGE_FLAG callbackPtr action -------------------------------------------------------------------------------- -- chapter 5.3: Callbacks (vertex) type VertexCallback v = AnnotatedVertex v -> IO () withVertexCallback :: Storable v => TessellatorObj -> VertexCallback v -> IO a -> IO a withVertexCallback tessObj vertexCallback action = bracket (makeTessVertexCallback (\p -> peek p >>= vertexCallback)) freeHaskellFunPtr $ \callbackPtr -> do gluTessCallback tessObj glu_TESS_VERTEX callbackPtr action -------------------------------------------------------------------------------- -- chapter 5.3: Callbacks (end) type EndCallback = IO () withEndCallback :: TessellatorObj -> EndCallback -> IO a -> IO a withEndCallback tessObj endCallback action = bracket (makeTessEndCallback endCallback) freeHaskellFunPtr $ \callbackPtr -> do gluTessCallback tessObj glu_TESS_END callbackPtr action -------------------------------------------------------------------------------- -- chapter 5.3: Callbacks (error) type ErrorCallback = GLenum -> IO () withErrorCallback :: TessellatorObj -> ErrorCallback -> IO a -> IO a withErrorCallback tessObj errorCallback action = bracket (makeTessErrorCallback errorCallback) freeHaskellFunPtr $ \callbackPtr -> do gluTessCallback tessObj glu_TESS_ERROR callbackPtr action checkForError :: TessellatorObj -> IO a -> IO a checkForError tessObj = withErrorCallback tessObj recordErrorCode -------------------------------------------------------------------------------- -- chapter 5.3: Callbacks (combine) type CombineCallback v = Ptr GLdouble -> Ptr (Ptr (AnnotatedVertex v)) -> Ptr GLfloat -> Ptr (Ptr (AnnotatedVertex v)) -> IO () withCombineCallback :: Storable v => TessellatorObj -> Combiner v -> IO a -> IO a withCombineCallback tessObj combiner action = withPool $ \vertexPool -> bracket (makeTessCombineCallback (combineProperties vertexPool combiner)) freeHaskellFunPtr $ \callbackPtr -> do gluTessCallback tessObj glu_TESS_COMBINE callbackPtr action -- NOTE: SGI's tesselator has a bug, sometimes passing NULL for the last two -- vertices instead of valid vertex data, so we have to work around this. We -- just pass the first vertex in these cases, which is OK, because the -- corresponding weight is 0. combineProperties :: Storable v => Pool -> Combiner v -> CombineCallback v combineProperties pool combiner newVertexPtr propertyPtrs weights result = do newVertex <- peek (castPtr newVertexPtr :: Ptr (Vertex3 GLdouble)) [v0, v1, v2, v3] <- mapM (getProperty propertyPtrs) [0..3] [w0, w1, w2, w3] <- peekArray 4 weights let defaultProperty = fromJust v0 f = fromMaybe defaultProperty wp = WeightedProperties (w0, f v0) (w1, f v1) (w2, f v2) (w3, f v3) av = AnnotatedVertex newVertex (combiner newVertex wp) poke result =<< pooledNew pool av getProperty :: Storable v => Ptr (Ptr (AnnotatedVertex v)) -> Int -> IO (Maybe v) getProperty propertyPtrs n = peekElemOff propertyPtrs n >>= maybeNullPtr (return Nothing) peekProperty peekProperty :: Storable v => Ptr (AnnotatedVertex v) -> IO (Maybe v) peekProperty ptr = do AnnotatedVertex _ v <- peek ptr return (Just v) -------------------------------------------------------------------------------- -- chapter 5.4: Control over Tessellation setTessellatorProperties :: TessellatorObj -> TessWinding -> Tolerance -> Normal3 GLdouble -> Bool -> IO () setTessellatorProperties tessObj windingRule tolerance theNormal boundaryOnly = do setWindingRule tessObj windingRule setTolerance tessObj tolerance setNormal tessObj theNormal setBoundaryOnly tessObj boundaryOnly setWindingRule :: TessellatorObj -> TessWinding -> IO () setWindingRule tessObj = gluTessProperty tessObj glu_TESS_WINDING_RULE . fromIntegral . marshalTessWinding setBoundaryOnly :: TessellatorObj -> Bool -> IO () setBoundaryOnly tessObj = gluTessProperty tessObj glu_TESS_BOUNDARY_ONLY . marshalGLboolean setTolerance :: TessellatorObj -> Tolerance -> IO () setTolerance tessObj = gluTessProperty tessObj glu_TESS_TOLERANCE setNormal :: TessellatorObj -> Normal3 GLdouble -> IO () setNormal tessObj (Normal3 x y z) = gluTessNormal tessObj x y z OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GLU/Initialization.hs0000644000000000000000000000224512521420345022610 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GLU.Initialization -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to chapter 2 (Initialization) of the GLU specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GLU.Initialization ( gluVersion, gluExtensions ) where import Data.StateVar import Foreign.C.String import Foreign.Ptr import Graphics.Rendering.GLU.Raw import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- gluVersion :: GettableStateVar String gluVersion = makeGettableStateVar (getString glu_VERSION) gluExtensions :: GettableStateVar [String] gluExtensions = makeGettableStateVar (fmap words $ getString glu_EXTENSIONS) getString :: GLenum -> IO String getString n = gluGetString n >>= maybeNullPtr (return "") (peekCString . castPtr) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GLU/Matrix.hs0000644000000000000000000001113012521420345021056 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GLU.Matrix -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to chapter 4 (Matrix Manipulation) of the GLU specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GLU.Matrix ( ortho2D, perspective, lookAt, pickMatrix, project, unProject, unProject4 ) where import Foreign.Marshal.Alloc import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.GLU.Raw import Graphics.Rendering.OpenGL.GL.CoordTrans import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.Tensor import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- matrix setup ortho2D :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> IO () ortho2D = gluOrtho2D perspective :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> IO () perspective = gluPerspective lookAt :: Vertex3 GLdouble -> Vertex3 GLdouble -> Vector3 GLdouble -> IO () lookAt (Vertex3 eyeX eyeY eyeZ) (Vertex3 centerX centerY centerZ) (Vector3 upX upY upZ) = gluLookAt eyeX eyeY eyeZ centerX centerY centerZ upX upY upZ pickMatrix :: (GLdouble, GLdouble) -> (GLdouble, GLdouble) -> (Position, Size) -> IO () pickMatrix (x, y) (w, h) viewPort = withViewport viewPort $ gluPickMatrix x y w h -------------------------------------------------------------------------------- -- coordinate projection project :: Matrix m => Vertex3 GLdouble -> m GLdouble -> m GLdouble -> (Position, Size) -> IO (Vertex3 GLdouble) project (Vertex3 objX objY objZ) model proj viewPort = withColumnMajor model $ \modelBuf -> withColumnMajor proj $ \projBuf -> withViewport viewPort $ \viewBuf -> getVertex3 $ gluProject objX objY objZ modelBuf projBuf viewBuf unProject :: Matrix m => Vertex3 GLdouble -> m GLdouble -> m GLdouble -> (Position, Size) -> IO (Vertex3 GLdouble) unProject (Vertex3 objX objY objZ) model proj viewPort = withColumnMajor model $ \modelBuf -> withColumnMajor proj $ \projBuf -> withViewport viewPort $ \viewBuf -> getVertex3 $ gluUnProject objX objY objZ modelBuf projBuf viewBuf unProject4 :: Matrix m => Vertex4 GLdouble -> m GLdouble -> m GLdouble -> (Position, Size) -> GLclampd -> GLclampd -> IO (Vertex4 GLdouble) unProject4 (Vertex4 objX objY objZ clipW) model proj viewPort near far = withColumnMajor model $ \modelBuf -> withColumnMajor proj $ \projBuf -> withViewport viewPort $ \viewBuf -> getVertex4 $ gluUnProject4 objX objY objZ clipW modelBuf projBuf viewBuf near far -------------------------------------------------------------------------------- withViewport :: (Position, Size) -> (Ptr GLint -> IO a ) -> IO a withViewport (Position x y, Size w h) = withArray [ x, y, fromIntegral w, fromIntegral h ] withColumnMajor :: (Matrix m, MatrixComponent c) => m c -> (Ptr c -> IO b) -> IO b withColumnMajor mat act = withMatrix mat juggle where juggle ColumnMajor p = act p juggle RowMajor p = do transposedElems <- mapM (peekElemOff p) [ 0, 4, 8, 12, 1, 5, 9, 13, 2, 6, 10, 14, 3, 7, 11, 15 ] withArray transposedElems act getVertex3 :: (Ptr GLdouble -> Ptr GLdouble -> Ptr GLdouble -> IO GLint) -> IO (Vertex3 GLdouble) getVertex3 act = alloca $ \xBuf -> alloca $ \yBuf -> alloca $ \zBuf -> do ok <- act xBuf yBuf zBuf if unmarshalGLboolean ok then do x <- peek xBuf y <- peek yBuf z <- peek zBuf return $ Vertex3 x y z else do recordInvalidValue return $ Vertex3 0 0 0 getVertex4 :: (Ptr GLdouble -> Ptr GLdouble -> Ptr GLdouble -> Ptr GLdouble -> IO GLint) -> IO (Vertex4 GLdouble) getVertex4 act = alloca $ \xBuf -> alloca $ \yBuf -> alloca $ \zBuf -> alloca $ \wBuf -> do ok <- act xBuf yBuf zBuf wBuf if unmarshalGLboolean ok then do x <- peek xBuf y <- peek yBuf z <- peek zBuf w <- peek wBuf return $ Vertex4 x y z w else do recordInvalidValue return $ Vertex4 0 0 0 0 OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GLU/Errors.hs0000644000000000000000000000253012521420345021072 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GLU.Errors -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 2.5 (GL Errors) of the OpenGL 2.1 specs -- and chapter 8 (Errors) of the GLU specs, offering a generalized view of -- errors in GL and GLU. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GLU.Errors ( Error(..), ErrorCategory(..), errors ) where import Data.StateVar import Graphics.Rendering.OpenGL.GLU.ErrorsInternal -------------------------------------------------------------------------------- -- | When an error occurs, it is recorded in this state variable and no further -- errors are recorded. Reading 'errors' returns the currently recorded errors -- (there may be more than one due to a possibly distributed implementation) and -- resets the state variable to @[]@, re-enabling the recording of future -- errors. The value @[]@ means that there has been no detectable error since -- the last time 'errors' was read, or since the GL was initialized. errors :: GettableStateVar [Error] errors = makeGettableStateVar getErrors OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/0000755000000000000000000000000012521420345017135 5ustar0000000000000000OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Rectangles.hs0000644000000000000000000000460612521420345021566 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Rectangles -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 10.9 (Rectangles) of the OpenGL 4.4 specs. -- -------------------------------------------------------------------------------- {-# LANGUAGE TypeSynonymInstances #-} module Graphics.Rendering.OpenGL.GL.Rectangles ( Rect(..) ) where import Foreign.Ptr import Graphics.Rendering.OpenGL.GL.Tensor import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- | 'rect' and 'rectv' support efficient specification of rectangles as two -- corner points. Each rectangle command takes four arguments, organized either -- as two consecutive pairs of (/x/, /y/) coordinates, or as two pointers to -- arrays, each containing an (/x/, /y/) pair. The resulting rectangle is -- defined in the /z/ = 0 plane. -- -- @'rect' ('Vertex2' x1 y1) ('Vertex2' x2, y2)@ is exactly equivalent to the -- following sequence: -- -- @ -- 'Graphics.Rendering.OpenGL.GL.BeginEnd.renderPrimitive' 'Graphics.Rendering.OpenGL.GL.BeginEnd.Polygon' $ do -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.vertex' ('Vertex2' x1 y1) -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.vertex' ('Vertex2' x2 y1) -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.vertex' ('Vertex2' x2 y2) -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.vertex' ('Vertex2' x1 y2) -- @ -- -- Note that if the second vertex is above and to the right of the first vertex, -- the rectangle is constructed with a counterclockwise winding. class Rect a where rect :: Vertex2 a -> Vertex2 a -> IO () rectv :: Ptr a -> Ptr a -> IO () instance Rect GLshort where rect (Vertex2 x1 y1) (Vertex2 x2 y2) = glRects x1 y1 x2 y2 rectv ptr1 ptr2 = glRectsv ptr1 ptr2 instance Rect GLint where rect (Vertex2 x1 y1) (Vertex2 x2 y2) = glRecti x1 y1 x2 y2 rectv ptr1 ptr2 = glRectiv ptr1 ptr2 instance Rect GLfloat where rect (Vertex2 x1 y1) (Vertex2 x2 y2) = glRectf x1 y1 x2 y2 rectv ptr1 ptr2 = glRectfv ptr1 ptr2 instance Rect GLdouble where rect (Vertex2 x1 y1) (Vertex2 x2 y2) = glRectd x1 y1 x2 y2 rectv ptr1 ptr2 = glRectdv ptr1 ptr2 OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/VertexArrayObjects.hs0000644000000000000000000000406612521420345023265 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.VertexArrayObjects -- Copyright : (c) Sven Panne, Lars Corbijn 2011-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.VertexArrayObjects ( VertexArrayObject, bindVertexArrayObject ) where import Control.Monad.IO.Class import Data.ObjectName import Data.StateVar import Foreign.Marshal.Array ( allocaArray, peekArray, withArrayLen ) import Graphics.Rendering.OpenGL.GL.DebugOutput import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw ----------------------------------------------------------------------------- newtype VertexArrayObject = VertexArrayObject { vertexArrayID :: GLuint } deriving( Eq, Ord, Show ) instance ObjectName VertexArrayObject where isObjectName = liftIO . fmap unmarshalGLboolean . glIsVertexArray . vertexArrayID deleteObjectNames bufferObjects = liftIO . withArrayLen (map vertexArrayID bufferObjects) $ glDeleteVertexArrays . fromIntegral instance GeneratableObjectName VertexArrayObject where genObjectNames n = liftIO . allocaArray n $ \buf -> do glGenVertexArrays (fromIntegral n) buf fmap (map VertexArrayObject) $ peekArray n buf instance CanBeLabeled VertexArrayObject where objectLabel = objectNameLabel gl_VERTEX_ARRAY . vertexArrayID bindVertexArrayObject :: StateVar (Maybe VertexArrayObject) bindVertexArrayObject = makeStateVar getVAO bindVAO getVAO :: IO (Maybe VertexArrayObject) getVAO = do vao <- getInteger1 (VertexArrayObject . fromIntegral) GetVertexArrayBinding return $ if vao == noVAO then Nothing else Just vao bindVAO :: Maybe VertexArrayObject -> IO () bindVAO = glBindVertexArray . vertexArrayID . maybe noVAO id noVAO :: VertexArrayObject noVAO = VertexArrayObject 0 OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PixelRectangles.hs0000644000000000000000000000310512521420345022561 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 3.6 (Pixel Rectangles) of the OpenGL 2.1 -- specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PixelRectangles ( module Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelStorage, module Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelTransfer, module Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelMap, module Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable, module Graphics.Rendering.OpenGL.GL.PixelRectangles.Convolution, module Graphics.Rendering.OpenGL.GL.PixelRectangles.Histogram, module Graphics.Rendering.OpenGL.GL.PixelRectangles.Minmax, module Graphics.Rendering.OpenGL.GL.PixelRectangles.Rasterization ) where import Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelStorage import Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelTransfer import Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelMap import Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable import Graphics.Rendering.OpenGL.GL.PixelRectangles.Convolution import Graphics.Rendering.OpenGL.GL.PixelRectangles.Histogram import Graphics.Rendering.OpenGL.GL.PixelRectangles.Minmax import Graphics.Rendering.OpenGL.GL.PixelRectangles.Rasterization OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/DisplayLists.hs0000644000000000000000000001072712521420345022124 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.DisplayLists -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 5.4 (Display Lists) of the OpenGL 2.1 -- specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.DisplayLists ( -- * Defining Display Lists DisplayList(DisplayList), ListMode(..), defineList, defineNewList, listIndex, listMode, maxListNesting, -- * Calling Display Lists callList, callLists, listBase ) where import Control.Monad.IO.Class import Data.ObjectName import Data.StateVar import Foreign.Ptr ( Ptr ) import Graphics.Rendering.OpenGL.GL.DebugOutput import Graphics.Rendering.OpenGL.GL.DataType import Graphics.Rendering.OpenGL.GL.Exception import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- newtype DisplayList = DisplayList { displayListID :: GLuint } deriving ( Eq, Ord, Show ) instance ObjectName DisplayList where isObjectName = liftIO . fmap unmarshalGLboolean . glIsList . displayListID deleteObjectNames = liftIO . mapM_ (uncurry glDeleteLists) . combineConsecutive instance CanBeLabeled DisplayList where objectLabel = objectNameLabel gl_DISPLAY_LIST . displayListID combineConsecutive :: [DisplayList] -> [(GLuint, GLsizei)] combineConsecutive [] = [] combineConsecutive (z:zs) = (displayListID z, len) : combineConsecutive rest where (len, rest) = run (0 :: GLsizei) z zs run n x xs = case n + 1 of m -> case xs of [] -> (m, []) (y:ys) | x `isFollowedBy` y -> run m y ys | otherwise -> (m, xs) DisplayList x `isFollowedBy` DisplayList y = x + 1 == y instance GeneratableObjectName DisplayList where genObjectNames n = liftIO $ do first <- glGenLists (fromIntegral n) if DisplayList first == noDisplayList then do recordOutOfMemory return [] else return [ DisplayList l | l <- [ first .. first + fromIntegral n - 1 ] ] -------------------------------------------------------------------------------- data ListMode = Compile | CompileAndExecute deriving ( Eq, Ord, Show ) marshalListMode :: ListMode -> GLenum marshalListMode x = case x of Compile -> gl_COMPILE CompileAndExecute -> gl_COMPILE_AND_EXECUTE unmarshalListMode :: GLenum -> ListMode unmarshalListMode x | x == gl_COMPILE = Compile | x == gl_COMPILE_AND_EXECUTE = CompileAndExecute | otherwise = error ("unmarshalListMode: illegal value " ++ show x) -------------------------------------------------------------------------------- defineList :: DisplayList -> ListMode -> IO a -> IO a defineList dl mode = bracket_ (glNewList (displayListID dl) (marshalListMode mode)) glEndList defineNewList :: ListMode -> IO a -> IO DisplayList defineNewList mode action = do lst <- genObjectName _ <- defineList lst mode action return lst -------------------------------------------------------------------------------- listIndex :: GettableStateVar (Maybe DisplayList) listIndex = makeGettableStateVar (do l <- getEnum1 (DisplayList . fromIntegral) GetListIndex return $ if l == noDisplayList then Nothing else Just l) noDisplayList :: DisplayList noDisplayList = DisplayList 0 listMode :: GettableStateVar ListMode listMode = makeGettableStateVar (getEnum1 unmarshalListMode GetListMode) maxListNesting :: GettableStateVar GLsizei maxListNesting = makeGettableStateVar (getSizei1 id GetMaxListNesting) -------------------------------------------------------------------------------- callList :: DisplayList -> IO () callList = glCallList . displayListID callLists :: GLsizei -> DataType -> Ptr a -> IO () callLists n = glCallLists n . marshalDataType -------------------------------------------------------------------------------- listBase :: StateVar DisplayList listBase = makeStateVar (getEnum1 (DisplayList . fromIntegral) GetListBase) (glListBase . displayListID) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/ControlPoint.hs0000644000000000000000000001275612521420345022136 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.ControlPoint -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for handling control points. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.ControlPoint ( ControlPoint(..) ) where import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.GL.Tensor import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.Domain import Graphics.Rendering.OpenGL.GL.VertexArrays import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- class ControlPoint c where map1Target :: Domain d => c d -> GLenum map2Target :: Domain d => c d -> GLenum enableCap1 :: Domain d => c d -> EnableCap enableCap2 :: Domain d => c d -> EnableCap numComponents :: Domain d => c d -> Stride peekControlPoint :: Domain d => Ptr (c d) -> IO (c d) pokeControlPoint :: Domain d => Ptr (c d) -> (c d) -> IO () instance ControlPoint Vertex3 where map1Target = marshalMapTarget . const Map1Vertex3 map2Target = marshalMapTarget . const Map2Vertex3 enableCap1 = const CapMap1Vertex3 enableCap2 = const CapMap2Vertex3 numComponents = const 3 peekControlPoint = peek pokeControlPoint = poke instance ControlPoint Vertex4 where map1Target = marshalMapTarget . const Map1Vertex4 map2Target = marshalMapTarget . const Map2Vertex4 enableCap1 = const CapMap1Vertex4 enableCap2 = const CapMap2Vertex4 numComponents = const 4 peekControlPoint = peek pokeControlPoint = poke instance ControlPoint Index1 where map1Target = marshalMapTarget . const Map1Index map2Target = marshalMapTarget . const Map2Index enableCap1 = const CapMap1Index enableCap2 = const CapMap2Index numComponents = const 1 peekControlPoint = peek pokeControlPoint = poke instance ControlPoint Color4 where map1Target = marshalMapTarget . const Map1Color4 map2Target = marshalMapTarget . const Map2Color4 enableCap1 = const CapMap1Color4 enableCap2 = const CapMap2Color4 numComponents = const 4 peekControlPoint = peek pokeControlPoint = poke instance ControlPoint Normal3 where map1Target = marshalMapTarget . const Map1Normal map2Target = marshalMapTarget . const Map2Normal enableCap1 = const CapMap1Normal enableCap2 = const CapMap2Normal numComponents = const 3 peekControlPoint = peek pokeControlPoint = poke instance ControlPoint TexCoord1 where map1Target = marshalMapTarget . const Map1TextureCoord1 map2Target = marshalMapTarget . const Map2TextureCoord1 enableCap1 = const CapMap1TextureCoord1 enableCap2 = const CapMap2TextureCoord1 numComponents = const 1 peekControlPoint = peek pokeControlPoint = poke instance ControlPoint TexCoord2 where map1Target = marshalMapTarget . const Map1TextureCoord2 map2Target = marshalMapTarget . const Map2TextureCoord2 enableCap1 = const CapMap1TextureCoord2 enableCap2 = const CapMap2TextureCoord2 numComponents = const 2 peekControlPoint = peek pokeControlPoint = poke instance ControlPoint TexCoord3 where map1Target = marshalMapTarget . const Map1TextureCoord3 map2Target = marshalMapTarget . const Map2TextureCoord3 enableCap1 = const CapMap1TextureCoord3 enableCap2 = const CapMap2TextureCoord3 numComponents = const 3 peekControlPoint = peek pokeControlPoint = poke instance ControlPoint TexCoord4 where map1Target = marshalMapTarget . const Map1TextureCoord4 map2Target = marshalMapTarget . const Map2TextureCoord4 enableCap1 = const CapMap1TextureCoord4 enableCap2 = const CapMap2TextureCoord4 numComponents = const 4 peekControlPoint = peek pokeControlPoint = poke -------------------------------------------------------------------------------- data MapTarget = Map1Color4 | Map1Index | Map1Normal | Map1TextureCoord1 | Map1TextureCoord2 | Map1TextureCoord3 | Map1TextureCoord4 | Map1Vertex3 | Map1Vertex4 | Map2Color4 | Map2Index | Map2Normal | Map2TextureCoord1 | Map2TextureCoord2 | Map2TextureCoord3 | Map2TextureCoord4 | Map2Vertex3 | Map2Vertex4 marshalMapTarget :: MapTarget -> GLenum marshalMapTarget x = case x of Map1Color4 -> gl_MAP1_COLOR_4 Map1Index -> gl_MAP1_INDEX Map1Normal -> gl_MAP1_NORMAL Map1TextureCoord1 -> gl_MAP1_TEXTURE_COORD_1 Map1TextureCoord2 -> gl_MAP1_TEXTURE_COORD_2 Map1TextureCoord3 -> gl_MAP1_TEXTURE_COORD_3 Map1TextureCoord4 -> gl_MAP1_TEXTURE_COORD_4 Map1Vertex3 -> gl_MAP1_VERTEX_3 Map1Vertex4 -> gl_MAP1_VERTEX_4 Map2Color4 -> gl_MAP2_COLOR_4 Map2Index -> gl_MAP2_INDEX Map2Normal -> gl_MAP2_NORMAL Map2TextureCoord1 -> gl_MAP2_TEXTURE_COORD_1 Map2TextureCoord2 -> gl_MAP2_TEXTURE_COORD_2 Map2TextureCoord3 -> gl_MAP2_TEXTURE_COORD_3 Map2TextureCoord4 -> gl_MAP2_TEXTURE_COORD_4 Map2Vertex3 -> gl_MAP2_VERTEX_3 Map2Vertex4 -> gl_MAP2_VERTEX_4 OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Clipping.hs0000644000000000000000000000365012521420345021242 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Clipping -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 13.5 (Primitive Clipping) of the OpenGL -- 4.4 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Clipping ( ClipPlaneName(..), clipPlane, maxClipPlanes ) where import Data.StateVar import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.CoordTrans import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- newtype ClipPlaneName = ClipPlaneName GLsizei deriving ( Eq, Ord, Show ) -------------------------------------------------------------------------------- clipPlane :: ClipPlaneName -> StateVar (Maybe (Plane GLdouble)) clipPlane name = makeStateVarMaybe (return $ nameToCap name) (alloca $ \buf -> do clipPlaneAction name $ flip glGetClipPlane $ castPtr buf peek buf) (\plane -> with plane $ clipPlaneAction name . flip glClipPlane . castPtr) nameToCap :: ClipPlaneName -> EnableCap nameToCap (ClipPlaneName i) = CapClipPlane i clipPlaneAction :: ClipPlaneName -> (GLenum -> IO ()) -> IO () clipPlaneAction (ClipPlaneName i) act = maybe recordInvalidEnum act (clipPlaneIndexToEnum i) -------------------------------------------------------------------------------- maxClipPlanes :: GettableStateVar GLsizei maxClipPlanes = makeGettableStateVar (getSizei1 id GetMaxClipPlanes) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/RasterPos.hs0000644000000000000000000001361212521420345021416 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.RasterPos -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 2.13 (Current Raster Position) of the -- OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- {-# LANGUAGE TypeSynonymInstances #-} module Graphics.Rendering.OpenGL.GL.RasterPos ( currentRasterPosition, RasterPosComponent, RasterPos(..), WindowPosComponent, WindowPos(..), currentRasterDistance, currentRasterColor, currentRasterSecondaryColor, currentRasterIndex, currentRasterTexCoords, currentRasterPositionValid, rasterPositionUnclipped ) where import Data.StateVar import Foreign.Ptr import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.Tensor import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- currentRasterPosition :: StateVar (Vertex4 GLfloat) currentRasterPosition = makeStateVar (getFloat4 Vertex4 GetCurrentRasterPosition) rasterPos -------------------------------------------------------------------------------- class RasterPosComponent a where rasterPos2 :: a -> a -> IO () rasterPos3 :: a -> a -> a -> IO () rasterPos4 :: a -> a -> a -> a -> IO () rasterPos2v :: Ptr a -> IO () rasterPos3v :: Ptr a -> IO () rasterPos4v :: Ptr a -> IO () instance RasterPosComponent GLshort where rasterPos2 = glRasterPos2s rasterPos3 = glRasterPos3s rasterPos4 = glRasterPos4s rasterPos2v = glRasterPos2sv rasterPos3v = glRasterPos3sv rasterPos4v = glRasterPos4sv instance RasterPosComponent GLint where rasterPos2 = glRasterPos2i rasterPos3 = glRasterPos3i rasterPos4 = glRasterPos4i rasterPos2v = glRasterPos2iv rasterPos3v = glRasterPos3iv rasterPos4v = glRasterPos4iv instance RasterPosComponent GLfloat where rasterPos2 = glRasterPos2f rasterPos3 = glRasterPos3f rasterPos4 = glRasterPos4f rasterPos2v = glRasterPos2fv rasterPos3v = glRasterPos3fv rasterPos4v = glRasterPos4fv instance RasterPosComponent GLdouble where rasterPos2 = glRasterPos2d rasterPos3 = glRasterPos3d rasterPos4 = glRasterPos4d rasterPos2v = glRasterPos2dv rasterPos3v = glRasterPos3dv rasterPos4v = glRasterPos4dv -------------------------------------------------------------------------------- class RasterPos a where rasterPos :: a -> IO () rasterPosv :: Ptr a -> IO () instance RasterPosComponent a => RasterPos (Vertex2 a) where rasterPos (Vertex2 x y) = rasterPos2 x y rasterPosv = rasterPos2v . (castPtr :: Ptr (Vertex2 b) -> Ptr b) instance RasterPosComponent a => RasterPos (Vertex3 a) where rasterPos (Vertex3 x y z) = rasterPos3 x y z rasterPosv = rasterPos3v . (castPtr :: Ptr (Vertex3 b) -> Ptr b) instance RasterPosComponent a => RasterPos (Vertex4 a) where rasterPos (Vertex4 x y z w) = rasterPos4 x y z w rasterPosv = rasterPos4v . (castPtr :: Ptr (Vertex4 b) -> Ptr b) -------------------------------------------------------------------------------- class WindowPosComponent a where windowPos2 :: a -> a -> IO () windowPos3 :: a -> a -> a -> IO () windowPos2v :: Ptr a -> IO () windowPos3v :: Ptr a -> IO () instance WindowPosComponent GLshort where windowPos2 = glWindowPos2s windowPos3 = glWindowPos3s windowPos2v = glWindowPos2sv windowPos3v = glWindowPos3sv instance WindowPosComponent GLint where windowPos2 = glWindowPos2i windowPos3 = glWindowPos3i windowPos2v = glWindowPos2iv windowPos3v = glWindowPos3iv instance WindowPosComponent GLfloat where windowPos2 = glWindowPos2f windowPos3 = glWindowPos3f windowPos2v = glWindowPos2fv windowPos3v = glWindowPos3fv instance WindowPosComponent GLdouble where windowPos2 = glWindowPos2d windowPos3 = glWindowPos3d windowPos2v = glWindowPos2dv windowPos3v = glWindowPos3dv -------------------------------------------------------------------------------- class WindowPos a where windowPos :: a -> IO () windowPosv :: Ptr a -> IO () instance WindowPosComponent a => WindowPos (Vertex2 a) where windowPos (Vertex2 x y) = windowPos2 x y windowPosv = windowPos2v . (castPtr :: Ptr (Vertex2 b) -> Ptr b) instance WindowPosComponent a => WindowPos (Vertex3 a) where windowPos (Vertex3 x y z) = windowPos3 x y z windowPosv = windowPos3v . (castPtr :: Ptr (Vertex3 b) -> Ptr b) -------------------------------------------------------------------------------- currentRasterDistance :: GettableStateVar GLfloat currentRasterDistance = makeGettableStateVar (getFloat1 id GetCurrentRasterDistance) currentRasterColor :: GettableStateVar (Color4 GLfloat) currentRasterColor = makeGettableStateVar (getFloat4 Color4 GetCurrentRasterColor) currentRasterSecondaryColor :: GettableStateVar (Color4 GLfloat) currentRasterSecondaryColor = makeGettableStateVar (getFloat4 Color4 GetCurrentRasterSecondaryColor) currentRasterIndex :: GettableStateVar (Index1 GLint) currentRasterIndex = makeGettableStateVar (getInteger1 Index1 GetCurrentRasterIndex) currentRasterTexCoords :: GettableStateVar (TexCoord4 GLfloat) currentRasterTexCoords = makeGettableStateVar (getFloat4 TexCoord4 GetCurrentRasterTextureCoords) currentRasterPositionValid :: GettableStateVar Bool currentRasterPositionValid = makeGettableStateVar (getBoolean1 unmarshalGLboolean GetCurrentRasterPositionValid) -------------------------------------------------------------------------------- rasterPositionUnclipped :: StateVar Capability rasterPositionUnclipped = makeCapability CapRasterPositionUnclipped OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Exception.hs0000644000000000000000000000276512521420345021441 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Exception -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module to compensate for differences between -- Haskell implementations. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Exception ( bracket, bracket_, unsafeBracket_, finallyRet ) where import Data.IORef ( newIORef, readIORef, writeIORef ) #ifdef __NHC__ import qualified IO ( bracket, bracket_ ) {-# INLINE bracket #-} bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c bracket = IO.bracket {-# INLINE bracket_ #-} bracket_ :: IO a -> IO b -> IO c -> IO c bracket_ before = IO.bracket_ before . const finally :: IO a -> IO b -> IO a finally = flip . bracket_ . return $ undefined #else import Control.Exception ( bracket, bracket_, finally ) #endif {-# INLINE unsafeBracket_ #-} unsafeBracket_ :: IO a -> IO b -> IO c -> IO c unsafeBracket_ before after thing = do _ <- before r <- thing _ <- after return r {-# INLINE finallyRet #-} finallyRet :: IO a -> IO b -> IO (a, b) a `finallyRet` sequel = do r2Ref <- newIORef undefined r1 <- a `finally` (sequel >>= writeIORef r2Ref) r2 <- readIORef r2Ref return (r1, r2) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Face.hs0000644000000000000000000000215012521420345020325 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Face -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for (un-)marshaling Face. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Face ( Face(..), marshalFace, unmarshalFace ) where import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data Face = Front | Back | FrontAndBack deriving ( Eq, Ord, Show ) marshalFace :: Face -> GLenum marshalFace x = case x of Front -> gl_FRONT Back -> gl_BACK FrontAndBack -> gl_FRONT_AND_BACK unmarshalFace :: GLenum -> Face unmarshalFace x | x == gl_FRONT = Front | x == gl_BACK = Back | x == gl_FRONT_AND_BACK = FrontAndBack | otherwise = error ("unmarshalFace: illegal value " ++ show x) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/EdgeFlag.hs0000644000000000000000000000227312521420345021133 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.EdgeFlag -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for (un-)marshaling EdgeFlag. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.EdgeFlag ( EdgeFlag(..), marshalEdgeFlag, unmarshalEdgeFlag ) where import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- | A vertex can begin an edge which lies in the interior of its polygon or on -- the polygon\'s boundary. data EdgeFlag = BeginsInteriorEdge | BeginsBoundaryEdge deriving ( Eq, Ord, Show ) marshalEdgeFlag :: EdgeFlag -> GLboolean marshalEdgeFlag = marshalGLboolean . (BeginsBoundaryEdge ==) unmarshalEdgeFlag :: GLboolean -> EdgeFlag unmarshalEdgeFlag f = if unmarshalGLboolean f then BeginsBoundaryEdge else BeginsInteriorEdge OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/ColorSum.hs0000644000000000000000000000140312521420345021232 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.ColorSum -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 3.9 (Color Sum) of the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.ColorSum ( colorSum ) where import Data.StateVar import Graphics.Rendering.OpenGL.GL.Capability -------------------------------------------------------------------------------- colorSum :: StateVar Capability colorSum = makeCapability CapColorSum OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Texturing.hs0000644000000000000000000000233712521420345021467 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Texturing -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 3.8 (Texturing) of the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Texturing ( module Graphics.Rendering.OpenGL.GL.Texturing.Specification, module Graphics.Rendering.OpenGL.GL.Texturing.Parameters, module Graphics.Rendering.OpenGL.GL.Texturing.Objects, module Graphics.Rendering.OpenGL.GL.Texturing.Environments, module Graphics.Rendering.OpenGL.GL.Texturing.Application, module Graphics.Rendering.OpenGL.GL.Texturing.Queries ) where import Graphics.Rendering.OpenGL.GL.Texturing.Specification import Graphics.Rendering.OpenGL.GL.Texturing.Parameters import Graphics.Rendering.OpenGL.GL.Texturing.Objects import Graphics.Rendering.OpenGL.GL.Texturing.Environments import Graphics.Rendering.OpenGL.GL.Texturing.Application import Graphics.Rendering.OpenGL.GL.Texturing.Queries OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Selection.hs0000644000000000000000000000544412521420345021425 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Selection -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 5.2 (Selection) of the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Selection ( HitRecord(..), getHitRecords, Name(..), withName, loadName, maxNameStackDepth, nameStackDepth, RenderMode(..), renderMode ) where import Data.StateVar import Foreign.Marshal.Array import Foreign.Ptr import Graphics.Rendering.OpenGL.GL.Exception import Graphics.Rendering.OpenGL.GL.IOState import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.RenderMode import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data HitRecord = HitRecord GLfloat GLfloat [Name] deriving ( Eq, Ord, Show ) -------------------------------------------------------------------------------- getHitRecords :: GLsizei -> IO a -> IO (a, Maybe [HitRecord]) getHitRecords bufSize action = allocaArray (fromIntegral bufSize) $ \buf -> do glSelectBuffer bufSize buf (value, numHits) <- withRenderMode Select $ do glInitNames action hits <- parseSelectionBuffer numHits buf return (value, hits) -------------------------------------------------------------------------------- parseSelectionBuffer :: GLint -> Ptr GLuint -> IO (Maybe [HitRecord]) parseSelectionBuffer numHits buf | numHits < 0 = return Nothing | otherwise = fmap Just $ evalIOState (nTimes numHits parseSelectionHit) buf type Parser a = IOState GLuint a parseSelectionHit :: Parser HitRecord parseSelectionHit = do numNames <- parseGLuint minZ <- parseGLfloat maxZ <- parseGLfloat nameStack <- nTimes numNames parseName return $ HitRecord minZ maxZ nameStack parseGLuint :: Parser GLuint parseGLuint = peekIOState parseGLfloat :: Parser GLfloat parseGLfloat = fmap (\x -> fromIntegral x / 0xffffffff) parseGLuint parseName :: Parser Name parseName = fmap Name parseGLuint -------------------------------------------------------------------------------- newtype Name = Name GLuint deriving ( Eq, Ord, Show ) withName :: Name -> IO a -> IO a withName (Name name) = bracket_ (glPushName name) glPopName loadName :: Name -> IO () loadName (Name n) = glLoadName n maxNameStackDepth :: GettableStateVar GLsizei maxNameStackDepth = makeGettableStateVar (getSizei1 id GetMaxNameStackDepth) nameStackDepth :: GettableStateVar GLsizei nameStackDepth = makeGettableStateVar (getSizei1 id GetNameStackDepth) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/CoordTrans.hs0000644000000000000000000004521612521420345021557 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.CoordTrans -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 2.11 (Coordinate Transformations) of the -- OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- {-# LANGUAGE TypeSynonymInstances #-} module Graphics.Rendering.OpenGL.GL.CoordTrans ( -- * Controlling the Viewport depthRange, Position(..), Size(..), viewport, maxViewportDims, -- * Matrices MatrixMode(..), matrixMode, MatrixOrder(..), MatrixComponent(rotate,translate,scale), Matrix(..), matrix, multMatrix, GLmatrix, loadIdentity, ortho, frustum, depthClamp, activeTexture, preservingMatrix, unsafePreservingMatrix, stackDepth, maxStackDepth, -- * Normal Transformation rescaleNormal, normalize, -- * Generating Texture Coordinates Plane(..), TextureCoordName(..), TextureGenMode(..), textureGenMode ) where import Data.StateVar import Foreign.ForeignPtr import Foreign.Marshal.Alloc import Foreign.Marshal.Array import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.GL.Tensor import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.Exception import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.Texturing.TextureUnit import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- | After clipping and division by /w/, depth coordinates range from -1 to 1, -- corresponding to the near and far clipping planes. 'depthRange' specifies a -- linear mapping of the normalized depth coordinates in this range to window -- depth coordinates. Regardless of the actual depth buffer implementation, -- window coordinate depth values are treated as though they range from 0 -- through 1 (like color components). Thus, the values accepted by 'depthRange' -- are both clamped to this range before they are accepted. -- -- The initial setting of (0, 1) maps the near plane to 0 and the far plane to -- 1. With this mapping, the depth buffer range is fully utilized. -- -- It is not necessary that the near value be less than the far value. Reverse -- mappings such as (1, 0) are acceptable. depthRange :: StateVar (GLclampd, GLclampd) depthRange = makeStateVar (getClampd2 (,) GetDepthRange) (uncurry glDepthRange) -------------------------------------------------------------------------------- -- | A 2-dimensional position, measured in pixels. data Position = Position !GLint !GLint deriving ( Eq, Ord, Show ) -- | A 2-dimensional size, measured in pixels. data Size = Size !GLsizei !GLsizei deriving ( Eq, Ord, Show ) -- | Controls the affine transformation from normalized device coordinates to -- window coordinates. The viewport state variable consists of the coordinates -- (/x/, /y/) of the lower left corner of the viewport rectangle, (in pixels, -- initial value (0,0)), and the size (/width/, /height/) of the viewport. When -- a GL context is first attached to a window, /width/ and /height/ are set to -- the dimensions of that window. -- -- Let (/xnd/, /ynd/) be normalized device coordinates. Then the window -- coordinates (/xw/, /yw/) are computed as follows: -- -- /xw/ = (/xnd/ + 1) (/width/ \/ 2) + /x/ -- -- /yw/ = (/ynd/ + 1) (/heigth/ \/ 2) + /y/ -- -- Viewport width and height are silently clamped to a range that depends on the -- implementation, see 'maxViewportDims'. viewport :: StateVar (Position, Size) viewport = makeStateVar (getInteger4 makeVp GetViewport) (\(Position x y, Size w h) -> glViewport x y w h) where makeVp x y w h = (Position x y, Size (fromIntegral w) (fromIntegral h)) -- | The implementation-dependent maximum viewport width and height. maxViewportDims :: GettableStateVar Size maxViewportDims = makeGettableStateVar (getSizei2 Size GetMaxViewportDims) -------------------------------------------------------------------------------- -- | A matrix stack. data MatrixMode = Modelview GLsizei -- ^ The modelview matrix stack of the specified vertex unit. | Projection -- ^ The projection matrix stack. | Texture -- ^ The texture matrix stack. | Color -- ^ The color matrix stack. | MatrixPalette -- ^ The matrix palette stack. deriving ( Eq, Ord, Show ) marshalMatrixMode :: MatrixMode -> Maybe GLenum marshalMatrixMode x = case x of Modelview i -> modelviewIndexToEnum i Projection -> Just gl_PROJECTION Texture -> Just gl_TEXTURE Color -> Just gl_COLOR MatrixPalette -> Just gl_MATRIX_PALETTE_ARB unmarshalMatrixMode :: GLenum -> MatrixMode unmarshalMatrixMode x | x == gl_PROJECTION = Projection | x == gl_TEXTURE = Texture | x == gl_COLOR = Color | x == gl_MATRIX_PALETTE_ARB = MatrixPalette | otherwise = case modelviewEnumToIndex x of Just i -> Modelview i Nothing -> error ("unmarshalMatrixMode: illegal value " ++ show x) matrixModeToGetMatrix :: MatrixMode -> PNameMatrix matrixModeToGetMatrix x = case x of Modelview _ -> GetModelviewMatrix -- ??? Projection -> GetProjectionMatrix Texture -> GetTextureMatrix Color -> GetColorMatrix MatrixPalette -> GetMatrixPalette matrixModeToGetStackDepth :: MatrixMode -> PName1I matrixModeToGetStackDepth x = case x of Modelview _ -> GetModelviewStackDepth Projection -> GetProjectionStackDepth Texture -> GetTextureStackDepth Color -> GetColorMatrixStackDepth MatrixPalette -> error "matrixModeToGetStackDepth: impossible" matrixModeToGetMaxStackDepth :: MatrixMode -> PName1I matrixModeToGetMaxStackDepth x = case x of Modelview _ -> GetMaxModelviewStackDepth Projection -> GetMaxProjectionStackDepth Texture -> GetMaxTextureStackDepth Color -> GetMaxColorMatrixStackDepth MatrixPalette -> GetMaxMatrixPaletteStackDepth -------------------------------------------------------------------------------- -- | Controls which matrix stack is the target for subsequent matrix operations. -- The initial value is ('Modelview' 0). matrixMode :: StateVar MatrixMode matrixMode = makeStateVar (getEnum1 unmarshalMatrixMode GetMatrixMode) (maybe recordInvalidValue glMatrixMode . marshalMatrixMode) -------------------------------------------------------------------------------- data MatrixOrder = ColumnMajor | RowMajor deriving ( Eq, Ord, Show ) -------------------------------------------------------------------------------- class Storable c => MatrixComponent c where getMatrix :: GetPNameMatrix p => p -> Ptr c -> IO () loadMatrix :: Ptr c -> IO () loadTransposeMatrix :: Ptr c -> IO () multMatrix_ :: Ptr c -> IO () multTransposeMatrix :: Ptr c -> IO () rotate :: c -> Vector3 c -> IO () translate :: Vector3 c -> IO () scale :: c -> c -> c -> IO () instance MatrixComponent GLfloat where getMatrix = getMatrixf loadMatrix = glLoadMatrixf loadTransposeMatrix = glLoadTransposeMatrixf multMatrix_ = glMultMatrixf multTransposeMatrix = glMultTransposeMatrixf rotate a (Vector3 x y z) = glRotatef a x y z translate (Vector3 x y z) = glTranslatef x y z scale = glScalef instance MatrixComponent GLdouble where getMatrix = getMatrixd loadMatrix = glLoadMatrixd loadTransposeMatrix = glLoadTransposeMatrixd multMatrix_ = glMultMatrixd multTransposeMatrix = glMultTransposeMatrixd rotate a (Vector3 x y z) = glRotated a x y z translate (Vector3 x y z) = glTranslated x y z scale = glScaled -------------------------------------------------------------------------------- class Matrix m where -- | Create a new matrix of the given order (containing undefined elements) -- and call the action to fill it with 4x4 elements. withNewMatrix :: MatrixComponent c => MatrixOrder -> (Ptr c -> IO ()) -> IO (m c) -- | Call the action with the given matrix. /Note:/ The action is /not/ -- allowed to modify the matrix elements! withMatrix :: MatrixComponent c => m c -> (MatrixOrder -> Ptr c -> IO a) -> IO a newMatrix :: MatrixComponent c => MatrixOrder -> [c] -> IO (m c) getMatrixComponents :: MatrixComponent c => MatrixOrder -> m c -> IO [c] withNewMatrix order act = allocaArray 16 $ \p -> do act p components <- peekArray 16 p newMatrix order components withMatrix mat act = do components <- getMatrixComponents ColumnMajor mat withArray components $ act ColumnMajor newMatrix order components = withNewMatrix order $ flip pokeArray (take 16 components) getMatrixComponents desiredOrder mat = withMatrix mat $ \order p -> if desiredOrder == order then peekArray 16 p else mapM (peekElemOff p) [ 0, 4, 8, 12, 1, 5, 9, 13, 2, 6, 10, 14, 3, 7, 11, 15 ] -------------------------------------------------------------------------------- matrix :: (Matrix m, MatrixComponent c) => Maybe MatrixMode -> StateVar (m c) matrix maybeMode = makeStateVar (maybe (get matrixMode) return maybeMode >>= (getMatrix' . matrixModeToGetMatrix)) (maybe id withMatrixMode maybeMode . setMatrix) withMatrixMode :: MatrixMode -> IO a -> IO a withMatrixMode mode act = preservingMatrixMode $ do matrixMode $= mode act getMatrix' :: (Matrix m, MatrixComponent c) => PNameMatrix -> IO (m c) getMatrix' = withNewMatrix ColumnMajor . getMatrix setMatrix :: (Matrix m, MatrixComponent c) => m c -> IO () setMatrix mat = withMatrix mat $ \order -> case order of ColumnMajor -> loadMatrix RowMajor -> loadTransposeMatrix multMatrix :: (Matrix m, MatrixComponent c) => m c -> IO () multMatrix mat = withMatrix mat $ \order -> case order of ColumnMajor -> multMatrix_ RowMajor -> multTransposeMatrix -------------------------------------------------------------------------------- data GLmatrix a = GLmatrix MatrixOrder (ForeignPtr a) deriving ( Eq, Ord, Show ) instance Matrix GLmatrix where withNewMatrix order f = do fp <- mallocForeignPtrArray 16 withForeignPtr fp f return $ GLmatrix order fp withMatrix (GLmatrix order fp) f = withForeignPtr fp (f order) -------------------------------------------------------------------------------- loadIdentity :: IO () loadIdentity = glLoadIdentity -------------------------------------------------------------------------------- ortho :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> IO () ortho = glOrtho frustum :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> IO () frustum = glFrustum -------------------------------------------------------------------------------- depthClamp :: StateVar Capability depthClamp = makeCapability CapDepthClamp -------------------------------------------------------------------------------- activeTexture :: StateVar TextureUnit activeTexture = makeStateVar (getEnum1 unmarshalTextureUnit GetActiveTexture) (glActiveTexture . marshalTextureUnit) -------------------------------------------------------------------------------- -- | Push the current matrix stack down by one, duplicating the current matrix, -- excute the given action, and pop the current matrix stack, replacing the -- current matrix with the one below it on the stack (i.e. restoring it to its -- previous state). The returned value is that of the given action. Note that -- a round-trip to the server is probably required. For a more efficient -- version, see 'unsafePreservingMatrix'. preservingMatrix :: IO a -> IO a preservingMatrix = unsafePreservingMatrix . preservingMatrixMode -- performance paranoia: No (un-)marshaling by avoiding matrixMode preservingMatrixMode :: IO a -> IO a preservingMatrixMode = bracket (getEnum1 id GetMatrixMode) glMatrixMode . const -- | A more efficient, but potentially dangerous version of 'preservingMatrix': -- The given action is not allowed to throw an exception or change the -- current matrix mode permanently. unsafePreservingMatrix :: IO a -> IO a unsafePreservingMatrix = unsafeBracket_ glPushMatrix glPopMatrix -------------------------------------------------------------------------------- stackDepth :: Maybe MatrixMode -> GettableStateVar GLsizei stackDepth maybeMode = makeGettableStateVar $ case maybeMode of Nothing -> getSizei1 id GetCurrentMatrixStackDepth -- only with ARB_fragment_program Just MatrixPalette -> do recordInvalidEnum ; return 0 Just mode -> getSizei1 id (matrixModeToGetStackDepth mode) maxStackDepth :: MatrixMode -> GettableStateVar GLsizei maxStackDepth = makeGettableStateVar . getSizei1 id . matrixModeToGetMaxStackDepth -------------------------------------------------------------------------------- -- | If 'rescaleNormal' contains 'Enabled', normal vectors specified with -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.normal' are scaled by a scaling -- factor derived from the modelview matrix. 'rescaleNormal' requires that the -- originally specified normals were of unit length, and that the modelview -- matrix contains only uniform scales for proper results. The initial value of -- 'rescaleNormal' is 'Disabled'. rescaleNormal :: StateVar Capability rescaleNormal = makeCapability CapRescaleNormal -- | If 'normalize' contains 'Enabled', normal vectors specified with -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.normal' are scaled to unit length -- after transformation. The initial value of 'normalize' is 'Disabled'. normalize :: StateVar Capability normalize = makeCapability CapNormalize -------------------------------------------------------------------------------- data Plane a = Plane !a !a !a !a deriving ( Eq, Ord, Show ) instance Storable a => Storable (Plane a) where sizeOf ~(Plane a _ _ _) = 4 * sizeOf a alignment ~(Plane a _ _ _) = alignment a peek = peek4 Plane . castPtr poke ptr (Plane a b c d) = poke4 (castPtr ptr) a b c d -------------------------------------------------------------------------------- data TextureCoordName = S | T | R | Q deriving ( Eq, Ord, Show ) marshalTextureCoordName :: TextureCoordName -> GLenum marshalTextureCoordName x = case x of S -> gl_S T -> gl_T R -> gl_R Q -> gl_Q -------------------------------------------------------------------------------- data TextureGenParameter = TextureGenMode | ObjectPlane | EyePlane marshalTextureGenParameter :: TextureGenParameter -> GLenum marshalTextureGenParameter x = case x of TextureGenMode -> gl_TEXTURE_GEN_MODE ObjectPlane -> gl_OBJECT_PLANE EyePlane -> gl_EYE_PLANE -------------------------------------------------------------------------------- data TextureGenMode' = EyeLinear' | ObjectLinear' | SphereMap' | NormalMap' | ReflectionMap' marshalTextureGenMode' :: TextureGenMode' -> GLint marshalTextureGenMode' x = fromIntegral $ case x of EyeLinear' -> gl_EYE_LINEAR ObjectLinear' -> gl_OBJECT_LINEAR SphereMap' -> gl_SPHERE_MAP NormalMap' -> gl_NORMAL_MAP ReflectionMap' -> gl_REFLECTION_MAP unmarshalTextureGenMode' :: GLint -> TextureGenMode' unmarshalTextureGenMode' x | y == gl_EYE_LINEAR = EyeLinear' | y == gl_OBJECT_LINEAR = ObjectLinear' | y == gl_SPHERE_MAP = SphereMap' | y == gl_NORMAL_MAP = NormalMap' | y == gl_REFLECTION_MAP = ReflectionMap' | otherwise = error ("unmarshalTextureGenMode': illegal value " ++ show x) where y = fromIntegral x -------------------------------------------------------------------------------- data TextureGenMode = EyeLinear (Plane GLdouble) | ObjectLinear (Plane GLdouble) | SphereMap | NormalMap | ReflectionMap deriving ( Eq, Ord, Show ) marshalTextureGenMode :: TextureGenMode -> GLint marshalTextureGenMode = marshalTextureGenMode' . convertMode where convertMode (EyeLinear _) = EyeLinear' convertMode (ObjectLinear _) = ObjectLinear' convertMode SphereMap = SphereMap' convertMode NormalMap = NormalMap' convertMode ReflectionMap = ReflectionMap' -------------------------------------------------------------------------------- textureGenMode :: TextureCoordName -> StateVar (Maybe TextureGenMode) textureGenMode coord = makeStateVarMaybe (return $ textureCoordNameToEnableCap coord) (do mode <- getMode coord case mode of EyeLinear' -> fmap EyeLinear $ getPlane coord EyePlane ObjectLinear' -> fmap ObjectLinear $ getPlane coord ObjectPlane SphereMap' -> return SphereMap NormalMap' -> return NormalMap ReflectionMap' -> return ReflectionMap) (\mode -> do setMode coord mode case mode of EyeLinear plane -> setPlane coord EyePlane plane ObjectLinear plane -> setPlane coord ObjectPlane plane _ -> return ()) -------------------------------------------------------------------------------- textureCoordNameToEnableCap :: TextureCoordName -> EnableCap textureCoordNameToEnableCap coord = case coord of S -> CapTextureGenS T -> CapTextureGenT R -> CapTextureGenR Q -> CapTextureGenQ -------------------------------------------------------------------------------- getMode :: TextureCoordName -> IO TextureGenMode' getMode coord = alloca $ \buf -> do glGetTexGeniv (marshalTextureCoordName coord) (marshalTextureGenParameter TextureGenMode) buf peek1 unmarshalTextureGenMode' buf setMode :: TextureCoordName -> TextureGenMode -> IO () setMode coord mode = glTexGeni (marshalTextureCoordName coord) (marshalTextureGenParameter TextureGenMode) (marshalTextureGenMode mode) -------------------------------------------------------------------------------- getPlane :: TextureCoordName -> TextureGenParameter -> IO (Plane GLdouble) getPlane coord param = alloca $ \planeBuffer -> do glGetTexGendv (marshalTextureCoordName coord) (marshalTextureGenParameter param) (castPtr planeBuffer) peek planeBuffer setPlane :: TextureCoordName -> TextureGenParameter -> Plane GLdouble -> IO () setPlane coord param plane = with plane $ \planeBuffer -> glTexGendv (marshalTextureCoordName coord) (marshalTextureGenParameter param) (castPtr planeBuffer) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Bitmaps.hs0000644000000000000000000000165612521420345021100 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Bitmaps -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 3.7 (Bitmaps) of the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Bitmaps ( bitmap ) where import Foreign.Ptr import Graphics.Rendering.OpenGL.GL.CoordTrans import Graphics.Rendering.OpenGL.GL.Tensor import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- bitmap :: Size -> (Vertex2 GLfloat) -> (Vector2 GLfloat) -> Ptr GLubyte -> IO () bitmap (Size w h) (Vertex2 xbo ybo) (Vector2 xbi ybi) = glBitmap w h xbo ybo xbi ybi OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/RenderMode.hs0000644000000000000000000000352612521420345021523 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.RenderMode -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module related to the current render mode. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.RenderMode ( RenderMode(..), withRenderMode, renderMode ) where import Data.StateVar import Graphics.Rendering.OpenGL.GL.Exception import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data RenderMode = Render | Feedback | Select deriving ( Eq, Ord, Show ) marshalRenderMode :: RenderMode -> GLenum marshalRenderMode x = case x of Render -> gl_RENDER Feedback -> gl_FEEDBACK Select -> gl_SELECT unmarshalRenderMode :: GLenum -> RenderMode unmarshalRenderMode x | x == gl_RENDER = Render | x == gl_FEEDBACK = Feedback | x == gl_SELECT = Select | otherwise = error ("unmarshalRenderMode: illegal value " ++ show x) -------------------------------------------------------------------------------- withRenderMode :: RenderMode -> IO a -> IO (a, GLint) withRenderMode newMode action = do oldMode <- get renderMode _ <- setRenderMode newMode action `finallyRet` setRenderMode oldMode setRenderMode :: RenderMode -> IO GLint setRenderMode = glRenderMode . marshalRenderMode -------------------------------------------------------------------------------- renderMode :: GettableStateVar RenderMode renderMode = makeGettableStateVar $ getEnum1 unmarshalRenderMode GetRenderMode OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/LineSegments.hs0000644000000000000000000001470312521420345022073 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.LineSegments -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 3.4 (Line Segments) of the OpenGL 2.1 -- specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.LineSegments ( -- * Line Rasterization lineWidth, -- * Line Stipple lineStipple, -- * Line Antialiasing lineSmooth, -- * Implementation-Dependent Limits aliasedLineWidthRange, smoothLineWidthRange, smoothLineWidthGranularity ) where import Control.Monad import Data.StateVar import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- | 'lineWidth' contains the rasterized width of both aliased and antialiased -- lines. The initial value is 1. Using a line width other than 1 has different -- effects, depending on whether line antialiasing is enabled (see -- 'lineSmooth'). Line antialiasing is initially disabled. -- -- If line antialiasing is disabled, the actual width is determined by rounding -- the supplied width to the nearest integer. (If the rounding results in the -- value 0, it is as if the line width were 1.) If /delta x/ >= /delta y/, /i/ -- pixels are filled in each column that is rasterized, where /i/ is the -- rounded value of 'lineWidth'. Otherwise, /i/ pixels are filled in each row -- that is rasterized. -- -- If antialiasing is enabled, line rasterization produces a fragment for each -- pixel square that intersects the region lying within the rectangle having -- width equal to the current line width, length equal to the actual length of -- the line, and centered on the mathematical line segment. The coverage value -- for each fragment is the window coordinate area of the intersection of the -- rectangular region with the corresponding pixel square. This value is saved -- and used in the final rasterization step. -- -- Not all widths can be supported when line antialiasing is enabled. If an -- unsupported width is requested, the nearest supported width is used. Only -- width 1 is guaranteed to be supported; others depend on the implementation. -- Likewise, there is a range for aliased line widths as well. To query the -- range of supported widths of antialiased lines and the size difference -- between supported widths within the range, query 'smoothLineWidthRange' and -- 'smoothLineWidthGranularity', respectively. For aliased lines, query the -- supported range with 'aliasedLineWidthRange'. -- -- The line width specified when 'lineWidth' is set is always returned when it -- is queried. Clamping and rounding for aliased and antialiased lines have no -- effect on the specified value. -- -- A non-antialiased line width may be clamped to an implementation-dependent -- maximum. Query 'aliasedLineWidthRange' to determine the maximum width. -- -- An 'Graphics.Rendering.OpenGL.GLU.Errors.InvalidValue' is generated if -- 'lineWidth' is set to a value less than or equal to zero. -- -- An 'Graphics.Rendering.OpenGL.GLU.Errors.InvalidOperation' is generated if -- 'lineWidth' is set during -- 'Graphics.Rendering.OpenGL.GL.BeginEnd.renderPrimitive'. lineWidth :: StateVar GLfloat lineWidth = makeStateVar (getFloat1 id GetLineWidth) glLineWidth -------------------------------------------------------------------------------- -- | Line stippling masks out certain fragments produced by rasterization; those -- fragments will not be drawn. The masking is achieved by using three -- parameters: the repeat count (1st element of the 'lineStipple' pair, clamped -- to the range [ 1 .. 256 ]), the 16-bit line stipple pattern (2nd element), -- and an integer stipple counter /s/. -- -- The counter /s/ is reset to 0 at before the first action during -- 'Graphics.Rendering.OpenGL.GL.BeginEnd.renderPrimitive' is called and before -- each line segment during -- 'Graphics.Rendering.OpenGL.GL.BeginEnd.renderPrimitive' is generated. It is -- incremented after each fragment of a unit width aliased line segment is -- generated or after each /i/ fragments of an /i/ width line segment are -- generated. The /i/ fragments associated with count /s/ are masked out if -- @'Data.Bits.testBit' /pattern/ (( /s/ \/ /factor/ ) /mod/ 16)@ is 'False', -- otherwise these fragments are sent to the frame buffer. Bit zero of the -- pattern is the least significant bit, i.e. it is used first. -- -- Antialiased lines are treated as a sequence of rectangles of height 1 for -- purposes of stippling. Whether rectangle /s/ is rasterized or not depends on -- the fragment rule described for aliased lines, counting rectangles rather -- than groups of fragments. -- -- The initial value of 'lineStipple' is 'Nothing', i.e. line stippling is -- disabled. -- -- An 'Graphics.Rendering.OpenGL.GLU.Errors.InvalidOperation' is generated if -- 'lineStipple' is set during -- 'Graphics.Rendering.OpenGL.GL.BeginEnd.renderPrimitive'. lineStipple :: StateVar (Maybe (GLint, GLushort)) lineStipple = makeStateVarMaybe (return CapLineStipple) (liftM2 (,) (getInteger1 id GetLineStippleRepeat) (getInteger1 fromIntegral GetLineStipplePattern)) (uncurry glLineStipple) -------------------------------------------------------------------------------- -- | Controls whether line antialiasing is enabled. The initial state is -- 'Graphics.Rendering.OpenGL.GL.Capability.Disabled'. lineSmooth :: StateVar Capability lineSmooth = makeCapability CapLineSmooth -------------------------------------------------------------------------------- -- | The smallest and largest supported width of aliased lines. aliasedLineWidthRange :: GettableStateVar (GLfloat, GLfloat) aliasedLineWidthRange = makeGettableStateVar $ getFloat2 (,) GetAliasedLineWidthRange -- | The smallest and largest supported width of antialiased lines. smoothLineWidthRange :: GettableStateVar (GLfloat, GLfloat) smoothLineWidthRange = makeGettableStateVar $ getFloat2 (,) GetSmoothLineWidthRange -- | The antialiased line width granularity, i.e. the size difference between -- supported widths. smoothLineWidthGranularity :: GettableStateVar GLfloat smoothLineWidthGranularity = makeGettableStateVar $ getFloat1 id GetSmoothLineWidthGranularity OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/VertexArrays.hs0000644000000000000000000004052612521420345022137 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.VertexArrays -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 2.8 (Vertex Arrays) of the OpenGL 2.1 -- specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.VertexArrays ( -- * Describing Data for the Arrays NumComponents, DataType(..), Stride, VertexArrayDescriptor(..), -- * Specifying Data for the Arrays Capability(..), ClientArrayType(..), arrayPointer, InterleavedArrays(..), interleavedArrays, -- * Enabling Arrays clientState, clientActiveTexture, -- * Dereferencing and Rendering ArrayIndex, NumArrayIndices, NumIndexBlocks, arrayElement, drawArrays, multiDrawArrays, drawElements, multiDrawElements, drawRangeElements, maxElementsVertices, maxElementsIndices, lockArrays, primitiveRestartIndex, primitiveRestartIndexNV, -- * Generic Vertex Attribute Arrays vertexAttribPointer, vertexAttribArray, ) where import Data.StateVar import Foreign.Ptr ( Ptr, nullPtr ) import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.DataType import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.PrimitiveMode import Graphics.Rendering.OpenGL.GL.PrimitiveModeInternal import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.Texturing.TextureUnit import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- type NumComponents = GLint type Stride = GLsizei data VertexArrayDescriptor a = VertexArrayDescriptor !NumComponents !DataType !Stride !(Ptr a) deriving ( Eq, Ord, Show ) noVertexArrayDescriptor :: VertexArrayDescriptor a noVertexArrayDescriptor = VertexArrayDescriptor 0 Byte 0 nullPtr -------------------------------------------------------------------------------- data ClientArrayType = VertexArray | NormalArray | ColorArray | IndexArray | TextureCoordArray | EdgeFlagArray | FogCoordArray | SecondaryColorArray | MatrixIndexArray deriving ( Eq, Ord, Show ) marshalClientArrayType :: ClientArrayType -> GLenum marshalClientArrayType x = case x of VertexArray -> gl_VERTEX_ARRAY NormalArray -> gl_NORMAL_ARRAY ColorArray -> gl_COLOR_ARRAY IndexArray -> gl_INDEX_ARRAY TextureCoordArray -> gl_TEXTURE_COORD_ARRAY EdgeFlagArray -> gl_EDGE_FLAG_ARRAY FogCoordArray -> gl_FOG_COORD_ARRAY SecondaryColorArray -> gl_SECONDARY_COLOR_ARRAY MatrixIndexArray -> gl_MATRIX_INDEX_ARRAY_ARB -- Hmmm... clientArrayTypeToEnableCap :: ClientArrayType -> EnableCap clientArrayTypeToEnableCap x = case x of VertexArray -> CapVertexArray NormalArray -> CapNormalArray ColorArray -> CapColorArray IndexArray -> CapIndexArray TextureCoordArray -> CapTextureCoordArray EdgeFlagArray -> CapEdgeFlagArray FogCoordArray -> CapFogCoordArray SecondaryColorArray -> CapSecondaryColorArray MatrixIndexArray -> CapMatrixIndexArray -------------------------------------------------------------------------------- arrayPointer :: ClientArrayType -> StateVar (VertexArrayDescriptor a) arrayPointer t = case t of VertexArray -> vertexPointer NormalArray -> normalPointer ColorArray -> colorPointer IndexArray -> indexPointer TextureCoordArray -> texCoordPointer EdgeFlagArray -> edgeFlagPointer FogCoordArray -> fogCoordPointer SecondaryColorArray -> secondaryColorPointer MatrixIndexArray -> makeStateVar (do recordInvalidEnum ; return noVertexArrayDescriptor) (const recordInvalidEnum) check :: Bool -> IO () -> IO () check flag val = if flag then val else recordInvalidValue -------------------------------------------------------------------------------- vertexPointer :: StateVar (VertexArrayDescriptor a) vertexPointer = makeStateVar getVertexPointer setVertexPointer getVertexPointer :: IO (VertexArrayDescriptor a) getVertexPointer = do n <- getInteger1 id GetVertexArraySize d <- getEnum1 unmarshalDataType GetVertexArrayType s <- getInteger1 fromIntegral GetVertexArrayStride p <- getPointer VertexArrayPointer return $ VertexArrayDescriptor n d s p setVertexPointer :: VertexArrayDescriptor a -> IO () setVertexPointer (VertexArrayDescriptor n d s p) = glVertexPointer n (marshalDataType d) s p -------------------------------------------------------------------------------- normalPointer :: StateVar (VertexArrayDescriptor a) normalPointer = makeStateVar getNormalPointer setNormalPointer getNormalPointer :: IO (VertexArrayDescriptor a) getNormalPointer = do d <- getEnum1 unmarshalDataType GetNormalArrayType s <- getInteger1 fromIntegral GetNormalArrayStride p <- getPointer NormalArrayPointer return $ VertexArrayDescriptor 3 d s p setNormalPointer :: VertexArrayDescriptor a -> IO () setNormalPointer (VertexArrayDescriptor n d s p) = check (n == 3) $ glNormalPointer (marshalDataType d) s p -------------------------------------------------------------------------------- colorPointer :: StateVar (VertexArrayDescriptor a) colorPointer = makeStateVar getColorPointer setColorPointer getColorPointer :: IO (VertexArrayDescriptor a) getColorPointer = do n <- getInteger1 id GetColorArraySize d <- getEnum1 unmarshalDataType GetColorArrayType s <- getInteger1 fromIntegral GetColorArrayStride p <- getPointer ColorArrayPointer return $ VertexArrayDescriptor n d s p setColorPointer :: VertexArrayDescriptor a -> IO () setColorPointer (VertexArrayDescriptor n d s p) = check (n == 3 || n == 4) $ glColorPointer n (marshalDataType d) s p -------------------------------------------------------------------------------- indexPointer :: StateVar (VertexArrayDescriptor a) indexPointer = makeStateVar getIndexPointer setIndexPointer getIndexPointer :: IO (VertexArrayDescriptor a) getIndexPointer = do d <- getEnum1 unmarshalDataType GetIndexArrayType s <- getInteger1 fromIntegral GetIndexArrayStride p <- getPointer IndexArrayPointer return $ VertexArrayDescriptor 1 d s p setIndexPointer :: VertexArrayDescriptor a -> IO () setIndexPointer (VertexArrayDescriptor n d s p) = check (n == 1) $ glIndexPointer (marshalDataType d) s p -------------------------------------------------------------------------------- texCoordPointer :: StateVar (VertexArrayDescriptor a) texCoordPointer = makeStateVar getTexCoordPointer setTexCoordPointer getTexCoordPointer :: IO (VertexArrayDescriptor a) getTexCoordPointer = do n <- getInteger1 id GetTextureCoordArraySize d <- getEnum1 unmarshalDataType GetTextureCoordArrayType s <- getInteger1 fromIntegral GetTextureCoordArrayStride p <- getPointer TextureCoordArrayPointer return $ VertexArrayDescriptor n d s p setTexCoordPointer :: VertexArrayDescriptor a -> IO () setTexCoordPointer (VertexArrayDescriptor n d s p) = glTexCoordPointer n (marshalDataType d) s p -------------------------------------------------------------------------------- edgeFlagPointer :: StateVar (VertexArrayDescriptor a) edgeFlagPointer = makeStateVar getEdgeFlagPointer setEdgeFlagPointer getEdgeFlagPointer :: IO (VertexArrayDescriptor a) getEdgeFlagPointer = do s <- getInteger1 fromIntegral GetEdgeFlagArrayStride p <- getPointer EdgeFlagArrayPointer return $ VertexArrayDescriptor 1 UnsignedByte s p setEdgeFlagPointer :: VertexArrayDescriptor a -> IO () setEdgeFlagPointer (VertexArrayDescriptor n d s p) = check (n == 1 && d == UnsignedByte) $ glEdgeFlagPointer s p -------------------------------------------------------------------------------- fogCoordPointer :: StateVar (VertexArrayDescriptor a) fogCoordPointer = makeStateVar getFogCoordPointer setFogCoordPointer getFogCoordPointer :: IO (VertexArrayDescriptor a) getFogCoordPointer = do d <- getEnum1 unmarshalDataType GetFogCoordArrayType s <- getInteger1 fromIntegral GetFogCoordArrayStride p <- getPointer FogCoordArrayPointer return $ VertexArrayDescriptor 1 d s p setFogCoordPointer :: VertexArrayDescriptor a -> IO () setFogCoordPointer (VertexArrayDescriptor n d s p) = check (n == 1) $ glFogCoordPointer (marshalDataType d) s p -------------------------------------------------------------------------------- secondaryColorPointer :: StateVar (VertexArrayDescriptor a) secondaryColorPointer = makeStateVar getSecondaryColorPointer setSecondaryColorPointer getSecondaryColorPointer :: IO (VertexArrayDescriptor a) getSecondaryColorPointer = do n <- getInteger1 id GetSecondaryColorArraySize d <- getEnum1 unmarshalDataType GetSecondaryColorArrayType s <- getInteger1 fromIntegral GetSecondaryColorArrayStride p <- getPointer SecondaryColorArrayPointer return $ VertexArrayDescriptor n d s p setSecondaryColorPointer :: (VertexArrayDescriptor a) -> IO () setSecondaryColorPointer (VertexArrayDescriptor n d s p) = glSecondaryColorPointer n (marshalDataType d) s p -------------------------------------------------------------------------------- data InterleavedArrays = V2f | V3f | C4ubV2f | C4ubV3f | C3fV3f | N3fV3f | C4fN3fV3f | T2fV3f | T4fV4f | T2fC4ubV3f | T2fC3fV3f | T2fN3fV3f | T2fC4fN3fV3f | T4fC4fN3fV4f deriving ( Eq, Ord, Show ) marshalInterleavedArrays :: InterleavedArrays -> GLenum marshalInterleavedArrays x = case x of V2f -> gl_V2F V3f -> gl_V3F C4ubV2f -> gl_C4UB_V2F C4ubV3f -> gl_C4UB_V3F C3fV3f -> gl_C3F_V3F N3fV3f -> gl_N3F_V3F C4fN3fV3f -> gl_C4F_N3F_V3F T2fV3f -> gl_T2F_V3F T4fV4f -> gl_T4F_V4F T2fC4ubV3f -> gl_T2F_C4UB_V3F T2fC3fV3f -> gl_T2F_C3F_V3F T2fN3fV3f -> gl_T2F_N3F_V3F T2fC4fN3fV3f -> gl_T2F_C4F_N3F_V3F T4fC4fN3fV4f -> gl_T4F_C4F_N3F_V4F -------------------------------------------------------------------------------- interleavedArrays :: InterleavedArrays -> Stride -> Ptr a -> IO () interleavedArrays = glInterleavedArrays . marshalInterleavedArrays -------------------------------------------------------------------------------- clientState :: ClientArrayType -> StateVar Capability clientState arrayType = makeStateVar (getClientState arrayType) (setClientState arrayType) getClientState :: ClientArrayType -> IO Capability getClientState arrayType = get . makeCapability . clientArrayTypeToEnableCap $ arrayType setClientState :: ClientArrayType -> Capability -> IO () setClientState arrayType val = (if val == Enabled then glEnableClientState else glDisableClientState) (marshalClientArrayType arrayType) -------------------------------------------------------------------------------- clientActiveTexture :: StateVar TextureUnit clientActiveTexture = makeStateVar (getEnum1 unmarshalTextureUnit GetClientActiveTexture) (glClientActiveTexture . marshalTextureUnit) -------------------------------------------------------------------------------- type ArrayIndex = GLint type NumArrayIndices = GLsizei type NumIndexBlocks = GLsizei -------------------------------------------------------------------------------- arrayElement :: ArrayIndex -> IO () arrayElement = glArrayElement drawArrays :: PrimitiveMode -> ArrayIndex -> NumArrayIndices -> IO () drawArrays = glDrawArrays . marshalPrimitiveMode multiDrawArrays :: PrimitiveMode -> Ptr ArrayIndex -> Ptr NumArrayIndices -> NumIndexBlocks -> IO () multiDrawArrays = glMultiDrawArrays . marshalPrimitiveMode drawElements :: PrimitiveMode -> NumArrayIndices -> DataType -> Ptr a -> IO () drawElements m c = glDrawElements (marshalPrimitiveMode m) c . marshalDataType multiDrawElements :: PrimitiveMode -> Ptr NumArrayIndices -> DataType -> Ptr (Ptr a) -> NumIndexBlocks -> IO () multiDrawElements m c = glMultiDrawElements (marshalPrimitiveMode m) c . marshalDataType drawRangeElements :: PrimitiveMode -> (ArrayIndex, ArrayIndex) -> NumArrayIndices -> DataType -> Ptr a -> IO () drawRangeElements m (s, e) c = glDrawRangeElements (marshalPrimitiveMode m) (fromIntegral s) (fromIntegral e) c . marshalDataType maxElementsVertices :: GettableStateVar NumArrayIndices maxElementsVertices = makeGettableStateVar (getSizei1 id GetMaxElementsVertices) maxElementsIndices :: GettableStateVar NumArrayIndices maxElementsIndices = makeGettableStateVar (getSizei1 id GetMaxElementsIndices) -------------------------------------------------------------------------------- lockArrays :: StateVar (Maybe (ArrayIndex, NumArrayIndices)) lockArrays = makeStateVar getLockArrays setLockArrays getLockArrays :: IO (Maybe (ArrayIndex, NumArrayIndices)) getLockArrays = do count <- getInteger1 fromIntegral GetArrayElementLockCount if count > 0 then do first <- getInteger1 id GetArrayElementLockFirst return $ Just (first, count) else return Nothing setLockArrays :: Maybe (ArrayIndex, NumArrayIndices) -> IO () setLockArrays = maybe glUnlockArraysEXT (uncurry glLockArraysEXT) -------------------------------------------------------------------------------- primitiveRestartIndex :: StateVar (Maybe ArrayIndex) primitiveRestartIndex = makeStateVarMaybe (return CapPrimitiveRestart) (getInteger1 id GetPrimitiveRestartIndex) (glPrimitiveRestartIndex . fromIntegral) -------------------------------------------------------------------------------- -- We almost could use makeStateVarMaybe below, but, alas, this is client state. primitiveRestartIndexNV :: StateVar (Maybe ArrayIndex) primitiveRestartIndexNV = makeStateVar getPrimitiveRestartIndexNV setPrimitiveRestartIndexNV getPrimitiveRestartIndexNV :: IO (Maybe ArrayIndex) getPrimitiveRestartIndexNV = do on <- getBoolean1 unmarshalGLboolean GetPrimitiveRestartNV if on then fmap Just $ getInteger1 fromIntegral GetPrimitiveRestartIndexNV else return Nothing setPrimitiveRestartIndexNV :: Maybe ArrayIndex -> IO () setPrimitiveRestartIndexNV maybeIdx = case maybeIdx of Nothing -> glDisableClientState gl_PRIMITIVE_RESTART_NV Just idx -> do glEnableClientState gl_PRIMITIVE_RESTART_NV glPrimitiveRestartIndexNV (fromIntegral idx) -------------------------------------------------------------------------------- vertexAttribPointer :: AttribLocation -> StateVar (IntegerHandling, VertexArrayDescriptor a) vertexAttribPointer location = makeStateVar (getVertexAttribPointer_ location) (setVertexAttribPointer location) getVertexAttribPointer_ :: AttribLocation -> IO (IntegerHandling, VertexArrayDescriptor a) getVertexAttribPointer_ location = do i <- getVertexAttribBoolean1 unmarshalGLboolean location GetVertexAttribArrayInteger h <- if i then return KeepIntegral else do f <- getVertexAttribBoolean1 unmarshalGLboolean location GetVertexAttribArrayNormalized return $ if f then ToNormalizedFloat else ToFloat n <- getVertexAttribInteger1 id location GetVertexAttribArraySize d <- getVertexAttribEnum1 unmarshalDataType location GetVertexAttribArrayType s <- getVertexAttribInteger1 fromIntegral location GetVertexAttribArrayStride p <- getVertexAttribPointer location VertexAttribArrayPointer return (h, VertexArrayDescriptor n d s p) setVertexAttribPointer :: AttribLocation -> (IntegerHandling, VertexArrayDescriptor a) -> IO () setVertexAttribPointer (AttribLocation location) (h, VertexArrayDescriptor n d s p) = case h of ToFloat -> glVertexAttribPointer location n md (marshalGLboolean False) s p ToNormalizedFloat -> glVertexAttribPointer location n md (marshalGLboolean True) s p KeepIntegral -> glVertexAttribIPointer location n md s p where md = marshalDataType d -------------------------------------------------------------------------------- vertexAttribArray :: AttribLocation -> StateVar Capability vertexAttribArray location = makeStateVar (getVertexAttribArray location) (flip setVertexAttribArray location) getVertexAttribArray :: AttribLocation -> IO Capability getVertexAttribArray location = getVertexAttribBoolean1 unmarshalCapability location GetVertexAttribArrayEnabled setVertexAttribArray :: Capability -> AttribLocation -> IO () setVertexAttribArray Disabled (AttribLocation location) = glDisableVertexAttribArray location setVertexAttribArray Enabled (AttribLocation location) = glEnableVertexAttribArray location OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/SyncObjects.hs0000644000000000000000000000741412521420345021725 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.SyncObjects -- Copyright : (c) Sven Panne 2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 4.1 (Sync Objects and Fences) of the -- OpenGL 4.4 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.SyncObjects ( -- * Sync Objects and Fences SyncObject, syncGpuCommandsComplete, -- * Waiting for Sync Objects WaitTimeout, WaitFlag(..), WaitResult(..), clientWaitSync, waitSync, maxServerWaitTimeout, -- * Sync Object Queries SyncStatus(..), syncStatus ) where import Control.Monad.IO.Class import Data.ObjectName import Data.StateVar import Foreign.Marshal.Utils ( with ) import Foreign.Ptr ( nullPtr ) import Graphics.Rendering.OpenGL.GL.DebugOutput import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- newtype SyncObject = SyncObject { syncID :: GLsync } deriving ( Eq, Ord, Show ) instance ObjectName SyncObject where isObjectName = liftIO . fmap unmarshalGLboolean . glIsSync . syncID deleteObjectName = liftIO . glDeleteSync . syncID instance CanBeLabeled SyncObject where objectLabel = objectPtrLabel . syncID syncGpuCommandsComplete :: IO SyncObject syncGpuCommandsComplete = fmap SyncObject $ glFenceSync gl_SYNC_GPU_COMMANDS_COMPLETE 0 -------------------------------------------------------------------------------- type WaitTimeout = GLuint64 -------------------------------------------------------------------------------- data WaitFlag = SyncFlushCommands deriving ( Eq, Ord, Show ) marshalWaitFlag :: WaitFlag -> GLbitfield marshalWaitFlag x = case x of SyncFlushCommands -> gl_SYNC_FLUSH_COMMANDS_BIT -------------------------------------------------------------------------------- data WaitResult = AlreadySignaled | TimeoutExpired | ConditionSatisfied | WaitFailed deriving ( Eq, Ord, Show ) unmarshalWaitResult :: GLenum -> WaitResult unmarshalWaitResult x | x == gl_ALREADY_SIGNALED = AlreadySignaled | x == gl_TIMEOUT_EXPIRED = TimeoutExpired | x == gl_CONDITION_SATISFIED = ConditionSatisfied | x == gl_WAIT_FAILED = WaitFailed | otherwise = error ("unmarshalWaitResult: illegal value " ++ show x) -------------------------------------------------------------------------------- clientWaitSync :: SyncObject -> [WaitFlag] -> WaitTimeout -> IO WaitResult clientWaitSync syncObject flags = fmap unmarshalWaitResult . glClientWaitSync (syncID syncObject) (sum (map marshalWaitFlag flags)) waitSync :: SyncObject -> IO () waitSync syncObject = glWaitSync (syncID syncObject) 0 (fromIntegral gl_TIMEOUT_IGNORED) maxServerWaitTimeout :: GettableStateVar WaitTimeout maxServerWaitTimeout = makeGettableStateVar (getInteger64 fromIntegral GetMaxServerWaitTimeout) -------------------------------------------------------------------------------- data SyncStatus = Unsignaled | Signaled deriving ( Eq, Ord, Show ) unmarshalSyncStatus :: GLenum -> SyncStatus unmarshalSyncStatus x | x == gl_UNSIGNALED = Unsignaled | x == gl_SIGNALED = Signaled | otherwise = error ("unmarshalSyncStatus: illegal value " ++ show x) syncStatus :: SyncObject -> GettableStateVar SyncStatus syncStatus syncObject = makeGettableStateVar $ with 0 $ \buf -> do glGetSynciv (syncID syncObject) gl_SYNC_STATUS 1 nullPtr buf peek1 (unmarshalSyncStatus . fromIntegral) buf OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/ComparisonFunction.hs0000644000000000000000000000312712521420345023314 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.ComparisonFunction -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for (un-)marshaling ComparisonFunction. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.ComparisonFunction ( ComparisonFunction(..), marshalComparisonFunction, unmarshalComparisonFunction ) where import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data ComparisonFunction = Never | Less | Equal | Lequal | Greater | Notequal | Gequal | Always deriving ( Eq, Ord, Show ) marshalComparisonFunction :: ComparisonFunction -> GLenum marshalComparisonFunction x = case x of Never -> gl_NEVER Less -> gl_LESS Equal -> gl_EQUAL Lequal -> gl_LEQUAL Greater -> gl_GREATER Notequal -> gl_NOTEQUAL Gequal -> gl_GEQUAL Always -> gl_ALWAYS unmarshalComparisonFunction :: GLenum -> ComparisonFunction unmarshalComparisonFunction x | x == gl_NEVER = Never | x == gl_LESS = Less | x == gl_EQUAL = Equal | x == gl_LEQUAL = Lequal | x == gl_GREATER = Greater | x == gl_NOTEQUAL = Notequal | x == gl_GEQUAL = Gequal | x == gl_ALWAYS = Always | otherwise = error ("unmarshalComparisonFunction: illegal value " ++ show x) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Tensor.hs0000644000000000000000000002501712521420345020750 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Tensor -- Copyright : (c) Sven Panne 2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This package contains tensor data types and their instances for some basic -- type classes. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Tensor ( Vertex1(..), Vertex2(..), Vertex3(..), Vertex4(..), Vector1(..), Vector2(..), Vector3(..), Vector4(..) ) where import Control.Applicative ( Applicative(..) ) import Control.Monad ( ap ) import Data.Foldable ( Foldable(..), foldlM ) import Data.Ix ( Ix ) import Data.Traversable ( Traversable(..), mapAccumL ) import Data.Typeable ( Typeable ) import Foreign.Marshal.Array ( advancePtr ) import Foreign.Ptr ( Ptr, plusPtr, castPtr ) import Foreign.Storable ( Storable(..) ) -------------------------------------------------------------------------------- -- | A vertex with /y/=0, /z/=0 and /w/=1. newtype Vertex1 a = Vertex1 a deriving (Eq, Ord, Ix, Bounded, Show, Read, Typeable) instance Functor Vertex1 where fmap f (Vertex1 x) = Vertex1 (f x) instance Applicative Vertex1 where pure a = Vertex1 a Vertex1 f <*> Vertex1 x = Vertex1 (f x) instance Foldable Vertex1 where foldr f a (Vertex1 x) = x `f ` a foldl f a (Vertex1 x) = a `f` x foldr1 _ (Vertex1 x) = x foldl1 _ (Vertex1 x) = x instance Traversable Vertex1 where traverse f (Vertex1 x) = pure Vertex1 <*> f x sequenceA (Vertex1 x) = pure Vertex1 <*> x mapM f (Vertex1 x) = return Vertex1 `ap` f x sequence (Vertex1 x) = return Vertex1 `ap` x instance Storable a => Storable (Vertex1 a) where sizeOf ~(Vertex1 s) = sizeOf s alignment ~(Vertex1 s) = alignment s peek = peekApplicativeTraversable poke = pokeFoldable -------------------------------------------------------------------------------- -- | A vertex with /z/=0 and /w/=1. data Vertex2 a = Vertex2 !a !a deriving (Eq, Ord, Ix, Bounded, Show, Read, Typeable) instance Functor Vertex2 where fmap f (Vertex2 x y) = Vertex2 (f x) (f y) instance Applicative Vertex2 where pure a = Vertex2 a a Vertex2 f g <*> Vertex2 x y = Vertex2 (f x) (g y) instance Foldable Vertex2 where foldr f a (Vertex2 x y) = x `f ` (y `f` a) foldl f a (Vertex2 x y) = (a `f` x) `f` y foldr1 f (Vertex2 x y) = x `f` y foldl1 f (Vertex2 x y) = x `f` y instance Traversable Vertex2 where traverse f (Vertex2 x y) = pure Vertex2 <*> f x <*> f y sequenceA (Vertex2 x y) = pure Vertex2 <*> x <*> y mapM f (Vertex2 x y) = return Vertex2 `ap` f x `ap` f y sequence (Vertex2 x y) = return Vertex2 `ap` x `ap` y instance Storable a => Storable (Vertex2 a) where sizeOf ~(Vertex2 x _) = 2 * sizeOf x alignment ~(Vertex2 x _) = alignment x peek = peekApplicativeTraversable poke = pokeFoldable -------------------------------------------------------------------------------- -- | A vertex with /w/=1. data Vertex3 a = Vertex3 !a !a !a deriving (Eq, Ord, Ix, Bounded, Show, Read, Typeable) instance Functor Vertex3 where fmap f (Vertex3 x y z) = Vertex3 (f x) (f y) (f z) instance Applicative Vertex3 where pure a = Vertex3 a a a Vertex3 f g h <*> Vertex3 x y z = Vertex3 (f x) (g y) (h z) instance Foldable Vertex3 where foldr f a (Vertex3 x y z) = x `f ` (y `f` (z `f` a)) foldl f a (Vertex3 x y z) = ((a `f` x) `f` y) `f` z foldr1 f (Vertex3 x y z) = x `f` (y `f` z) foldl1 f (Vertex3 x y z) = (x `f` y) `f` z instance Traversable Vertex3 where traverse f (Vertex3 x y z) = pure Vertex3 <*> f x <*> f y <*> f z sequenceA (Vertex3 x y z) = pure Vertex3 <*> x <*> y <*> z mapM f (Vertex3 x y z) = return Vertex3 `ap` f x `ap` f y `ap` f z sequence (Vertex3 x y z) = return Vertex3 `ap` x `ap` y `ap` z instance Storable a => Storable (Vertex3 a) where sizeOf ~(Vertex3 x _ _) = 3 * sizeOf x alignment ~(Vertex3 x _ _) = alignment x peek = peekApplicativeTraversable poke = pokeFoldable -------------------------------------------------------------------------------- -- | A fully-fledged four-dimensional vertex. data Vertex4 a = Vertex4 !a !a !a !a deriving (Eq, Ord, Ix, Bounded, Show, Read, Typeable) instance Functor Vertex4 where fmap f (Vertex4 x y z w) = Vertex4 (f x) (f y) (f z) (f w) instance Applicative Vertex4 where pure a = Vertex4 a a a a Vertex4 f g h i <*> Vertex4 x y z w = Vertex4 (f x) (g y) (h z) (i w) instance Foldable Vertex4 where foldr f a (Vertex4 x y z w) = x `f ` (y `f` (z `f` (w `f` a))) foldl f a (Vertex4 x y z w) = (((a `f` x) `f` y) `f` z) `f` w foldr1 f (Vertex4 x y z w) = x `f` (y `f` (z `f` w)) foldl1 f (Vertex4 x y z w) = ((x `f` y) `f` z) `f` w instance Traversable Vertex4 where traverse f (Vertex4 x y z w) = pure Vertex4 <*> f x <*> f y <*> f z <*> f w sequenceA (Vertex4 x y z w) = pure Vertex4 <*> x <*> y <*> z <*> w mapM f (Vertex4 x y z w) = return Vertex4 `ap` f x `ap` f y `ap` f z `ap` f w sequence (Vertex4 x y z w) = return Vertex4 `ap` x `ap` y `ap` z `ap` w instance Storable a => Storable (Vertex4 a) where sizeOf ~(Vertex4 x _ _ _) = 4 * sizeOf x alignment ~(Vertex4 x _ _ _) = alignment x peek = peekApplicativeTraversable poke = pokeFoldable -------------------------------------------------------------------------------- -- | A one-dimensional vector. newtype Vector1 a = Vector1 a deriving (Eq, Ord, Ix, Bounded, Show, Read, Typeable) instance Functor Vector1 where fmap f (Vector1 x) = Vector1 (f x) instance Applicative Vector1 where pure a = Vector1 a Vector1 f <*> Vector1 x = Vector1 (f x) instance Foldable Vector1 where foldr f a (Vector1 x) = x `f ` a foldl f a (Vector1 x) = a `f` x foldr1 _ (Vector1 x) = x foldl1 _ (Vector1 x) = x instance Traversable Vector1 where traverse f (Vector1 x) = pure Vector1 <*> f x sequenceA (Vector1 x) = pure Vector1 <*> x mapM f (Vector1 x) = return Vector1 `ap` f x sequence (Vector1 x) = return Vector1 `ap` x instance Storable a => Storable (Vector1 a) where sizeOf ~(Vector1 s) = sizeOf s alignment ~(Vector1 s) = alignment s peek = peekApplicativeTraversable poke = pokeFoldable -------------------------------------------------------------------------------- -- | A two-dimensional vector. data Vector2 a = Vector2 !a !a deriving (Eq, Ord, Ix, Bounded, Show, Read, Typeable) instance Functor Vector2 where fmap f (Vector2 x y) = Vector2 (f x) (f y) instance Applicative Vector2 where pure a = Vector2 a a Vector2 f g <*> Vector2 x y = Vector2 (f x) (g y) instance Foldable Vector2 where foldr f a (Vector2 x y) = x `f ` (y `f` a) foldl f a (Vector2 x y) = (a `f` x) `f` y foldr1 f (Vector2 x y) = x `f` y foldl1 f (Vector2 x y) = x `f` y instance Traversable Vector2 where traverse f (Vector2 x y) = pure Vector2 <*> f x <*> f y sequenceA (Vector2 x y) = pure Vector2 <*> x <*> y mapM f (Vector2 x y) = return Vector2 `ap` f x `ap` f y sequence (Vector2 x y) = return Vector2 `ap` x `ap` y instance Storable a => Storable (Vector2 a) where sizeOf ~(Vector2 x _) = 2 * sizeOf x alignment ~(Vector2 x _) = alignment x peek = peekApplicativeTraversable poke = pokeFoldable -------------------------------------------------------------------------------- -- | A three-dimensional vector. data Vector3 a = Vector3 !a !a !a deriving (Eq, Ord, Ix, Bounded, Show, Read, Typeable) instance Functor Vector3 where fmap f (Vector3 x y z) = Vector3 (f x) (f y) (f z) instance Applicative Vector3 where pure a = Vector3 a a a Vector3 f g h <*> Vector3 x y z = Vector3 (f x) (g y) (h z) instance Foldable Vector3 where foldr f a (Vector3 x y z) = x `f ` (y `f` (z `f` a)) foldl f a (Vector3 x y z) = ((a `f` x) `f` y) `f` z foldr1 f (Vector3 x y z) = x `f` (y `f` z) foldl1 f (Vector3 x y z) = (x `f` y) `f` z instance Traversable Vector3 where traverse f (Vector3 x y z) = pure Vector3 <*> f x <*> f y <*> f z sequenceA (Vector3 x y z) = pure Vector3 <*> x <*> y <*> z mapM f (Vector3 x y z) = return Vector3 `ap` f x `ap` f y `ap` f z sequence (Vector3 x y z) = return Vector3 `ap` x `ap` y `ap` z instance Storable a => Storable (Vector3 a) where sizeOf ~(Vector3 x _ _) = 3 * sizeOf x alignment ~(Vector3 x _ _) = alignment x peek = peekApplicativeTraversable poke = pokeFoldable -------------------------------------------------------------------------------- -- | A four-dimensional vector. data Vector4 a = Vector4 !a !a !a !a deriving (Eq, Ord, Ix, Bounded, Show, Read, Typeable) instance Functor Vector4 where fmap f (Vector4 x y z w) = Vector4 (f x) (f y) (f z) (f w) instance Applicative Vector4 where pure a = Vector4 a a a a Vector4 f g h i <*> Vector4 x y z w = Vector4 (f x) (g y) (h z) (i w) instance Foldable Vector4 where foldr f a (Vector4 x y z w) = x `f ` (y `f` (z `f` (w `f` a))) foldl f a (Vector4 x y z w) = (((a `f` x) `f` y) `f` z) `f` w foldr1 f (Vector4 x y z w) = x `f` (y `f` (z `f` w)) foldl1 f (Vector4 x y z w) = ((x `f` y) `f` z) `f` w instance Traversable Vector4 where traverse f (Vector4 x y z w) = pure Vector4 <*> f x <*> f y <*> f z <*> f w sequenceA (Vector4 x y z w) = pure Vector4 <*> x <*> y <*> z <*> w mapM f (Vector4 x y z w) = return Vector4 `ap` f x `ap` f y `ap` f z `ap` f w sequence (Vector4 x y z w) = return Vector4 `ap` x `ap` y `ap` z `ap` w instance Storable a => Storable (Vector4 a) where sizeOf ~(Vector4 x _ _ _) = 4 * sizeOf x alignment ~(Vector4 x _ _ _) = alignment x peek = peekApplicativeTraversable poke = pokeFoldable -------------------------------------------------------------------------------- peekApplicativeTraversable :: (Applicative t, Traversable t, Storable a) => Ptr (t a) -> IO (t a) peekApplicativeTraversable = Data.Traversable.mapM peek . addresses addresses :: (Applicative t, Traversable t, Storable a) => Ptr (t a) -> t (Ptr a) addresses = snd . mapAccumL nextPtr 0 . pure . castPtr nextPtr :: Storable a => Int -> Ptr a -> (Int, Ptr a) nextPtr offset ptr = (offset + 1, advancePtr ptr offset) -------------------------------------------------------------------------------- pokeFoldable :: (Foldable t, Storable a) => Ptr (t a) -> t a -> IO () pokeFoldable ptr xs = foldlM pokeAndAdvance (castPtr ptr) xs >> return () pokeAndAdvance :: Storable a => Ptr a -> a -> IO (Ptr a) pokeAndAdvance ptr value = do poke ptr value return $ ptr `plusPtr` sizeOf value OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/IOState.hs0000644000000000000000000000363312521420345021006 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.IOState -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for an IO monad with a pointer as an -- additional state, basically a /StateT (Ptr s) IO a/. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.IOState ( IOState(..), getIOState, peekIOState, evalIOState, nTimes ) where import Control.Applicative ( Applicative(..) ) import Control.Monad ( ap, liftM, replicateM ) import Foreign.Ptr ( Ptr, plusPtr ) import Foreign.Storable ( Storable(sizeOf,peek) ) -------------------------------------------------------------------------------- newtype IOState s a = IOState { runIOState :: Ptr s -> IO (a, Ptr s) } instance Applicative (IOState s) where pure = return (<*>) = ap instance Functor (IOState s) where fmap = liftM instance Monad (IOState s) where return a = IOState $ \s -> return (a, s) m >>= k = IOState $ \s -> do (a, s') <- runIOState m s ; runIOState (k a) s' fail str = IOState $ \_ -> fail str getIOState :: IOState s (Ptr s) getIOState = IOState $ \s -> return (s, s) putIOState :: Ptr s -> IOState s () putIOState s = IOState $ \_ -> return ((), s) peekIOState :: Storable a => IOState a a peekIOState = do ptr <- getIOState x <- liftIOState $ peek ptr putIOState (ptr `plusPtr` sizeOf x) return x liftIOState :: IO a -> IOState s a liftIOState m = IOState $ \s -> do a <- m ; return (a, s) evalIOState :: IOState s a -> Ptr s -> IO a evalIOState m s = do (a, _) <- runIOState m s ; return a nTimes :: Integral a => a -> IOState b c -> IOState b [c] nTimes n = replicateM (fromIntegral n) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/ReadCopyPixels.hs0000644000000000000000000000631412521420345022370 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.ReadCopyPixels -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 4.3 (Drawing, Reading, and Copying Pixels) -- of the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.ReadCopyPixels ( -- * Reading Pixels readPixels, readBuffer, -- * Copying Pixels PixelCopyType(..), copyPixels, -- * Copying Pixels for framebuffers BlitBuffer(..), blitFramebuffer ) where import Data.StateVar import Graphics.Rendering.OpenGL.GL.BufferMode import Graphics.Rendering.OpenGL.GL.CoordTrans import Graphics.Rendering.OpenGL.GL.PixelData import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.Texturing.Filter import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- readPixels :: Position -> Size -> PixelData a -> IO () readPixels (Position x y) (Size w h) pd = withPixelData pd $ glReadPixels x y w h -------------------------------------------------------------------------------- readBuffer :: StateVar BufferMode readBuffer = makeStateVar (getEnum1 unmarshalBufferMode GetReadBuffer) (maybe recordInvalidValue glReadBuffer . marshalBufferMode) -------------------------------------------------------------------------------- data PixelCopyType = CopyColor | CopyDepth | CopyStencil deriving ( Eq, Ord, Show ) marshalPixelCopyType :: PixelCopyType -> GLenum marshalPixelCopyType x = case x of CopyColor -> gl_COLOR CopyDepth -> gl_DEPTH CopyStencil -> gl_STENCIL -------------------------------------------------------------------------------- copyPixels :: Position -> Size -> PixelCopyType -> IO () copyPixels (Position x y) (Size w h) t = glCopyPixels x y w h (marshalPixelCopyType t) -------------------------------------------------------------------------------- -- | The buffers which can be copied with 'blitFramebuffer'. data BlitBuffer = ColorBuffer' | StencilBuffer' | DepthBuffer' deriving ( Eq, Ord, Show ) marshalBlitBuffer :: BlitBuffer -> GLbitfield marshalBlitBuffer x = case x of ColorBuffer' -> gl_COLOR_BUFFER_BIT StencilBuffer' -> gl_STENCIL_BUFFER_BIT DepthBuffer' -> gl_DEPTH_BUFFER_BIT -------------------------------------------------------------------------------- blitFramebuffer :: Position -> Position -> Position -> Position -> [BlitBuffer] -> TextureFilter -> IO () blitFramebuffer (Position sx0 sy0) (Position sx1 sy1) (Position dx0 dy0) (Position dx1 dy1) buffers filt = glBlitFramebuffer sx0 sy0 sx1 sy1 dx0 dy0 dx1 dy1 (sum (map marshalBlitBuffer buffers)) (fromIntegral (marshalMagnificationFilter filt)) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/DataType.hs0000644000000000000000000001266212521420345021213 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.DataType -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for (un-)marshaling DataType. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.DataType ( DataType(..), marshalDataType, unmarshalDataType, DataTypeType(..), marshalDataTypeType, unmarshalDataTypeType ) where import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- basically table 3.2 (pixel data type parameter) plus a few additions data DataType = UnsignedByte | Byte | UnsignedShort | Short | UnsignedInt | Int | HalfFloat | Float | UnsignedByte332 | UnsignedByte233Rev | UnsignedShort565 | UnsignedShort565Rev | UnsignedShort4444 | UnsignedShort4444Rev | UnsignedShort5551 | UnsignedShort1555Rev | UnsignedInt8888 | UnsignedInt8888Rev | UnsignedInt1010102 | UnsignedInt2101010Rev | UnsignedInt248 | UnsignedInt10f11f11fRev | UnsignedInt5999Rev | Float32UnsignedInt248Rev | Bitmap -- pixel data, deprecated in 3.1 | UnsignedShort88 -- MESA_ycbcr_texture/APPLE_ycbcr_422 | UnsignedShort88Rev -- MESA_ycbcr_texture/APPLE_ycbcr_422 | Double -- vertex arrays (EXT_vertex_array, now core) | TwoBytes -- CallLists | ThreeBytes -- CallLists | FourBytes -- CallLists deriving ( Eq, Ord, Show ) marshalDataType :: DataType -> GLenum marshalDataType x = case x of UnsignedByte -> gl_UNSIGNED_BYTE Byte -> gl_BYTE UnsignedShort -> gl_UNSIGNED_SHORT Short -> gl_SHORT UnsignedInt -> gl_UNSIGNED_INT Int -> gl_INT HalfFloat -> gl_HALF_FLOAT Float -> gl_FLOAT UnsignedByte332 -> gl_UNSIGNED_BYTE_3_3_2 UnsignedByte233Rev -> gl_UNSIGNED_BYTE_2_3_3_REV UnsignedShort565 -> gl_UNSIGNED_SHORT_5_6_5 UnsignedShort565Rev -> gl_UNSIGNED_SHORT_5_6_5_REV UnsignedShort4444 -> gl_UNSIGNED_SHORT_4_4_4_4 UnsignedShort4444Rev -> gl_UNSIGNED_SHORT_4_4_4_4_REV UnsignedShort5551 -> gl_UNSIGNED_SHORT_5_5_5_1 UnsignedShort1555Rev -> gl_UNSIGNED_SHORT_1_5_5_5_REV UnsignedInt8888 -> gl_UNSIGNED_INT_8_8_8_8 UnsignedInt8888Rev -> gl_UNSIGNED_INT_8_8_8_8_REV UnsignedInt1010102 -> gl_UNSIGNED_INT_10_10_10_2 UnsignedInt2101010Rev -> gl_UNSIGNED_INT_2_10_10_10_REV UnsignedInt248 -> gl_UNSIGNED_INT_24_8 UnsignedInt10f11f11fRev -> gl_UNSIGNED_INT_10F_11F_11F_REV UnsignedInt5999Rev -> gl_UNSIGNED_INT_5_9_9_9_REV Float32UnsignedInt248Rev -> gl_FLOAT_32_UNSIGNED_INT_24_8_REV Bitmap -> gl_BITMAP UnsignedShort88 -> gl_UNSIGNED_SHORT_8_8_APPLE UnsignedShort88Rev -> gl_UNSIGNED_SHORT_8_8_REV_APPLE Double -> gl_DOUBLE TwoBytes -> gl_2_BYTES ThreeBytes -> gl_3_BYTES FourBytes -> gl_4_BYTES unmarshalDataType :: GLenum -> DataType unmarshalDataType x | x == gl_UNSIGNED_BYTE = UnsignedByte | x == gl_BYTE = Byte | x == gl_UNSIGNED_SHORT = UnsignedShort | x == gl_SHORT = Short | x == gl_UNSIGNED_INT = UnsignedInt | x == gl_INT = Int | x == gl_HALF_FLOAT = HalfFloat | x == gl_FLOAT = Float | x == gl_UNSIGNED_BYTE_3_3_2 = UnsignedByte332 | x == gl_UNSIGNED_BYTE_2_3_3_REV = UnsignedByte233Rev | x == gl_UNSIGNED_SHORT_5_6_5 = UnsignedShort565 | x == gl_UNSIGNED_SHORT_5_6_5_REV = UnsignedShort565Rev | x == gl_UNSIGNED_SHORT_4_4_4_4 = UnsignedShort4444 | x == gl_UNSIGNED_SHORT_4_4_4_4_REV = UnsignedShort4444Rev | x == gl_UNSIGNED_SHORT_5_5_5_1 = UnsignedShort5551 | x == gl_UNSIGNED_SHORT_1_5_5_5_REV = UnsignedShort1555Rev | x == gl_UNSIGNED_INT_8_8_8_8 = UnsignedInt8888 | x == gl_UNSIGNED_INT_8_8_8_8_REV = UnsignedInt8888Rev | x == gl_UNSIGNED_INT_10_10_10_2 = UnsignedInt1010102 | x == gl_UNSIGNED_INT_2_10_10_10_REV = UnsignedInt2101010Rev | x == gl_UNSIGNED_INT_24_8 = UnsignedInt248 | x == gl_UNSIGNED_INT_10F_11F_11F_REV = UnsignedInt10f11f11fRev | x == gl_UNSIGNED_INT_5_9_9_9_REV = UnsignedInt5999Rev | x == gl_FLOAT_32_UNSIGNED_INT_24_8_REV = Float32UnsignedInt248Rev | x == gl_BITMAP = Bitmap | x == gl_UNSIGNED_SHORT_8_8_APPLE = UnsignedShort88 | x == gl_UNSIGNED_SHORT_8_8_REV_APPLE = UnsignedShort88Rev | x == gl_DOUBLE = Double | x == gl_2_BYTES = TwoBytes | x == gl_3_BYTES = ThreeBytes | x == gl_4_BYTES = FourBytes | otherwise = error ("unmarshalDataType: illegal value " ++ show x) data DataTypeType = TNone | TSignedNormalized | TUnsignedNormalized | TFloat | TInt | TUnsignedInt marshalDataTypeType :: DataTypeType -> GLenum marshalDataTypeType x = case x of TNone -> gl_NONE TSignedNormalized -> gl_SIGNED_NORMALIZED TUnsignedNormalized -> gl_UNSIGNED_NORMALIZED TFloat -> gl_FLOAT TInt -> gl_INT TUnsignedInt -> gl_UNSIGNED_INT unmarshalDataTypeType :: GLenum -> DataTypeType unmarshalDataTypeType x | x == gl_NONE = TNone | x == gl_SIGNED_NORMALIZED = TSignedNormalized | x == gl_UNSIGNED_NORMALIZED = TUnsignedNormalized | x == gl_FLOAT = TFloat | x == gl_INT = TInt | x == gl_UNSIGNED_INT = TUnsignedInt | otherwise = error $ "unmarshalDataTypeType: illegal value " ++ show x OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/ByteString.hs0000644000000000000000000000416112521420345021565 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.ByteString -- Copyright : (c) Sven Panne 2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for interfacing with ByteStrings. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.ByteString ( B.ByteString, stringQuery, createAndTrimByteString, withByteString, withGLstring, packUtf8, unpackUtf8 ) where import Data.StateVar import Foreign.Ptr import Graphics.Rendering.OpenGL.Raw import qualified Data.ByteString as B import qualified Data.ByteString.Internal as BI import qualified Data.ByteString.Unsafe as BU import qualified Data.Text as T import qualified Data.Text.Encoding as TE -------------------------------------------------------------------------------- stringQuery :: (a -> GettableStateVar GLsizei) -> (a -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO ()) -> a -> IO B.ByteString stringQuery lengthVar getStr obj = do len <- get (lengthVar obj) createByteString len $ getStr obj len nullPtr createByteString :: Integral a => a -> (Ptr GLchar -> IO ()) -> IO B.ByteString createByteString size act = BI.create (fromIntegral size) (act . castPtr) createAndTrimByteString :: (Integral a, Integral b) => a -> (Ptr GLchar -> IO b) -> IO B.ByteString createAndTrimByteString maxLen act = BI.createAndTrim (fromIntegral maxLen) (fmap fromIntegral . act . castPtr) withByteString :: B.ByteString -> (Ptr GLchar -> GLsizei -> IO b) -> IO b withByteString bs act = BU.unsafeUseAsCStringLen bs $ \(ptr, size) -> act (castPtr ptr) (fromIntegral size) withGLstring :: String -> (Ptr GLchar -> IO a) -> IO a withGLstring s act = withByteString (packUtf8 (s ++ "\0")) (const . act) packUtf8 :: String -> B.ByteString packUtf8 = TE.encodeUtf8 . T.pack unpackUtf8 :: B.ByteString -> String unpackUtf8 = T.unpack . TE.decodeUtf8 OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/BlendingFactor.hs0000644000000000000000000000477212521420345022364 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.BlendingFactor -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for (un-)marshaling BlendingFactor. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.BlendingFactor ( BlendingFactor(..), marshalBlendingFactor, unmarshalBlendingFactor ) where import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data BlendingFactor = Zero | One | SrcColor | OneMinusSrcColor | DstColor | OneMinusDstColor | SrcAlpha | OneMinusSrcAlpha | DstAlpha | OneMinusDstAlpha | ConstantColor | OneMinusConstantColor | ConstantAlpha | OneMinusConstantAlpha | SrcAlphaSaturate deriving ( Eq, Ord, Show ) marshalBlendingFactor :: BlendingFactor -> GLenum marshalBlendingFactor x = case x of Zero -> gl_ZERO One -> gl_ONE SrcColor -> gl_SRC_COLOR OneMinusSrcColor -> gl_ONE_MINUS_SRC_COLOR DstColor -> gl_DST_COLOR OneMinusDstColor -> gl_ONE_MINUS_DST_COLOR SrcAlpha -> gl_SRC_ALPHA OneMinusSrcAlpha -> gl_ONE_MINUS_SRC_ALPHA DstAlpha -> gl_DST_ALPHA OneMinusDstAlpha -> gl_ONE_MINUS_DST_ALPHA ConstantColor -> gl_CONSTANT_COLOR OneMinusConstantColor -> gl_ONE_MINUS_CONSTANT_COLOR ConstantAlpha -> gl_CONSTANT_ALPHA OneMinusConstantAlpha -> gl_ONE_MINUS_CONSTANT_ALPHA SrcAlphaSaturate -> gl_SRC_ALPHA_SATURATE unmarshalBlendingFactor :: GLenum -> BlendingFactor unmarshalBlendingFactor x | x == gl_ZERO = Zero | x == gl_ONE = One | x == gl_SRC_COLOR = SrcColor | x == gl_ONE_MINUS_SRC_COLOR = OneMinusSrcColor | x == gl_DST_COLOR = DstColor | x == gl_ONE_MINUS_DST_COLOR = OneMinusDstColor | x == gl_SRC_ALPHA = SrcAlpha | x == gl_ONE_MINUS_SRC_ALPHA = OneMinusSrcAlpha | x == gl_DST_ALPHA = DstAlpha | x == gl_ONE_MINUS_DST_ALPHA = OneMinusDstAlpha | x == gl_CONSTANT_COLOR = ConstantColor | x == gl_ONE_MINUS_CONSTANT_COLOR = OneMinusConstantColor | x == gl_CONSTANT_ALPHA = ConstantAlpha | x == gl_ONE_MINUS_CONSTANT_ALPHA = OneMinusConstantAlpha | x == gl_SRC_ALPHA_SATURATE = SrcAlphaSaturate | otherwise = error ("unmarshalBlendingFactor: illegal value " ++ show x) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/VertexSpec.hs0000644000000000000000000011576312521420345021576 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.VertexSpec -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 2.7 (Vertex Specification) of the -- OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- {-# LANGUAGE TypeSynonymInstances #-} module Graphics.Rendering.OpenGL.GL.VertexSpec ( -- * Vertex Coordinates Vertex(..), VertexComponent, -- * Auxiliary Vertex Attributes -- $AuxiliaryVertexAttributes -- ** Texture Coordinates currentTextureCoords, TexCoord(..), TexCoordComponent, TexCoord1(..), TexCoord2(..), TexCoord3(..), TexCoord4(..), -- ** Normal currentNormal, Normal(..), NormalComponent, Normal3(..), -- ** Fog Coordinate currentFogCoord, FogCoord(..), FogCoordComponent, FogCoord1(..), -- ** Color and Secondary Color rgbaMode, currentColor, Color(..), currentSecondaryColor, SecondaryColor(..), ColorComponent, Color3(..), Color4(..), currentIndex, Index(..), IndexComponent, Index1(..), -- * Generic Vertex Attributes IntegerHandling(..), AttribLocation(..), currentVertexAttrib, currentVertexAttribI, currentVertexAttribIu, VertexAttrib(..), VertexAttribComponent(..), -- * Texture Units TextureUnit(..), maxTextureUnit ) where import Data.StateVar import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.Tensor import Graphics.Rendering.OpenGL.GL.Texturing.TextureUnit import Graphics.Rendering.OpenGL.GL.VertexAttributes import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- | The class of all types which can be used as a vertex coordinate. class VertexComponent a where vertex2 :: a -> a -> IO () vertex3 :: a -> a -> a -> IO () vertex4 :: a -> a -> a -> a -> IO () vertex2v :: Ptr a -> IO () vertex3v :: Ptr a -> IO () vertex4v :: Ptr a -> IO () instance VertexComponent GLshort where vertex2 = glVertex2s vertex3 = glVertex3s vertex4 = glVertex4s vertex2v = glVertex2sv vertex3v = glVertex3sv vertex4v = glVertex4sv instance VertexComponent GLint where vertex2 = glVertex2i vertex3 = glVertex3i vertex4 = glVertex4i vertex2v = glVertex2iv vertex3v = glVertex3iv vertex4v = glVertex4iv instance VertexComponent GLfloat where vertex2 = glVertex2f vertex3 = glVertex3f vertex4 = glVertex4f vertex2v = glVertex2fv vertex3v = glVertex3fv vertex4v = glVertex4fv instance VertexComponent GLdouble where vertex2 = glVertex2d vertex3 = glVertex3d vertex4 = glVertex4d vertex2v = glVertex2dv vertex3v = glVertex3dv vertex4v = glVertex4dv -------------------------------------------------------------------------------- -- | Specify the (/x/, /y/, /z/, /w/) coordinates of a four-dimensional vertex. -- This must only be done during -- 'Graphics.Rendering.OpenGL.GL.BeginEnd.renderPrimitive', otherwise the -- behaviour is unspecified. The current values of the auxiliary vertex -- attributes are associated with the vertex. -- -- Note that there is no such thing as a \"current vertex\" which could be -- retrieved. class Vertex a where vertex :: a -> IO () vertexv :: Ptr a -> IO () instance VertexComponent a => Vertex (Vertex2 a) where vertex (Vertex2 x y) = vertex2 x y vertexv = vertex2v . (castPtr :: Ptr (Vertex2 b) -> Ptr b) instance VertexComponent a => Vertex (Vertex3 a) where vertex (Vertex3 x y z) = vertex3 x y z vertexv = vertex3v . (castPtr :: Ptr (Vertex3 b) -> Ptr b) instance VertexComponent a => Vertex (Vertex4 a) where vertex (Vertex4 x y z w) = vertex4 x y z w vertexv = vertex4v . (castPtr :: Ptr (Vertex4 b) -> Ptr b) -------------------------------------------------------------------------------- -- $AuxiliaryVertexAttributes -- Apart from its coordinates in four-dimensional space, every vertex has -- associated /auxiliary attributes/: Its texture coordinates, a normal, a -- fog coordinate, and a color plus a secondary color. For every attribute, the -- OpenGL state contains its current value, which can be changed at any time. -- -- Every attribute has a \"natural\" format via which it can be manipulated -- directly as part of the OpenGL state, e.g. the current texture coordinates -- are internally handled as @'TexCoord4' 'GLfloat'@. Different formats are -- converted to this format, e.g. the /s/, /r/, and /t/ coordinates of a -- @'TexCoord3' 'GLint'@ are converted to floating point values and a /q/ -- coordinate of 1.0 is implicitly assumed. -- -- Consequently, the vast majority of classes, functions, and data types in this -- module are for convenience only and offer no additional functionality. -------------------------------------------------------------------------------- -- | The current texture coordinates (/s/, /t/, /r/, /q/) for the current -- texture unit (see 'Graphics.Rendering.OpenGL.GL.CoordTrans.activeTexture'). -- The initial value is (0,0,0,1) for all texture units. currentTextureCoords :: StateVar (TexCoord4 GLfloat) currentTextureCoords = makeStateVar (getFloat4 TexCoord4 GetCurrentTextureCoords) texCoord -------------------------------------------------------------------------------- -- | The class of all types which can be used as a texture coordinate. class TexCoordComponent a where texCoord1 :: a -> IO () texCoord2 :: a -> a -> IO () texCoord3 :: a -> a -> a -> IO () texCoord4 :: a -> a -> a -> a -> IO () texCoord1v :: Ptr a -> IO () texCoord2v :: Ptr a -> IO () texCoord3v :: Ptr a -> IO () texCoord4v :: Ptr a -> IO () multiTexCoord1 :: GLenum -> a -> IO () multiTexCoord2 :: GLenum -> a -> a -> IO () multiTexCoord3 :: GLenum -> a -> a -> a -> IO () multiTexCoord4 :: GLenum -> a -> a -> a -> a -> IO () multiTexCoord1v :: GLenum -> Ptr a -> IO () multiTexCoord2v :: GLenum -> Ptr a -> IO () multiTexCoord3v :: GLenum -> Ptr a -> IO () multiTexCoord4v :: GLenum -> Ptr a -> IO () instance TexCoordComponent GLshort where texCoord1 = glTexCoord1s texCoord2 = glTexCoord2s texCoord3 = glTexCoord3s texCoord4 = glTexCoord4s texCoord1v = glTexCoord1sv texCoord2v = glTexCoord2sv texCoord3v = glTexCoord3sv texCoord4v = glTexCoord4sv multiTexCoord1 = glMultiTexCoord1s multiTexCoord2 = glMultiTexCoord2s multiTexCoord3 = glMultiTexCoord3s multiTexCoord4 = glMultiTexCoord4s multiTexCoord1v = glMultiTexCoord1sv multiTexCoord2v = glMultiTexCoord2sv multiTexCoord3v = glMultiTexCoord3sv multiTexCoord4v = glMultiTexCoord4sv instance TexCoordComponent GLint where texCoord1 = glTexCoord1i texCoord2 = glTexCoord2i texCoord3 = glTexCoord3i texCoord4 = glTexCoord4i texCoord1v = glTexCoord1iv texCoord2v = glTexCoord2iv texCoord3v = glTexCoord3iv texCoord4v = glTexCoord4iv multiTexCoord1 = glMultiTexCoord1i multiTexCoord2 = glMultiTexCoord2i multiTexCoord3 = glMultiTexCoord3i multiTexCoord4 = glMultiTexCoord4i multiTexCoord1v = glMultiTexCoord1iv multiTexCoord2v = glMultiTexCoord2iv multiTexCoord3v = glMultiTexCoord3iv multiTexCoord4v = glMultiTexCoord4iv instance TexCoordComponent GLfloat where texCoord1 = glTexCoord1f texCoord2 = glTexCoord2f texCoord3 = glTexCoord3f texCoord4 = glTexCoord4f texCoord1v = glTexCoord1fv texCoord2v = glTexCoord2fv texCoord3v = glTexCoord3fv texCoord4v = glTexCoord4fv multiTexCoord1 = glMultiTexCoord1f multiTexCoord2 = glMultiTexCoord2f multiTexCoord3 = glMultiTexCoord3f multiTexCoord4 = glMultiTexCoord4f multiTexCoord1v = glMultiTexCoord1fv multiTexCoord2v = glMultiTexCoord2fv multiTexCoord3v = glMultiTexCoord3fv multiTexCoord4v = glMultiTexCoord4fv instance TexCoordComponent GLdouble where texCoord1 = glTexCoord1d texCoord2 = glTexCoord2d texCoord3 = glTexCoord3d texCoord4 = glTexCoord4d texCoord1v = glTexCoord1dv texCoord2v = glTexCoord2dv texCoord3v = glTexCoord3dv texCoord4v = glTexCoord4dv multiTexCoord1 = glMultiTexCoord1d multiTexCoord2 = glMultiTexCoord2d multiTexCoord3 = glMultiTexCoord3d multiTexCoord4 = glMultiTexCoord4d multiTexCoord1v = glMultiTexCoord1dv multiTexCoord2v = glMultiTexCoord2dv multiTexCoord3v = glMultiTexCoord3dv multiTexCoord4v = glMultiTexCoord4dv -------------------------------------------------------------------------------- -- | Change the current texture coordinates of the current or given texture -- unit. class TexCoord a where texCoord :: a -> IO () texCoordv :: Ptr a -> IO () multiTexCoord :: TextureUnit -> a -> IO () multiTexCoordv :: TextureUnit -> Ptr a -> IO () instance TexCoordComponent a => TexCoord (TexCoord1 a) where texCoord (TexCoord1 s) = texCoord1 s texCoordv = texCoord1v . (castPtr :: Ptr (TexCoord1 b) -> Ptr b) multiTexCoord u (TexCoord1 s) = multiTexCoord1 (marshalTextureUnit u) s multiTexCoordv u = multiTexCoord1v (marshalTextureUnit u) . (castPtr :: Ptr (TexCoord1 b) -> Ptr b) instance TexCoordComponent a => TexCoord (TexCoord2 a) where texCoord (TexCoord2 s t) = texCoord2 s t texCoordv = texCoord2v . (castPtr :: Ptr (TexCoord2 b) -> Ptr b) multiTexCoord u (TexCoord2 s t) = multiTexCoord2 (marshalTextureUnit u) s t multiTexCoordv u = multiTexCoord2v (marshalTextureUnit u) . (castPtr :: Ptr (TexCoord2 b) -> Ptr b) instance TexCoordComponent a => TexCoord (TexCoord3 a) where texCoord (TexCoord3 s t r) = texCoord3 s t r texCoordv = texCoord3v . (castPtr :: Ptr (TexCoord3 b) -> Ptr b) multiTexCoord u (TexCoord3 s t r) = multiTexCoord3 (marshalTextureUnit u) s t r multiTexCoordv u = multiTexCoord3v (marshalTextureUnit u) . (castPtr :: Ptr (TexCoord3 b) -> Ptr b) instance TexCoordComponent a => TexCoord (TexCoord4 a) where texCoord (TexCoord4 s t r q) = texCoord4 s t r q texCoordv = texCoord4v . (castPtr :: Ptr (TexCoord4 b) -> Ptr b) multiTexCoord u (TexCoord4 s t r q) = multiTexCoord4 (marshalTextureUnit u) s t r q multiTexCoordv u = multiTexCoord4v (marshalTextureUnit u) . (castPtr :: Ptr (TexCoord4 b) -> Ptr b) -------------------------------------------------------------------------------- -- | The current normal (/x/, /y/, /z/). The initial value is the unit vector -- (0, 0, 1). currentNormal :: StateVar (Normal3 GLfloat) currentNormal = makeStateVar (getFloat3 Normal3 GetCurrentNormal) normal -------------------------------------------------------------------------------- -- | The class of all types which can be used as a component of a normal. class NormalComponent a where normal3 :: a -> a -> a -> IO () normal3v :: Ptr a -> IO () instance NormalComponent GLbyte where normal3 = glNormal3b normal3v = glNormal3bv instance NormalComponent GLshort where normal3 = glNormal3s normal3v = glNormal3sv instance NormalComponent GLint where normal3 = glNormal3i normal3v = glNormal3iv instance NormalComponent GLfloat where normal3 = glNormal3f normal3v = glNormal3fv instance NormalComponent GLdouble where normal3 = glNormal3d normal3v = glNormal3dv -------------------------------------------------------------------------------- -- | Change the current normal. Integral arguments are converted to -- floating-point with a linear mapping that maps the most positive -- representable integer value to 1.0, and the most negative representable -- integer value to -1.0. -- -- Normals specified with 'normal' or 'normalv' need not have unit length. -- If 'Graphics.Rendering.OpenGL.GL.CoordTrans.normalize' is enabled, then -- normals of any length specified with 'normal' or 'normalv' are normalized -- after transformation. If -- 'Graphics.Rendering.OpenGL.GL.CoordTrans.rescaleNormal' is enabled, normals -- are scaled by a scaling factor derived from the modelview matrix. -- 'Graphics.Rendering.OpenGL.GL.CoordTrans.rescaleNormal' requires that the -- originally specified normals were of unit length, and that the modelview -- matrix contains only uniform scales for proper results. Normalization is -- initially disabled. class Normal a where normal :: a -> IO () normalv :: Ptr a -> IO () instance NormalComponent a => Normal (Normal3 a) where normal (Normal3 x y z) = normal3 x y z normalv = normal3v . (castPtr :: Ptr (Normal3 b) -> Ptr b) -------------------------------------------------------------------------------- -- | The current fog coordinate. The initial value is 0. currentFogCoord :: StateVar (FogCoord1 GLfloat) currentFogCoord = makeStateVar (getFloat1 FogCoord1 GetCurrentFogCoord) fogCoord -------------------------------------------------------------------------------- -- | The class of all types which can be used as the fog coordinate. class FogCoordComponent a where fogCoord1 :: a -> IO () fogCoord1v :: Ptr a -> IO () instance FogCoordComponent GLfloat where fogCoord1 = glFogCoordf fogCoord1v = glFogCoordfv instance FogCoordComponent GLdouble where fogCoord1 = glFogCoordd fogCoord1v = glFogCoorddv -------------------------------------------------------------------------------- -- | Change the current fog coordinate. class FogCoord a where fogCoord :: a -> IO () fogCoordv :: Ptr a -> IO () instance FogCoordComponent a => FogCoord (FogCoord1 a) where fogCoord (FogCoord1 c) = fogCoord1 c fogCoordv = fogCoord1v . (castPtr :: Ptr (FogCoord1 b) -> Ptr b) -------------------------------------------------------------------------------- -- | If 'rgbaMode' contains 'True', the color buffers store RGBA value. If -- color indexes are stored, it contains 'False'. rgbaMode :: GettableStateVar Bool rgbaMode = makeGettableStateVar (getBoolean1 unmarshalGLboolean GetRGBAMode) -------------------------------------------------------------------------------- -- The current color (/R/, /G/, /B/, /A/). The initial value is (1, 1, 1, 1). -- Note that this state variable is significant only when the GL is in RGBA -- mode. currentColor :: StateVar (Color4 GLfloat) currentColor = makeStateVar (getFloat4 Color4 GetCurrentColor) color -- The current secondary color (/R/, /G/, /B/). The initial value is (0, 0, 0). -- Note that this state variable is significant only when the GL is in RGBA -- mode. currentSecondaryColor :: StateVar (Color3 GLfloat) currentSecondaryColor = makeStateVar (do Color4 r g b _ <- getFloat4 Color4 GetCurrentSecondaryColor return $ Color3 r g b) secondaryColor -------------------------------------------------------------------------------- -- | The class of all types which can be used as a color component. class ColorComponent a where color3 :: a -> a -> a -> IO () color4 :: a -> a -> a -> a -> IO () color3v :: Ptr a -> IO () color4v :: Ptr a -> IO () secondaryColor3 :: a -> a -> a -> IO () secondaryColor3v :: Ptr a -> IO () instance ColorComponent GLbyte where color3 = glColor3b color4 = glColor4b color3v = glColor3bv color4v = glColor4bv secondaryColor3 = glSecondaryColor3b secondaryColor3v = glSecondaryColor3bv instance ColorComponent GLshort where color3 = glColor3s color4 = glColor4s color3v = glColor3sv color4v = glColor4sv secondaryColor3 = glSecondaryColor3s secondaryColor3v = glSecondaryColor3sv instance ColorComponent GLint where color3 = glColor3i color4 = glColor4i color3v = glColor3iv color4v = glColor4iv secondaryColor3 = glSecondaryColor3i secondaryColor3v = glSecondaryColor3iv instance ColorComponent GLfloat where color3 = glColor3f color4 = glColor4f color3v = glColor3fv color4v = glColor4fv secondaryColor3 = glSecondaryColor3f secondaryColor3v = glSecondaryColor3fv instance ColorComponent GLdouble where color3 = glColor3d color4 = glColor4d color3v = glColor3dv color4v = glColor4dv secondaryColor3 = glSecondaryColor3d secondaryColor3v = glSecondaryColor3dv instance ColorComponent GLubyte where color3 = glColor3ub color4 = glColor4ub color3v = glColor3ubv color4v = glColor4ubv secondaryColor3 = glSecondaryColor3ub secondaryColor3v = glSecondaryColor3ubv instance ColorComponent GLushort where color3 = glColor3us color4 = glColor4us color3v = glColor3usv color4v = glColor4usv secondaryColor3 = glSecondaryColor3us secondaryColor3v = glSecondaryColor3usv instance ColorComponent GLuint where color3 = glColor3ui color4 = glColor4ui color3v = glColor3uiv color4v = glColor4uiv secondaryColor3 = glSecondaryColor3ui secondaryColor3v = glSecondaryColor3uiv -------------------------------------------------------------------------------- -- | Change the current color. class Color a where color :: a -> IO () colorv :: Ptr a -> IO () instance ColorComponent a => Color (Color3 a) where color (Color3 r g b) = color3 r g b colorv = color3v . (castPtr :: Ptr (Color3 b) -> Ptr b) instance ColorComponent a => Color (Color4 a) where color (Color4 r g b a) = color4 r g b a colorv = color4v . (castPtr :: Ptr (Color4 b) -> Ptr b) -------------------------------------------------------------------------------- -- | Change the current secondary color. class SecondaryColor a where secondaryColor :: a -> IO () secondaryColorv :: Ptr a -> IO () instance ColorComponent a => SecondaryColor (Color3 a) where secondaryColor (Color3 r g b) = secondaryColor3 r g b secondaryColorv = secondaryColor3v . (castPtr :: Ptr (Color3 b) -> Ptr b) -------------------------------------------------------------------------------- -- The current color index. The initial value is 1. Note that this state -- variable is significant only when the GL is in color index mode. currentIndex :: StateVar (Index1 GLint) currentIndex = makeStateVar (getInteger1 Index1 GetCurrentIndex) index -------------------------------------------------------------------------------- -- | The class of all types which can be used as a color index. class IndexComponent a where index1 :: a -> IO () index1v :: Ptr a -> IO () instance IndexComponent GLshort where index1 = glIndexs index1v = glIndexsv instance IndexComponent GLint where index1 = glIndexi index1v = glIndexiv instance IndexComponent GLfloat where index1 = glIndexf index1v = glIndexfv instance IndexComponent GLdouble where index1 = glIndexd index1v = glIndexdv instance IndexComponent GLubyte where index1 = glIndexub index1v = glIndexubv -------------------------------------------------------------------------------- -- | Change the current color index. class Index a where index :: a -> IO () -- Collision with Prelude.index indexv :: Ptr a -> IO () instance IndexComponent a => Index (Index1 a) where index (Index1 i) = index1 i indexv = index1v . (castPtr :: Ptr (Index1 b) -> Ptr b) -------------------------------------------------------------------------------- data IntegerHandling = ToFloat | ToNormalizedFloat | KeepIntegral deriving ( Eq, Ord, Show ) -------------------------------------------------------------------------------- currentVertexAttrib :: AttribLocation -> StateVar (Vertex4 GLfloat) currentVertexAttrib location = makeStateVar (getVertexAttribFloat4 Vertex4 location GetCurrentVertexAttrib) (vertexAttrib ToFloat location) currentVertexAttribI :: AttribLocation -> StateVar (Vertex4 GLint) currentVertexAttribI location = makeStateVar (getVertexAttribIInteger4 Vertex4 location GetCurrentVertexAttrib) (vertexAttrib ToNormalizedFloat location) currentVertexAttribIu :: AttribLocation -> StateVar (Vertex4 GLuint) currentVertexAttribIu location = makeStateVar (getVertexAttribIuInteger4 Vertex4 location GetCurrentVertexAttrib) (vertexAttrib KeepIntegral location) -------------------------------------------------------------------------------- -- The generic vertex attribute API is not as orthogonal as we would like. -- Minimal methods: vertexAttrib4v and vertexAttrib4Nv and vertexAttrib4Iv -- | The class of all types which can be used as a generic vertex attribute. -- NOTE: Do not use the methods of this class directly, they were only exported -- by accident and will be hidden in future versions of this package. class (Storable a, Num a) => VertexAttribComponent a where vertexAttrib1 :: AttribLocation -> a -> IO () vertexAttrib2 :: AttribLocation -> a -> a -> IO () vertexAttrib3 :: AttribLocation -> a -> a -> a -> IO () vertexAttrib4 :: AttribLocation -> a -> a -> a -> a -> IO () vertexAttrib1N :: AttribLocation -> a -> IO () vertexAttrib2N :: AttribLocation -> a -> a -> IO () vertexAttrib3N :: AttribLocation -> a -> a -> a -> IO () vertexAttrib4N :: AttribLocation -> a -> a -> a -> a -> IO () vertexAttrib1I :: AttribLocation -> a -> IO () vertexAttrib2I :: AttribLocation -> a -> a -> IO () vertexAttrib3I :: AttribLocation -> a -> a -> a -> IO () vertexAttrib4I :: AttribLocation -> a -> a -> a -> a -> IO () vertexAttrib1v :: AttribLocation -> Ptr a -> IO () vertexAttrib2v :: AttribLocation -> Ptr a -> IO () vertexAttrib3v :: AttribLocation -> Ptr a -> IO () vertexAttrib4v :: AttribLocation -> Ptr a -> IO () vertexAttrib1Nv :: AttribLocation -> Ptr a -> IO () vertexAttrib2Nv :: AttribLocation -> Ptr a -> IO () vertexAttrib3Nv :: AttribLocation -> Ptr a -> IO () vertexAttrib4Nv :: AttribLocation -> Ptr a -> IO () vertexAttrib1Iv :: AttribLocation -> Ptr a -> IO () vertexAttrib2Iv :: AttribLocation -> Ptr a -> IO () vertexAttrib3Iv :: AttribLocation -> Ptr a -> IO () vertexAttrib4Iv :: AttribLocation -> Ptr a -> IO () vertexAttrib1 location x = vertexAttrib4 location x 0 0 1 vertexAttrib2 location x y = vertexAttrib4 location x y 0 1 vertexAttrib3 location x y z = vertexAttrib4 location x y z 1 vertexAttrib4 location x y z w = allocaArray 4 $ \buf -> do poke4 buf x y z w vertexAttrib4v location buf vertexAttrib1N location x = vertexAttrib4N location x 0 0 1 vertexAttrib2N location x y = vertexAttrib4N location x y 0 1 vertexAttrib3N location x y z = vertexAttrib4N location x y z 1 vertexAttrib4N location x y z w = allocaArray 4 $ \buf -> do poke4 buf x y z w vertexAttrib4Nv location buf vertexAttrib1I location x = vertexAttrib4I location x 0 0 1 vertexAttrib2I location x y = vertexAttrib4I location x y 0 1 vertexAttrib3I location x y z = vertexAttrib4I location x y z 1 vertexAttrib4I location x y z w = allocaArray 4 $ \buf -> do poke4 buf x y z w vertexAttrib4Iv location buf vertexAttrib1v location = peek1M $ vertexAttrib1 location vertexAttrib2v location = peek2M $ vertexAttrib2 location vertexAttrib3v location = peek3M $ vertexAttrib3 location vertexAttrib1Nv location = peek1M $ vertexAttrib1N location vertexAttrib2Nv location = peek2M $ vertexAttrib2N location vertexAttrib3Nv location = peek3M $ vertexAttrib3N location vertexAttrib1Iv location = peek1M $ vertexAttrib1I location vertexAttrib2Iv location = peek2M $ vertexAttrib2I location vertexAttrib3Iv location = peek3M $ vertexAttrib3I location instance VertexAttribComponent GLbyte where vertexAttrib4v (AttribLocation al) = glVertexAttrib4bv al vertexAttrib4Nv (AttribLocation al) = glVertexAttrib4Nbv al vertexAttrib4Iv (AttribLocation al) = glVertexAttribI4bv al instance VertexAttribComponent GLubyte where vertexAttrib4N (AttribLocation al) = glVertexAttrib4Nub al vertexAttrib4v (AttribLocation al) = glVertexAttrib4ubv al vertexAttrib4Nv (AttribLocation al) = glVertexAttrib4Nubv al vertexAttrib4Iv (AttribLocation al) = glVertexAttribI4ubv al instance VertexAttribComponent GLshort where vertexAttrib1 (AttribLocation al) = glVertexAttrib1s al vertexAttrib2 (AttribLocation al) = glVertexAttrib2s al vertexAttrib3 (AttribLocation al) = glVertexAttrib3s al vertexAttrib4 (AttribLocation al) = glVertexAttrib4s al vertexAttrib1v (AttribLocation al) = glVertexAttrib1sv al vertexAttrib2v (AttribLocation al) = glVertexAttrib2sv al vertexAttrib3v (AttribLocation al) = glVertexAttrib3sv al vertexAttrib4v (AttribLocation al) = glVertexAttrib4sv al vertexAttrib4Nv (AttribLocation al) = glVertexAttrib4Nsv al vertexAttrib4Iv (AttribLocation al) = glVertexAttribI4sv al instance VertexAttribComponent GLushort where vertexAttrib4v (AttribLocation al) = glVertexAttrib4usv al vertexAttrib4Nv (AttribLocation al) = glVertexAttrib4Nusv al vertexAttrib4Iv (AttribLocation al) = glVertexAttribI4usv al instance VertexAttribComponent GLint where vertexAttrib1I (AttribLocation al) = glVertexAttribI1i al vertexAttrib2I (AttribLocation al) = glVertexAttribI2i al vertexAttrib3I (AttribLocation al) = glVertexAttribI3i al vertexAttrib4I (AttribLocation al) = glVertexAttribI4i al vertexAttrib4v (AttribLocation al) = glVertexAttrib4iv al vertexAttrib4Nv (AttribLocation al) = glVertexAttrib4Niv al vertexAttrib1Iv (AttribLocation al) = glVertexAttribI1iv al vertexAttrib2Iv (AttribLocation al) = glVertexAttribI2iv al vertexAttrib3Iv (AttribLocation al) = glVertexAttribI3iv al vertexAttrib4Iv (AttribLocation al) = glVertexAttribI4iv al instance VertexAttribComponent GLuint where vertexAttrib1I (AttribLocation al) = glVertexAttribI1ui al vertexAttrib2I (AttribLocation al) = glVertexAttribI2ui al vertexAttrib3I (AttribLocation al) = glVertexAttribI3ui al vertexAttrib4I (AttribLocation al) = glVertexAttribI4ui al vertexAttrib4v (AttribLocation al) = glVertexAttrib4uiv al vertexAttrib4Nv (AttribLocation al) = glVertexAttrib4Nuiv al vertexAttrib1Iv (AttribLocation al) = glVertexAttribI1uiv al vertexAttrib2Iv (AttribLocation al) = glVertexAttribI2uiv al vertexAttrib3Iv (AttribLocation al) = glVertexAttribI3uiv al vertexAttrib4Iv (AttribLocation al) = glVertexAttribI4uiv al instance VertexAttribComponent GLfloat where vertexAttrib1 (AttribLocation al) = glVertexAttrib1f al vertexAttrib2 (AttribLocation al) = glVertexAttrib2f al vertexAttrib3 (AttribLocation al) = glVertexAttrib3f al vertexAttrib4 (AttribLocation al) = glVertexAttrib4f al vertexAttrib1v (AttribLocation al) = glVertexAttrib1fv al vertexAttrib2v (AttribLocation al) = glVertexAttrib2fv al vertexAttrib3v (AttribLocation al) = glVertexAttrib3fv al vertexAttrib4v (AttribLocation al) = glVertexAttrib4fv al vertexAttrib4Nv = vertexAttrib4v vertexAttrib4Iv = vertexAttrib4IvRealFrac vertexAttrib4IvRealFrac :: (Storable a, RealFrac a) => AttribLocation -> Ptr a -> IO () vertexAttrib4IvRealFrac location = peek4M $ \x y z w -> vertexAttrib4I location (toGLint x) (toGLint y) (toGLint z) (toGLint w) -- formula 2.6 from the OpenGL 3.1 spec toGLint :: RealFrac a => a -> GLint toGLint = truncate . (fromIntegral (maxBound :: GLint) *). clamp where clamp = max (-1.0) . min 1.0 instance VertexAttribComponent GLdouble where vertexAttrib1 (AttribLocation al) = glVertexAttrib1d al vertexAttrib2 (AttribLocation al) = glVertexAttrib2d al vertexAttrib3 (AttribLocation al) = glVertexAttrib3d al vertexAttrib4 (AttribLocation al) = glVertexAttrib4d al vertexAttrib1v (AttribLocation al) = glVertexAttrib1dv al vertexAttrib2v (AttribLocation al) = glVertexAttrib2dv al vertexAttrib3v (AttribLocation al) = glVertexAttrib3dv al vertexAttrib4v (AttribLocation al) = glVertexAttrib4dv al vertexAttrib4Nv = vertexAttrib4v vertexAttrib4Iv = vertexAttrib4IvRealFrac -------------------------------------------------------------------------------- class VertexAttrib a where vertexAttrib :: IntegerHandling -> AttribLocation -> a -> IO () vertexAttribv :: IntegerHandling -> AttribLocation -> Ptr a -> IO () instance VertexAttribComponent a => VertexAttrib (Vertex1 a) where vertexAttrib ToFloat location (Vertex1 i) = vertexAttrib1 location i vertexAttrib ToNormalizedFloat location (Vertex1 i) = vertexAttrib1N location i vertexAttrib KeepIntegral location (Vertex1 i) = vertexAttrib1I location i vertexAttribv ToFloat location = vertexAttrib1v location . (castPtr :: Ptr (Vertex1 b) -> Ptr b) vertexAttribv ToNormalizedFloat location = vertexAttrib1Nv location . (castPtr :: Ptr (Vertex1 b) -> Ptr b) vertexAttribv KeepIntegral location = vertexAttrib1Iv location . (castPtr :: Ptr (Vertex1 b) -> Ptr b) instance VertexAttribComponent a => VertexAttrib (Vertex2 a) where vertexAttrib ToFloat location (Vertex2 x y) = vertexAttrib2 location x y vertexAttrib ToNormalizedFloat location (Vertex2 x y) = vertexAttrib2N location x y vertexAttrib KeepIntegral location (Vertex2 x y) = vertexAttrib2I location x y vertexAttribv ToFloat location = vertexAttrib2v location . (castPtr :: Ptr (Vertex2 b) -> Ptr b) vertexAttribv ToNormalizedFloat location = vertexAttrib2Nv location . (castPtr :: Ptr (Vertex2 b) -> Ptr b) vertexAttribv KeepIntegral location = vertexAttrib2Iv location . (castPtr :: Ptr (Vertex2 b) -> Ptr b) instance VertexAttribComponent a => VertexAttrib (Vertex3 a) where vertexAttrib ToFloat location (Vertex3 x y z) = vertexAttrib3 location x y z vertexAttrib ToNormalizedFloat location (Vertex3 x y z) = vertexAttrib3N location x y z vertexAttrib KeepIntegral location (Vertex3 x y z) = vertexAttrib3I location x y z vertexAttribv ToFloat location = vertexAttrib3v location . (castPtr :: Ptr (Vertex3 b) -> Ptr b) vertexAttribv ToNormalizedFloat location = vertexAttrib3Nv location . (castPtr :: Ptr (Vertex3 b) -> Ptr b) vertexAttribv KeepIntegral location = vertexAttrib3Iv location . (castPtr :: Ptr (Vertex3 b) -> Ptr b) instance VertexAttribComponent a => VertexAttrib (Vertex4 a) where vertexAttrib ToFloat location (Vertex4 x y z w) = vertexAttrib4 location x y z w vertexAttrib ToNormalizedFloat location (Vertex4 x y z w) = vertexAttrib4N location x y z w vertexAttrib KeepIntegral location (Vertex4 x y z w) = vertexAttrib4I location x y z w vertexAttribv ToFloat location = vertexAttrib4v location . (castPtr :: Ptr (Vertex4 b) -> Ptr b) vertexAttribv ToNormalizedFloat location = vertexAttrib4Nv location . (castPtr :: Ptr (Vertex4 b) -> Ptr b) vertexAttribv KeepIntegral location = vertexAttrib4Iv location . (castPtr :: Ptr (Vertex4 b) -> Ptr b) instance VertexAttribComponent a => VertexAttrib (Vector1 a) where vertexAttrib ToFloat location (Vector1 i) = vertexAttrib1 location i vertexAttrib ToNormalizedFloat location (Vector1 i) = vertexAttrib1N location i vertexAttrib KeepIntegral location (Vector1 i) = vertexAttrib1I location i vertexAttribv ToFloat location = vertexAttrib1v location . (castPtr :: Ptr (Vector1 b) -> Ptr b) vertexAttribv ToNormalizedFloat location = vertexAttrib1Nv location . (castPtr :: Ptr (Vector1 b) -> Ptr b) vertexAttribv KeepIntegral location = vertexAttrib1Iv location . (castPtr :: Ptr (Vector1 b) -> Ptr b) instance VertexAttribComponent a => VertexAttrib (Vector2 a) where vertexAttrib ToFloat location (Vector2 x y) = vertexAttrib2 location x y vertexAttrib ToNormalizedFloat location (Vector2 x y) = vertexAttrib2N location x y vertexAttrib KeepIntegral location (Vector2 x y) = vertexAttrib2I location x y vertexAttribv ToFloat location = vertexAttrib2v location . (castPtr :: Ptr (Vector2 b) -> Ptr b) vertexAttribv ToNormalizedFloat location = vertexAttrib2Nv location . (castPtr :: Ptr (Vector2 b) -> Ptr b) vertexAttribv KeepIntegral location = vertexAttrib2Iv location . (castPtr :: Ptr (Vector2 b) -> Ptr b) instance VertexAttribComponent a => VertexAttrib (Vector3 a) where vertexAttrib ToFloat location (Vector3 x y z) = vertexAttrib3 location x y z vertexAttrib ToNormalizedFloat location (Vector3 x y z) = vertexAttrib3N location x y z vertexAttrib KeepIntegral location (Vector3 x y z) = vertexAttrib3I location x y z vertexAttribv ToFloat location = vertexAttrib3v location . (castPtr :: Ptr (Vector3 b) -> Ptr b) vertexAttribv ToNormalizedFloat location = vertexAttrib3Nv location . (castPtr :: Ptr (Vector3 b) -> Ptr b) vertexAttribv KeepIntegral location = vertexAttrib3Iv location . (castPtr :: Ptr (Vector3 b) -> Ptr b) instance VertexAttribComponent a => VertexAttrib (Vector4 a) where vertexAttrib ToFloat location (Vector4 x y z w) = vertexAttrib4 location x y z w vertexAttrib ToNormalizedFloat location (Vector4 x y z w) = vertexAttrib4N location x y z w vertexAttrib KeepIntegral location (Vector4 x y z w) = vertexAttrib4I location x y z w vertexAttribv ToFloat location = vertexAttrib4v location . (castPtr :: Ptr (Vector4 b) -> Ptr b) vertexAttribv ToNormalizedFloat location = vertexAttrib4Nv location . (castPtr :: Ptr (Vector4 b) -> Ptr b) vertexAttribv KeepIntegral location = vertexAttrib4Iv location . (castPtr :: Ptr (Vector4 b) -> Ptr b) instance VertexAttribComponent a => VertexAttrib (TexCoord1 a) where vertexAttrib ToFloat location (TexCoord1 s) = vertexAttrib1 location s vertexAttrib ToNormalizedFloat location (TexCoord1 s) = vertexAttrib1N location s vertexAttrib KeepIntegral location (TexCoord1 s) = vertexAttrib1I location s vertexAttribv ToFloat location = vertexAttrib1v location . (castPtr :: Ptr (TexCoord1 b) -> Ptr b) vertexAttribv ToNormalizedFloat location = vertexAttrib1Nv location . (castPtr :: Ptr (TexCoord1 b) -> Ptr b) vertexAttribv KeepIntegral location = vertexAttrib1Iv location . (castPtr :: Ptr (TexCoord1 b) -> Ptr b) instance VertexAttribComponent a => VertexAttrib (TexCoord2 a) where vertexAttrib ToFloat location (TexCoord2 s t) = vertexAttrib2 location s t vertexAttrib ToNormalizedFloat location (TexCoord2 s t) = vertexAttrib2N location s t vertexAttrib KeepIntegral location (TexCoord2 s t) = vertexAttrib2I location s t vertexAttribv ToFloat location = vertexAttrib2v location . (castPtr :: Ptr (TexCoord2 b) -> Ptr b) vertexAttribv ToNormalizedFloat location = vertexAttrib2Nv location . (castPtr :: Ptr (TexCoord2 b) -> Ptr b) vertexAttribv KeepIntegral location = vertexAttrib2Iv location . (castPtr :: Ptr (TexCoord2 b) -> Ptr b) instance VertexAttribComponent a => VertexAttrib (TexCoord3 a) where vertexAttrib ToFloat location (TexCoord3 s t u) = vertexAttrib3 location s t u vertexAttrib ToNormalizedFloat location (TexCoord3 s t u) = vertexAttrib3N location s t u vertexAttrib KeepIntegral location (TexCoord3 s t u) = vertexAttrib3I location s t u vertexAttribv ToFloat location = vertexAttrib3v location . (castPtr :: Ptr (TexCoord3 b) -> Ptr b) vertexAttribv ToNormalizedFloat location = vertexAttrib3Nv location . (castPtr :: Ptr (TexCoord3 b) -> Ptr b) vertexAttribv KeepIntegral location = vertexAttrib3Iv location . (castPtr :: Ptr (TexCoord3 b) -> Ptr b) instance VertexAttribComponent a => VertexAttrib (TexCoord4 a) where vertexAttrib ToFloat location (TexCoord4 s t u v) = vertexAttrib4 location s t u v vertexAttrib ToNormalizedFloat location (TexCoord4 s t u v) = vertexAttrib4N location s t u v vertexAttrib KeepIntegral location (TexCoord4 s t u v) = vertexAttrib4I location s t u v vertexAttribv ToFloat location = vertexAttrib4v location . (castPtr :: Ptr (TexCoord4 b) -> Ptr b) vertexAttribv ToNormalizedFloat location = vertexAttrib4Nv location . (castPtr :: Ptr (TexCoord4 b) -> Ptr b) vertexAttribv KeepIntegral location = vertexAttrib4Iv location . (castPtr :: Ptr (TexCoord4 b) -> Ptr b) instance VertexAttribComponent a => VertexAttrib (Normal3 a) where vertexAttrib ToFloat location (Normal3 x y z) = vertexAttrib3 location x y z vertexAttrib ToNormalizedFloat location (Normal3 x y z) = vertexAttrib3N location x y z vertexAttrib KeepIntegral location (Normal3 x y z) = vertexAttrib3I location x y z vertexAttribv ToFloat location = vertexAttrib3v location . (castPtr :: Ptr (Normal3 b) -> Ptr b) vertexAttribv ToNormalizedFloat location = vertexAttrib3Nv location . (castPtr :: Ptr (Normal3 b) -> Ptr b) vertexAttribv KeepIntegral location = vertexAttrib3Iv location . (castPtr :: Ptr (Normal3 b) -> Ptr b) instance VertexAttribComponent a => VertexAttrib (FogCoord1 a) where vertexAttrib ToFloat location (FogCoord1 c) = vertexAttrib1 location c vertexAttrib ToNormalizedFloat location (FogCoord1 c) = vertexAttrib1N location c vertexAttrib KeepIntegral location (FogCoord1 c) = vertexAttrib1I location c vertexAttribv ToFloat location = vertexAttrib1v location . (castPtr :: Ptr (FogCoord1 b) -> Ptr b) vertexAttribv ToNormalizedFloat location = vertexAttrib1Nv location . (castPtr :: Ptr (FogCoord1 b) -> Ptr b) vertexAttribv KeepIntegral location = vertexAttrib1Iv location . (castPtr :: Ptr (FogCoord1 b) -> Ptr b) instance VertexAttribComponent a => VertexAttrib (Color3 a) where vertexAttrib ToFloat location (Color3 r g b) = vertexAttrib3 location r g b vertexAttrib ToNormalizedFloat location (Color3 r g b) = vertexAttrib3N location r g b vertexAttrib KeepIntegral location (Color3 r g b) = vertexAttrib3I location r g b vertexAttribv ToFloat location = vertexAttrib3v location . (castPtr :: Ptr (Color3 b) -> Ptr b) vertexAttribv ToNormalizedFloat location = vertexAttrib3Nv location . (castPtr :: Ptr (Color3 b) -> Ptr b) vertexAttribv KeepIntegral location = vertexAttrib3Iv location . (castPtr :: Ptr (Color3 b) -> Ptr b) instance VertexAttribComponent a => VertexAttrib (Color4 a) where vertexAttrib ToFloat location (Color4 r g b a) = vertexAttrib4 location r g b a vertexAttrib ToNormalizedFloat location (Color4 r g b a) = vertexAttrib4N location r g b a vertexAttrib KeepIntegral location (Color4 r g b a) = vertexAttrib4I location r g b a vertexAttribv ToFloat location = vertexAttrib4v location . (castPtr :: Ptr (Color4 b) -> Ptr b) vertexAttribv ToNormalizedFloat location = vertexAttrib4Nv location . (castPtr :: Ptr (Color4 b) -> Ptr b) vertexAttribv KeepIntegral location = vertexAttrib4Iv location . (castPtr :: Ptr (Color4 b) -> Ptr b) instance VertexAttribComponent a => VertexAttrib (Index1 a) where vertexAttrib ToFloat location (Index1 i) = vertexAttrib1 location i vertexAttrib ToNormalizedFloat location (Index1 i) = vertexAttrib1N location i vertexAttrib KeepIntegral location (Index1 i) = vertexAttrib1I location i vertexAttribv ToFloat location = vertexAttrib1v location . (castPtr :: Ptr (Index1 b) -> Ptr b) vertexAttribv ToNormalizedFloat location = vertexAttrib1Nv location . (castPtr :: Ptr (Index1 b) -> Ptr b) vertexAttribv KeepIntegral location = vertexAttrib1Iv location . (castPtr :: Ptr (Index1 b) -> Ptr b) -------------------------------------------------------------------------------- -- | An implementation must support at least 2 texture units, but it may -- support up to 32 ones. This state variable can be used to query the actual -- implementation limit. maxTextureUnit :: GettableStateVar TextureUnit maxTextureUnit = makeGettableStateVar (getEnum1 (TextureUnit . fromIntegral) GetMaxTextureUnits) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PixelFormat.hs0000644000000000000000000000674512521420345021737 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PixelFormat -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for (un-)marshaling PixelFormat. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PixelFormat ( PixelFormat(..), marshalPixelFormat, unmarshalPixelFormat ) where import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data PixelFormat = ColorIndex | StencilIndex | DepthComponent | DepthStencil | Red | Green | Blue | Alpha | RG | RGB | RGBA | Luminance | LuminanceAlpha | RedInteger | GreenInteger | BlueInteger | AlphaInteger | RGInteger | RGBInteger | RGBAInteger | BGRInteger | BGRAInteger | ABGR | BGR | BGRA | CMYK | CMYKA | FourTwoTwo | FourTwoTwoRev | FourTwoTwoAverage | FourTwoTwoRevAverage | YCBCR422 deriving ( Eq, Ord, Show ) marshalPixelFormat :: PixelFormat -> GLenum marshalPixelFormat x = case x of ColorIndex -> gl_COLOR_INDEX StencilIndex -> gl_STENCIL_INDEX DepthComponent -> gl_DEPTH_COMPONENT Red -> gl_RED Green -> gl_GREEN Blue -> gl_BLUE Alpha -> gl_ALPHA RG -> gl_RG RGB -> gl_RGB RGBA -> gl_RGBA Luminance -> gl_LUMINANCE LuminanceAlpha -> gl_LUMINANCE_ALPHA RedInteger -> gl_RED_INTEGER GreenInteger -> gl_GREEN_INTEGER BlueInteger -> gl_BLUE_INTEGER AlphaInteger -> gl_ALPHA_INTEGER RGInteger -> gl_RG_INTEGER RGBInteger -> gl_RGB_INTEGER RGBAInteger -> gl_RGBA_INTEGER BGRInteger -> gl_BGR_INTEGER BGRAInteger -> gl_BGRA_INTEGER ABGR -> gl_ABGR_EXT BGR -> gl_BGR BGRA -> gl_BGRA CMYK -> gl_CMYK_EXT CMYKA -> gl_CMYKA_EXT FourTwoTwo -> gl_422_EXT FourTwoTwoRev -> gl_422_REV_EXT FourTwoTwoAverage -> gl_422_AVERAGE_EXT FourTwoTwoRevAverage -> gl_422_REV_AVERAGE_EXT YCBCR422 -> gl_YCBCR_422_APPLE DepthStencil -> gl_DEPTH_STENCIL unmarshalPixelFormat :: GLenum -> PixelFormat unmarshalPixelFormat x | x == gl_COLOR_INDEX = ColorIndex | x == gl_STENCIL_INDEX = StencilIndex | x == gl_DEPTH_COMPONENT = DepthComponent | x == gl_RED = Red | x == gl_GREEN = Green | x == gl_BLUE = Blue | x == gl_ALPHA = Alpha | x == gl_RG = RG | x == gl_RGB = RGB | x == gl_RGBA = RGBA | x == gl_LUMINANCE = Luminance | x == gl_LUMINANCE_ALPHA = LuminanceAlpha | x == gl_RED_INTEGER = RedInteger | x == gl_GREEN_INTEGER = GreenInteger | x == gl_BLUE_INTEGER = BlueInteger | x == gl_ALPHA_INTEGER = AlphaInteger | x == gl_RG_INTEGER = RGInteger | x == gl_RGB_INTEGER = RGBInteger | x == gl_RGBA_INTEGER = RGBAInteger | x == gl_BGR_INTEGER = BGRInteger | x == gl_BGRA_INTEGER = BGRAInteger | x == gl_ABGR_EXT = ABGR | x == gl_BGR = BGR | x == gl_BGRA = BGRA | x == gl_CMYK_EXT = CMYK | x == gl_CMYKA_EXT = CMYKA | x == gl_422_EXT = FourTwoTwo | x == gl_422_REV_EXT = FourTwoTwoRev | x == gl_422_AVERAGE_EXT = FourTwoTwoAverage | x == gl_422_REV_AVERAGE_EXT = FourTwoTwoRevAverage | x == gl_YCBCR_422_APPLE = YCBCR422 | x == gl_DEPTH_STENCIL = DepthStencil | otherwise = error ("unmarshalPixelFormat: illegal value " ++ show x) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PeekPoke.hs0000644000000000000000000000561512521420345021203 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PeekPoke -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module with peek- and poke-related utilities. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PeekPoke ( poke1, poke2, poke3, poke4, peek1, peek2, peek3, peek4, peek1M, peek2M, peek3M, peek4M ) where import Foreign.Ptr import Foreign.Storable -------------------------------------------------------------------------------- -- The implementation is little bit verbose/redundant, but seems to generate -- better code than mapM/zipWithM_. -------------------------------------------------------------------------------- {-# INLINE poke1 #-} poke1 :: Storable a => Ptr a -> a -> IO () poke1 ptr x = pokeElemOff ptr 0 x {-# INLINE poke2 #-} poke2 :: Storable a => Ptr a -> a -> a -> IO () poke2 ptr x y = do pokeElemOff ptr 0 x pokeElemOff ptr 1 y {-# INLINE poke3 #-} poke3 :: Storable a => Ptr a -> a -> a -> a -> IO () poke3 ptr x y z = do pokeElemOff ptr 0 x pokeElemOff ptr 1 y pokeElemOff ptr 2 z {-# INLINE poke4 #-} poke4 :: Storable a => Ptr a -> a -> a -> a -> a -> IO () poke4 ptr x y z w = do pokeElemOff ptr 0 x pokeElemOff ptr 1 y pokeElemOff ptr 2 z pokeElemOff ptr 3 w -------------------------------------------------------------------------------- {-# INLINE peek1 #-} peek1 :: Storable a => (a -> b) -> Ptr a -> IO b peek1 f ptr = do x <- peekElemOff ptr 0 return $ f x {-# INLINE peek2 #-} peek2 :: Storable a => (a -> a -> b) -> Ptr a -> IO b peek2 f = peek2M $ \x y -> return (f x y) {-# INLINE peek3 #-} peek3 :: Storable a => (a -> a -> a -> b) -> Ptr a -> IO b peek3 f = peek3M $ \x y z -> return (f x y z) {-# INLINE peek4 #-} peek4 :: Storable a => (a -> a -> a -> a -> b) -> Ptr a -> IO b peek4 f = peek4M $ \x y z w -> return (f x y z w) -------------------------------------------------------------------------------- {-# INLINE peek1M #-} peek1M :: Storable a => (a -> IO b) -> Ptr a -> IO b peek1M f ptr = do x <- peekElemOff ptr 0 f x {-# INLINE peek2M #-} peek2M :: Storable a => (a -> a -> IO b) -> Ptr a -> IO b peek2M f ptr = do x <- peekElemOff ptr 0 y <- peekElemOff ptr 1 f x y {-# INLINE peek3M #-} peek3M :: Storable a => (a -> a -> a -> IO b) -> Ptr a -> IO b peek3M f ptr = do x <- peekElemOff ptr 0 y <- peekElemOff ptr 1 z <- peekElemOff ptr 2 f x y z {-# INLINE peek4M #-} peek4M :: Storable a => (a -> a -> a -> a -> IO b) -> Ptr a -> IO b peek4M f ptr = do x <- peekElemOff ptr 0 y <- peekElemOff ptr 1 z <- peekElemOff ptr 2 w <- peekElemOff ptr 3 f x y z w OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PixelData.hs0000644000000000000000000000207112521420345021344 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PixelData -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal helper module. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PixelData ( PixelData(..), withPixelData ) where import Foreign.Ptr import Graphics.Rendering.OpenGL.GL.DataType import Graphics.Rendering.OpenGL.GL.PixelFormat import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data PixelData a = PixelData PixelFormat DataType (Ptr a) deriving ( Eq, Ord, Show ) withPixelData :: PixelData a -> (GLenum -> GLenum -> Ptr a -> b) -> b withPixelData (PixelData pixelFormat dataType ptr) f = f (marshalPixelFormat pixelFormat) (marshalDataType dataType) ptr OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Antialiasing.hs0000644000000000000000000000242212521420345022074 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Antialiasing -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 3.2 (Antialiasing) of the OpenGL 2.1 -- specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Antialiasing ( sampleBuffers, samples, multisample, subpixelBits ) where import Data.StateVar import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- sampleBuffers :: GettableStateVar GLsizei sampleBuffers = antialiasingInfo GetSampleBuffers samples :: GettableStateVar GLsizei samples = antialiasingInfo GetSamples multisample :: StateVar Capability multisample = makeCapability CapMultisample subpixelBits :: GettableStateVar GLsizei subpixelBits = antialiasingInfo GetSubpixelBits antialiasingInfo :: GetPName1I p => p -> GettableStateVar GLsizei antialiasingInfo = makeGettableStateVar . getSizei1 id OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/FramebufferObjects.hs0000644000000000000000000000174712521420345023240 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Copyright : (c) Sven Panne 2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- Framebuffer objects. -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.FramebufferObjects ( module Graphics.Rendering.OpenGL.GL.FramebufferObjects.Attachments, module Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjects, module Graphics.Rendering.OpenGL.GL.FramebufferObjects.Queries, module Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObjects ) where import Graphics.Rendering.OpenGL.GL.FramebufferObjects.Attachments import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjects import Graphics.Rendering.OpenGL.GL.FramebufferObjects.Queries import Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObjects OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PixellikeObject.hs0000644000000000000000000000631712521420345022555 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PixellikeObject -- Copyright : (c) Sven Panne, Lars Corbijn 2011-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PixellikeObject ( PixellikeObjectGetPName(..), PixellikeObjectTarget(pixellikeObjTarParam), ) where import Data.StateVar import Foreign.Marshal.Utils import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjectAttachment import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferTarget import Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferTarget import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.Texturing.Specification import Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget import Graphics.Rendering.OpenGL.Raw ----------------------------------------------------------------------------- data PixellikeObjectGetPName = RedSize | BlueSize | GreenSize | AlphaSize | DepthSize | StencilSize class PixellikeObjectTarget t where --dummy t to include it in the type class marshalPixellikeOT :: t -> PixellikeObjectGetPName -> GLenum pixObjTarQueryFunc :: t -> GLenum -> IO GLint pixellikeObjTarParam :: t -> PixellikeObjectGetPName -> GettableStateVar GLint pixellikeObjTarParam t p = makeGettableStateVar (pixObjTarQueryFunc t $ marshalPixellikeOT t p) instance PixellikeObjectTarget RenderbufferTarget where marshalPixellikeOT _ x = case x of RedSize -> gl_RENDERBUFFER_RED_SIZE BlueSize -> gl_RENDERBUFFER_BLUE_SIZE GreenSize -> gl_RENDERBUFFER_GREEN_SIZE AlphaSize -> gl_RENDERBUFFER_ALPHA_SIZE DepthSize -> gl_RENDERBUFFER_DEPTH_SIZE StencilSize -> gl_RENDERBUFFER_STENCIL_SIZE pixObjTarQueryFunc t = getRBParameteriv t id data FramebufferTargetAttachment = FramebufferTargetAttachment FramebufferTarget FramebufferObjectAttachment instance PixellikeObjectTarget FramebufferTargetAttachment where marshalPixellikeOT _ x = case x of RedSize -> gl_FRAMEBUFFER_ATTACHMENT_RED_SIZE BlueSize -> gl_FRAMEBUFFER_ATTACHMENT_BLUE_SIZE GreenSize -> gl_FRAMEBUFFER_ATTACHMENT_GREEN_SIZE AlphaSize -> gl_FRAMEBUFFER_ATTACHMENT_ALPHA_SIZE DepthSize -> gl_FRAMEBUFFER_ATTACHMENT_DEPTH_SIZE StencilSize -> gl_FRAMEBUFFER_ATTACHMENT_STENCIL_SIZE pixObjTarQueryFunc (FramebufferTargetAttachment fbt fba) = getFBAParameteriv fbt fba id data TextureTargetFull t = TextureTargetFull t Level instance QueryableTextureTarget t => PixellikeObjectTarget (TextureTargetFull t) where marshalPixellikeOT _ x = case x of RedSize -> gl_TEXTURE_RED_SIZE BlueSize -> gl_TEXTURE_BLUE_SIZE GreenSize -> gl_TEXTURE_GREEN_SIZE AlphaSize -> gl_TEXTURE_ALPHA_SIZE DepthSize -> gl_TEXTURE_DEPTH_SIZE StencilSize -> gl_TEXTURE_STENCIL_SIZE pixObjTarQueryFunc (TextureTargetFull t level) p = with 0 $ \buf -> do glGetTexLevelParameteriv (marshalQueryableTextureTarget t) level p buf peek1 id buf OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/VertexAttributes.hs0000644000000000000000000002723212521420345023023 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.VertexAttributes -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for auxiliary vertex attributes. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.VertexAttributes ( TexCoord1(..), TexCoord2(..), TexCoord3(..), TexCoord4(..), Normal3(..), FogCoord1(..), Color3(..), Color4(..), Index1(..) ) where import Control.Applicative import Control.Monad import Data.Foldable import Data.Ix import Data.Traversable import Data.Typeable import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable -------------------------------------------------------------------------------- -- | Texture coordinates with /t/=0, /r/=0, and /q/=1. newtype TexCoord1 a = TexCoord1 a deriving (Eq, Ord, Ix, Bounded, Show, Read, Typeable) instance Functor TexCoord1 where fmap f (TexCoord1 x) = TexCoord1 (f x) instance Applicative TexCoord1 where pure a = TexCoord1 a TexCoord1 f <*> TexCoord1 x = TexCoord1 (f x) instance Foldable TexCoord1 where foldr f a (TexCoord1 x) = x `f ` a foldl f a (TexCoord1 x) = a `f` x foldr1 _ (TexCoord1 x) = x foldl1 _ (TexCoord1 x) = x instance Traversable TexCoord1 where traverse f (TexCoord1 x) = pure TexCoord1 <*> f x sequenceA (TexCoord1 x) = pure TexCoord1 <*> x mapM f (TexCoord1 x) = return TexCoord1 `ap` f x sequence (TexCoord1 x) = return TexCoord1 `ap` x instance Storable a => Storable (TexCoord1 a) where sizeOf ~(TexCoord1 s) = sizeOf s alignment ~(TexCoord1 s) = alignment s peek = peekApplicativeTraversable poke = pokeFoldable -------------------------------------------------------------------------------- -- | Texture coordinates with /r/=0 and /q/=1. data TexCoord2 a = TexCoord2 !a !a deriving (Eq, Ord, Ix, Bounded, Show, Read, Typeable) instance Functor TexCoord2 where fmap f (TexCoord2 x y) = TexCoord2 (f x) (f y) instance Applicative TexCoord2 where pure a = TexCoord2 a a TexCoord2 f g <*> TexCoord2 x y = TexCoord2 (f x) (g y) instance Foldable TexCoord2 where foldr f a (TexCoord2 x y) = x `f ` (y `f` a) foldl f a (TexCoord2 x y) = (a `f` x) `f` y foldr1 f (TexCoord2 x y) = x `f` y foldl1 f (TexCoord2 x y) = x `f` y instance Traversable TexCoord2 where traverse f (TexCoord2 x y) = pure TexCoord2 <*> f x <*> f y sequenceA (TexCoord2 x y) = pure TexCoord2 <*> x <*> y mapM f (TexCoord2 x y) = return TexCoord2 `ap` f x `ap` f y sequence (TexCoord2 x y) = return TexCoord2 `ap` x `ap` y instance Storable a => Storable (TexCoord2 a) where sizeOf ~(TexCoord2 x _) = 2 * sizeOf x alignment ~(TexCoord2 x _) = alignment x peek = peekApplicativeTraversable poke = pokeFoldable -------------------------------------------------------------------------------- -- | Texture coordinates with /q/=1. data TexCoord3 a = TexCoord3 !a !a !a deriving (Eq, Ord, Ix, Bounded, Show, Read, Typeable) instance Functor TexCoord3 where fmap f (TexCoord3 x y z) = TexCoord3 (f x) (f y) (f z) instance Applicative TexCoord3 where pure a = TexCoord3 a a a TexCoord3 f g h <*> TexCoord3 x y z = TexCoord3 (f x) (g y) (h z) instance Foldable TexCoord3 where foldr f a (TexCoord3 x y z) = x `f ` (y `f` (z `f` a)) foldl f a (TexCoord3 x y z) = ((a `f` x) `f` y) `f` z foldr1 f (TexCoord3 x y z) = x `f` (y `f` z) foldl1 f (TexCoord3 x y z) = (x `f` y) `f` z instance Traversable TexCoord3 where traverse f (TexCoord3 x y z) = pure TexCoord3 <*> f x <*> f y <*> f z sequenceA (TexCoord3 x y z) = pure TexCoord3 <*> x <*> y <*> z mapM f (TexCoord3 x y z) = return TexCoord3 `ap` f x `ap` f y `ap` f z sequence (TexCoord3 x y z) = return TexCoord3 `ap` x `ap` y `ap` z instance Storable a => Storable (TexCoord3 a) where sizeOf ~(TexCoord3 x _ _) = 3 * sizeOf x alignment ~(TexCoord3 x _ _) = alignment x peek = peekApplicativeTraversable poke = pokeFoldable -------------------------------------------------------------------------------- -- | Fully-fledged four-dimensional texture coordinates. data TexCoord4 a = TexCoord4 !a !a !a !a deriving (Eq, Ord, Ix, Bounded, Show, Read, Typeable) instance Functor TexCoord4 where fmap f (TexCoord4 x y z w) = TexCoord4 (f x) (f y) (f z) (f w) instance Applicative TexCoord4 where pure a = TexCoord4 a a a a TexCoord4 f g h i <*> TexCoord4 x y z w = TexCoord4 (f x) (g y) (h z) (i w) instance Foldable TexCoord4 where foldr f a (TexCoord4 x y z w) = x `f ` (y `f` (z `f` (w `f` a))) foldl f a (TexCoord4 x y z w) = (((a `f` x) `f` y) `f` z) `f` w foldr1 f (TexCoord4 x y z w) = x `f` (y `f` (z `f` w)) foldl1 f (TexCoord4 x y z w) = ((x `f` y) `f` z) `f` w instance Traversable TexCoord4 where traverse f (TexCoord4 x y z w) = pure TexCoord4 <*> f x <*> f y <*> f z <*> f w sequenceA (TexCoord4 x y z w) = pure TexCoord4 <*> x <*> y <*> z <*> w mapM f (TexCoord4 x y z w) = return TexCoord4 `ap` f x `ap` f y `ap` f z `ap` f w sequence (TexCoord4 x y z w) = return TexCoord4 `ap` x `ap` y `ap` z `ap` w instance Storable a => Storable (TexCoord4 a) where sizeOf ~(TexCoord4 x _ _ _) = 4 * sizeOf x alignment ~(TexCoord4 x _ _ _) = alignment x peek = peekApplicativeTraversable poke = pokeFoldable -------------------------------------------------------------------------------- -- A three-dimensional normal. data Normal3 a = Normal3 !a !a !a deriving (Eq, Ord, Ix, Bounded, Show, Read, Typeable) instance Functor Normal3 where fmap f (Normal3 x y z) = Normal3 (f x) (f y) (f z) instance Applicative Normal3 where pure a = Normal3 a a a Normal3 f g h <*> Normal3 x y z = Normal3 (f x) (g y) (h z) instance Foldable Normal3 where foldr f a (Normal3 x y z) = x `f ` (y `f` (z `f` a)) foldl f a (Normal3 x y z) = ((a `f` x) `f` y) `f` z foldr1 f (Normal3 x y z) = x `f` (y `f` z) foldl1 f (Normal3 x y z) = (x `f` y) `f` z instance Traversable Normal3 where traverse f (Normal3 x y z) = pure Normal3 <*> f x <*> f y <*> f z sequenceA (Normal3 x y z) = pure Normal3 <*> x <*> y <*> z mapM f (Normal3 x y z) = return Normal3 `ap` f x `ap` f y `ap` f z sequence (Normal3 x y z) = return Normal3 `ap` x `ap` y `ap` z instance Storable a => Storable (Normal3 a) where sizeOf ~(Normal3 x _ _) = 3 * sizeOf x alignment ~(Normal3 x _ _) = alignment x peek = peekApplicativeTraversable poke = pokeFoldable -------------------------------------------------------------------------------- -- | A fog coordinate. newtype FogCoord1 a = FogCoord1 a deriving (Eq, Ord, Ix, Bounded, Show, Read, Typeable) instance Functor FogCoord1 where fmap f (FogCoord1 x) = FogCoord1 (f x) instance Applicative FogCoord1 where pure a = FogCoord1 a FogCoord1 f <*> FogCoord1 x = FogCoord1 (f x) instance Foldable FogCoord1 where foldr f a (FogCoord1 x) = x `f ` a foldl f a (FogCoord1 x) = a `f` x foldr1 _ (FogCoord1 x) = x foldl1 _ (FogCoord1 x) = x instance Traversable FogCoord1 where traverse f (FogCoord1 x) = pure FogCoord1 <*> f x sequenceA (FogCoord1 x) = pure FogCoord1 <*> x mapM f (FogCoord1 x) = return FogCoord1 `ap` f x sequence (FogCoord1 x) = return FogCoord1 `ap` x instance Storable a => Storable (FogCoord1 a) where sizeOf ~(FogCoord1 s) = sizeOf s alignment ~(FogCoord1 s) = alignment s peek = peekApplicativeTraversable poke = pokeFoldable -------------------------------------------------------------------------------- -- An RGBA color with /A/=1. data Color3 a = Color3 !a !a !a deriving (Eq, Ord, Ix, Bounded, Show, Read, Typeable) instance Functor Color3 where fmap f (Color3 x y z) = Color3 (f x) (f y) (f z) instance Applicative Color3 where pure a = Color3 a a a Color3 f g h <*> Color3 x y z = Color3 (f x) (g y) (h z) instance Foldable Color3 where foldr f a (Color3 x y z) = x `f ` (y `f` (z `f` a)) foldl f a (Color3 x y z) = ((a `f` x) `f` y) `f` z foldr1 f (Color3 x y z) = x `f` (y `f` z) foldl1 f (Color3 x y z) = (x `f` y) `f` z instance Traversable Color3 where traverse f (Color3 x y z) = pure Color3 <*> f x <*> f y <*> f z sequenceA (Color3 x y z) = pure Color3 <*> x <*> y <*> z mapM f (Color3 x y z) = return Color3 `ap` f x `ap` f y `ap` f z sequence (Color3 x y z) = return Color3 `ap` x `ap` y `ap` z instance Storable a => Storable (Color3 a) where sizeOf ~(Color3 x _ _) = 3 * sizeOf x alignment ~(Color3 x _ _) = alignment x peek = peekApplicativeTraversable poke = pokeFoldable -------------------------------------------------------------------------------- -- | A fully-fledged RGBA color. data Color4 a = Color4 !a !a !a !a deriving (Eq, Ord, Ix, Bounded, Show, Read, Typeable) instance Functor Color4 where fmap f (Color4 x y z w) = Color4 (f x) (f y) (f z) (f w) instance Applicative Color4 where pure a = Color4 a a a a Color4 f g h i <*> Color4 x y z w = Color4 (f x) (g y) (h z) (i w) instance Foldable Color4 where foldr f a (Color4 x y z w) = x `f ` (y `f` (z `f` (w `f` a))) foldl f a (Color4 x y z w) = (((a `f` x) `f` y) `f` z) `f` w foldr1 f (Color4 x y z w) = x `f` (y `f` (z `f` w)) foldl1 f (Color4 x y z w) = ((x `f` y) `f` z) `f` w instance Traversable Color4 where traverse f (Color4 x y z w) = pure Color4 <*> f x <*> f y <*> f z <*> f w sequenceA (Color4 x y z w) = pure Color4 <*> x <*> y <*> z <*> w mapM f (Color4 x y z w) = return Color4 `ap` f x `ap` f y `ap` f z `ap` f w sequence (Color4 x y z w) = return Color4 `ap` x `ap` y `ap` z `ap` w instance Storable a => Storable (Color4 a) where sizeOf ~(Color4 x _ _ _) = 4 * sizeOf x alignment ~(Color4 x _ _ _) = alignment x peek = peekApplicativeTraversable poke = pokeFoldable -------------------------------------------------------------------------------- -- | A color index. newtype Index1 a = Index1 a deriving (Eq, Ord, Ix, Bounded, Show, Read, Typeable) instance Functor Index1 where fmap f (Index1 x) = Index1 (f x) instance Applicative Index1 where pure a = Index1 a Index1 f <*> Index1 x = Index1 (f x) instance Foldable Index1 where foldr f a (Index1 x) = x `f ` a foldl f a (Index1 x) = a `f` x foldr1 _ (Index1 x) = x foldl1 _ (Index1 x) = x instance Traversable Index1 where traverse f (Index1 x) = pure Index1 <*> f x sequenceA (Index1 x) = pure Index1 <*> x mapM f (Index1 x) = return Index1 `ap` f x sequence (Index1 x) = return Index1 `ap` x instance Storable a => Storable (Index1 a) where sizeOf ~(Index1 s) = sizeOf s alignment ~(Index1 s) = alignment s peek = peekApplicativeTraversable poke = pokeFoldable -------------------------------------------------------------------------------- peekApplicativeTraversable :: (Applicative t, Traversable t, Storable a) => Ptr (t a) -> IO (t a) peekApplicativeTraversable = Data.Traversable.mapM peek . addresses addresses :: (Applicative t, Traversable t, Storable a) => Ptr (t a) -> t (Ptr a) addresses = snd . mapAccumL nextPtr 0 . pure . castPtr nextPtr :: Storable a => Int -> Ptr a -> (Int, Ptr a) nextPtr offset ptr = (offset + 1, advancePtr ptr offset) -------------------------------------------------------------------------------- pokeFoldable :: (Foldable t, Storable a) => Ptr (t a) -> t a -> IO () pokeFoldable ptr xs = foldlM pokeAndAdvance (castPtr ptr) xs >> return () pokeAndAdvance :: Storable a => Ptr a -> a -> IO (Ptr a) pokeAndAdvance ptr value = do poke ptr value return $ ptr `plusPtr` sizeOf value OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/FlushFinish.hs0000644000000000000000000000362212521420345021716 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.FlushFinish -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 2.3.2 (Flush and Finish) of the OpenGL 4.4 -- specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.FlushFinish ( flush, finish ) where import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- | Different GL implementations buffer commands in several different -- locations, including network buffers and the graphics accelerator itself. -- 'flush' empties all of these buffers, causing all issued commands to be -- executed as quickly as they are accepted by the actual rendering engine. -- Though this execution may not be completed in any particular time period, it -- does complete in finite time. -- -- Because any GL program might be executed over a network, or on an accelerator -- that buffers commands, all programs should call 'flush' whenever they count -- on having all of their previously issued commands completed. For example, -- call 'flush' before waiting for user input that depends on the generated -- image. -- -- Note that 'flush' can return at any time. It does not wait until the -- execution of all previously issued GL commands is complete. flush :: IO () flush = glFlush -- | 'finish' does not return until the effects of all previously called GL -- commands are complete. Such effects include all changes to GL state, all -- changes to connection state, and all changes to the frame buffer contents. -- -- Note that 'finish' requires a round trip to the server. finish :: IO () finish = glFinish OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/TransformFeedback.hs0000644000000000000000000001156312521420345023057 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.TransformFeedback -- Copyright : (c) Sven Panne, Lars Corbijn 2011-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.TransformFeedback ( -- * starting and ending beginTransformFeedback, endTransformFeedback, -- * TransformFeedbackBufferMode TransformFeedbackBufferMode(..), marshalTransformFeedbackBufferMode, unmarshalTransformFeedbackBufferMode, -- * Shader related transformFeedbackBufferMode, transformFeedbackVaryings, setTransformFeedbackVaryings, -- * limits maxTransformFeedbackSeparateAttribs, maxTransformFeedbackInterleavedComponents, maxTransformFeedbackSeparateComponents ) where import Data.StateVar import Foreign.Marshal.Array import Graphics.Rendering.OpenGL.GL.ByteString import Graphics.Rendering.OpenGL.GL.DataType import Graphics.Rendering.OpenGL.GL.PrimitiveMode import Graphics.Rendering.OpenGL.GL.PrimitiveModeInternal import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.Shaders.Program import Graphics.Rendering.OpenGL.GL.Shaders.Variables import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- beginTransformFeedback :: PrimitiveMode -> IO () beginTransformFeedback = glBeginTransformFeedback . marshalPrimitiveMode endTransformFeedback :: IO () endTransformFeedback = glEndTransformFeedback -------------------------------------------------------------------------------- data TransformFeedbackBufferMode = InterleavedAttribs | SeperateAttribs deriving ( Eq, Ord, Show ) marshalTransformFeedbackBufferMode :: TransformFeedbackBufferMode -> GLenum marshalTransformFeedbackBufferMode x = case x of InterleavedAttribs -> gl_INTERLEAVED_ATTRIBS SeperateAttribs -> gl_SEPARATE_ATTRIBS unmarshalTransformFeedbackBufferMode :: GLenum -> TransformFeedbackBufferMode unmarshalTransformFeedbackBufferMode x | x == gl_INTERLEAVED_ATTRIBS = InterleavedAttribs | x == gl_SEPARATE_ATTRIBS = SeperateAttribs | otherwise = error $ "unmarshalTransformFeedbackBufferMode: illegal value " ++ show x -- limits -- | Max number of seprate atributes or varyings than can be captured -- in transformfeedback, initial value 4 maxTransformFeedbackSeparateAttribs :: GettableStateVar GLint maxTransformFeedbackSeparateAttribs = makeGettableStateVar $ getInteger1 fromIntegral GetMaxTransformFeedbackSeparateAttribs -- | Max number of components to write to a single buffer in -- interleaved mod, initial value 64 maxTransformFeedbackInterleavedComponents :: GettableStateVar GLint maxTransformFeedbackInterleavedComponents = makeGettableStateVar $ getInteger1 fromIntegral GetMaxTransformFeedbackInterleavedComponents -- | Max number of components per attribute or varying in seperate mode -- initial value 4 maxTransformFeedbackSeparateComponents :: GettableStateVar GLint maxTransformFeedbackSeparateComponents = makeGettableStateVar $ getInteger1 fromIntegral GetMaxTransformFeedbackSeparateComponents -------------------------------------------------------------------------------- -- | Set all the transform feedbacks varyings for this program -- it overwrites any previous call to this function setTransformFeedbackVaryings :: Program -> [String] -> TransformFeedbackBufferMode -> IO () setTransformFeedbackVaryings (Program program) sts tfbm = do ptSts <- mapM (\x -> withGLstring x return) sts stsPtrs <- newArray ptSts glTransformFeedbackVaryings program (fromIntegral . length $ sts) stsPtrs (marshalTransformFeedbackBufferMode tfbm) -- | Get the currently used transformFeedbackBufferMode transformFeedbackBufferMode :: Program -> GettableStateVar TransformFeedbackBufferMode transformFeedbackBufferMode = programVar1 (unmarshalTransformFeedbackBufferMode . fromIntegral) TransformFeedbackBufferMode -- | The number of varyings that are currently recorded when in -- transform feedback mode numTransformFeedbackVaryings :: Program -> GettableStateVar GLuint numTransformFeedbackVaryings = programVar1 fromIntegral TransformFeedbackVaryings -- | The maximum length of a varying's name for transform feedback mode transformFeedbackVaryingMaxLength :: Program -> GettableStateVar GLsizei transformFeedbackVaryingMaxLength = programVar1 fromIntegral TransformFeedbackVaryingMaxLength -- | The name, datatype and size of the transform feedback varyings. transformFeedbackVaryings :: Program -> GettableStateVar [(GLint, DataType, String)] transformFeedbackVaryings = activeVars numTransformFeedbackVaryings transformFeedbackVaryingMaxLength glGetTransformFeedbackVarying unmarshalDataType OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PrimitiveMode.hs0000644000000000000000000001010612521420345022244 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PrimitiveMode -- Copyright : (c) Sven Panne 2002-2013, Tobias Markus 2015 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 10.1 (Primitive Types) of the OpenGL 4.4 -- specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PrimitiveMode ( -- * Primitive Modes PrimitiveMode(..), -- * Patches (Tessellation) patchVertices, maxPatchVertices ) where import Data.StateVar import Graphics.Rendering.OpenGL.GL.QueryUtils.PName import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- | Specification of the way the vertices given during 'renderPrimitive' are -- interpreted. In the description of the constructors, /n/ is an integer count -- starting at one, and /N/ is the total number of vertices specified. data PrimitiveMode = Points -- ^ Treats each vertex as a single point. Vertex /n/ defines point /n/. -- /N/ points are drawn. | Lines -- ^ Treats each pair of vertices as an independent line segment. Vertices -- 2/n/-1 and 2/n/ define line /n/. /N/\/2 lines are drawn. | LineLoop -- ^ Draws a connected group of line segments from the first vertex to the -- last, then back to the first. Vertices /n/ and /n/+1 define line /n/. -- The last line, however, is defined by vertices /N/ and 1. /N/ lines -- are drawn. | LineStrip -- ^ Draws a connected group of line segments from the first vertex to the -- last. Vertices /n/ and /n/+1 define line /n/. /N/-1 lines are drawn. | Triangles -- ^ Treats each triplet of vertices as an independent triangle. Vertices -- /3n-2/, /3n-1/, and /3n/ define triangle /n/. /N\/3/ triangles are drawn. | TriangleStrip -- ^ Draws a connected group of triangles. One triangle is defined for each -- vertex presented after the first two vertices. For odd /n/, vertices -- /n/, /n/+1, and /n/+2 define triangle /n/. For even /n/, vertices /n/+1, -- /n/, and /n/+2 define triangle /n/. /N/-2 triangles are drawn. | TriangleFan -- ^ Draws a connected group of triangles. One triangle is defined for each -- vertex presented after the first two vertices. Vertices 1, /n/+1, and -- /n/+2 define triangle /n/. /N/-2 triangles are drawn. | Quads -- ^ Treats each group of four vertices as an independent quadrilateral. -- Vertices 4/n/-3, 4/n/-2, 4/n/-1, and 4/n/ define quadrilateral /n/. -- /N/\/4 quadrilaterals are drawn. | QuadStrip -- ^ Draws a connected group of quadrilaterals. One quadrilateral is --defined for each pair of vertices presented after the first pair. -- Vertices 2/n/-1, 2/n/, 2/n/+2, and 2/n/+1 define quadrilateral /n/. -- /N/\/2-1 quadrilaterals are drawn. Note that the order in which vertices -- are used to construct a quadrilateral from strip data is different from -- that used with independent data. | Polygon -- ^ Draws a single, convex polygon. Vertices 1 through /N/ define this -- polygon. | Patches -- ^ Only used in conjunction with tessellation. The number of vertices per -- patch can be set with 'patchVertices'. deriving ( Eq, Ord, Show ) -- | 'patchVertices' is the number of vertices per patch primitive. -- -- An 'Graphics.Rendering.OpenGL.GLU.Errors.InvalidValue' is generated if -- 'patchVertices' is set to a value less than or equal to zero or greater -- than the implementation-dependent maximum value 'maxPatchVertices'. patchVertices :: StateVar GLsizei patchVertices = makeStateVar (getSizei1 id GetMaxPatchVertices) (glPatchParameteri gl_PATCH_VERTICES . fromIntegral) -- | Contains the maximumum number of vertices in a single patch. maxPatchVertices :: GettableStateVar GLsizei maxPatchVertices = makeGettableStateVar $ getSizei1 id GetMaxPatchVertices OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/ConditionalRendering.hs0000644000000000000000000000341012521420345023570 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.ConditionalRendering -- Copyright : (c) Sven Panne 2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 10.10 (Conditional Rendering) of the -- OpenGL 4.4 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.ConditionalRendering ( ConditionalRenderMode(..), beginConditionalRender, endConditionalRender, withConditionalRender ) where import Graphics.Rendering.OpenGL.GL.Exception import Graphics.Rendering.OpenGL.GL.QueryObject import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data ConditionalRenderMode = QueryWait | QueryNoWait | QueryByRegionWait | QueryByRegionNoWait deriving ( Eq, Ord, Show ) marshalConditionalRenderMode :: ConditionalRenderMode -> GLenum marshalConditionalRenderMode x = case x of QueryWait -> gl_QUERY_WAIT QueryNoWait -> gl_QUERY_NO_WAIT QueryByRegionWait -> gl_QUERY_BY_REGION_WAIT QueryByRegionNoWait -> gl_QUERY_BY_REGION_NO_WAIT -------------------------------------------------------------------------------- beginConditionalRender :: QueryObject -> ConditionalRenderMode -> IO () beginConditionalRender q = glBeginConditionalRender (queryID q) . marshalConditionalRenderMode endConditionalRender :: IO () endConditionalRender = glEndConditionalRender withConditionalRender :: QueryObject -> ConditionalRenderMode -> IO a -> IO a withConditionalRender q m = bracket_ (beginConditionalRender q m) endConditionalRender OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/QueryUtils.hs0000644000000000000000000000727012521420345021625 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.QueryUtils -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module with utilities to query OpenGL state. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.QueryUtils ( module Graphics.Rendering.OpenGL.GL.QueryUtils.PName, module Graphics.Rendering.OpenGL.GL.QueryUtils.VertexAttrib, lightIndexToEnum, modelviewIndexToEnum, modelviewEnumToIndex, maybeNullPtr, objectNameLabel, objectPtrLabel, maxLabelLength ) where import Data.StateVar import Foreign.C.String ( peekCStringLen, withCStringLen ) import Foreign.Ptr ( Ptr, nullPtr ) import Foreign.Marshal.Alloc ( alloca ) import Foreign.Marshal.Array ( allocaArray ) import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.QueryUtils.PName import Graphics.Rendering.OpenGL.GL.QueryUtils.VertexAttrib import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- 0x4000 through 0x4FFF are reserved for light numbers lightIndexToEnum :: GLsizei -> Maybe GLenum lightIndexToEnum i | 0 <= i && i <= maxLightIndex = Just (gl_LIGHT0 + fromIntegral i) | otherwise = Nothing maxLightIndex :: GLsizei maxLightIndex = 0xFFF -------------------------------------------------------------------------------- -- 0x1700, 0x850a, and 0x8722 through 0x873f are reserved for modelview matrices modelviewIndexToEnum :: GLsizei -> Maybe GLenum modelviewIndexToEnum 0 = Just gl_MODELVIEW modelviewIndexToEnum 1 = Just gl_MODELVIEW1_ARB modelviewIndexToEnum i | 2 <= i && i <= 31 = Just (gl_MODELVIEW2_ARB - 2 + fromIntegral i) | otherwise = Nothing modelviewEnumToIndex :: GLenum -> Maybe GLsizei modelviewEnumToIndex x | x == gl_MODELVIEW = Just 0 | x == gl_MODELVIEW1_ARB = Just 1 | gl_MODELVIEW2_ARB <= x && x <= gl_MODELVIEW31_ARB = Just (fromIntegral (x - (gl_MODELVIEW2_ARB - 2))) | otherwise = Nothing -------------------------------------------------------------------------------- maybeNullPtr :: b -> (Ptr a -> b) -> Ptr a -> b maybeNullPtr n f ptr | ptr == nullPtr = n | otherwise = f ptr -------------------------------------------------------------------------------- objectNameLabel :: GLuint -> GLenum -> StateVar (Maybe String) objectNameLabel name ident = makeStateVar (getObjectLabelWith (glGetObjectLabel ident name)) (setObjectLabelWith (glObjectLabel ident name)) objectPtrLabel :: Ptr () -> StateVar (Maybe String) objectPtrLabel ptr = makeStateVar (getObjectLabelWith (glGetObjectPtrLabel ptr)) (setObjectLabelWith (glObjectPtrLabel ptr)) getObjectLabelWith :: (GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO ()) -> IO (Maybe String) getObjectLabelWith getLabel = do maxLen <- get maxLabelLength alloca $ \lenBuf -> allocaArray (fromIntegral maxLen) $ \labelBuf -> do getLabel maxLen lenBuf labelBuf actualLen <- peek1 fromIntegral lenBuf label <- peekCStringLen (labelBuf, actualLen) return $ if label == "" then Nothing else Just label setObjectLabelWith :: (GLsizei -> Ptr GLchar -> IO ()) -> Maybe String -> IO () setObjectLabelWith setLabel = maybe (set (nullPtr, (0 :: Int))) (flip withCStringLen set) where set (labelBuf, len) = setLabel (fromIntegral len) labelBuf maxLabelLength :: GettableStateVar GLsizei maxLabelLength = makeGettableStateVar (getSizei1 id GetMaxLabelLength) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PerFragment.hs0000644000000000000000000002771312521420345021715 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PerFragment -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 4.1 (Per-Fragment Operations) of the -- OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PerFragment ( -- * Discarding Primitives Before Rasterization rasterizerDiscard, discardingRasterizer, -- * Scissor Test scissor, -- * Multisample Fragment Operations sampleAlphaToCoverage, sampleAlphaToOne, sampleCoverage, -- * Depth Bounds Test depthBounds, -- * Alpha Test ComparisonFunction(..), alphaFunc, -- * Stencil Test stencilTest, stencilFunc, stencilFuncSeparate, StencilOp(..), stencilOp, stencilOpSeparate, activeStencilFace, -- * Depth Buffer Test depthFunc, -- * Blending blend, blendBuffer, BlendEquation(..), blendEquation, blendEquationSeparate, BlendingFactor(..), blendFuncSeparate, blendFunc, blendColor, -- * Dithering dither, -- * Logical Operation LogicOp(..), logicOp ) where import Control.Monad import Data.StateVar import Graphics.Rendering.OpenGL.GL.BlendingFactor import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.ComparisonFunction import Graphics.Rendering.OpenGL.GL.CoordTrans import Graphics.Rendering.OpenGL.GL.Exception import Graphics.Rendering.OpenGL.GL.Face import Graphics.Rendering.OpenGL.GL.Framebuffer import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- rasterizerDiscard :: StateVar Capability rasterizerDiscard = makeCapability CapRasterizerDiscard discardingRasterizer :: IO a -> IO a discardingRasterizer act = do r <- get rasterizerDiscard bracket_ (rasterizerDiscard $= Enabled) (rasterizerDiscard $= r) act -------------------------------------------------------------------------------- scissor :: StateVar (Maybe (Position, Size)) scissor = makeStateVarMaybe (return CapScissorTest) (getInteger4 makeSB GetScissorBox) (\(Position x y, Size w h) -> glScissor x y w h) where makeSB x y w h = (Position x y, Size (fromIntegral w) (fromIntegral h)) -------------------------------------------------------------------------------- sampleAlphaToCoverage :: StateVar Capability sampleAlphaToCoverage = makeCapability CapSampleAlphaToCoverage sampleAlphaToOne :: StateVar Capability sampleAlphaToOne = makeCapability CapSampleAlphaToOne sampleCoverage :: StateVar (Maybe (GLclampf, Bool)) sampleCoverage = makeStateVarMaybe (return CapSampleCoverage) (liftM2 (,) (getClampf1 id GetSampleCoverageValue) (getBoolean1 unmarshalGLboolean GetSampleCoverageInvert)) (\(value, invert) -> glSampleCoverage value (marshalGLboolean invert)) -------------------------------------------------------------------------------- depthBounds :: StateVar (Maybe (GLclampd, GLclampd)) depthBounds = makeStateVarMaybe (return CapDepthBoundsTest) (getClampd2 (,) GetDepthBounds) (uncurry glDepthBoundsEXT) -------------------------------------------------------------------------------- alphaFunc :: StateVar (Maybe (ComparisonFunction, GLclampf)) alphaFunc = makeStateVarMaybe (return CapAlphaTest) (liftM2 (,) (getEnum1 unmarshalComparisonFunction GetAlphaTestFunc) (getClampf1 id GetAlphaTestRef)) (uncurry (glAlphaFunc . marshalComparisonFunction)) -------------------------------------------------------------------------------- stencilTest :: StateVar Capability stencilTest = makeCapability CapStencilTest -------------------------------------------------------------------------------- stencilFunc :: StateVar (ComparisonFunction, GLint, GLuint) stencilFunc = makeStateVar (liftM3 (,,) (getEnum1 unmarshalComparisonFunction GetStencilFunc) (getInteger1 id GetStencilRef) (getInteger1 fromIntegral GetStencilValueMask)) (\(func, ref, mask) -> glStencilFunc (marshalComparisonFunction func) ref mask) stencilFuncSeparate :: Face -> SettableStateVar (ComparisonFunction, GLint, GLuint) stencilFuncSeparate face = makeSettableStateVar $ \(func, ref, mask) -> glStencilFuncSeparate (marshalFace face) (marshalComparisonFunction func) ref mask -------------------------------------------------------------------------------- data StencilOp = OpZero | OpKeep | OpReplace | OpIncr | OpIncrWrap | OpDecr | OpDecrWrap | OpInvert deriving ( Eq, Ord, Show ) marshalStencilOp :: StencilOp -> GLenum marshalStencilOp x = case x of OpZero -> gl_ZERO OpKeep -> gl_KEEP OpReplace -> gl_REPLACE OpIncr -> gl_INCR OpIncrWrap -> gl_INCR_WRAP OpDecr -> gl_DECR OpDecrWrap -> gl_DECR_WRAP OpInvert -> gl_INVERT unmarshalStencilOp :: GLenum -> StencilOp unmarshalStencilOp x | x == gl_ZERO = OpZero | x == gl_KEEP = OpKeep | x == gl_REPLACE = OpReplace | x == gl_INCR = OpIncr | x == gl_INCR_WRAP = OpIncrWrap | x == gl_DECR = OpDecr | x == gl_DECR_WRAP = OpDecrWrap | x == gl_INVERT = OpInvert | otherwise = error ("unmarshalStencilOp: illegal value " ++ show x) -------------------------------------------------------------------------------- stencilOp :: StateVar (StencilOp, StencilOp, StencilOp) stencilOp = makeStateVar (liftM3 (,,) (getEnum1 unmarshalStencilOp GetStencilFail) (getEnum1 unmarshalStencilOp GetStencilPassDepthFail) (getEnum1 unmarshalStencilOp GetStencilPassDepthPass)) (\(sf, spdf, spdp) -> glStencilOp (marshalStencilOp sf) (marshalStencilOp spdf) (marshalStencilOp spdp)) stencilOpSeparate :: Face -> SettableStateVar (StencilOp, StencilOp, StencilOp) stencilOpSeparate face = makeSettableStateVar $ \(sf, spdf, spdp) -> glStencilOpSeparate (marshalFace face) (marshalStencilOp sf) (marshalStencilOp spdf) (marshalStencilOp spdp) -------------------------------------------------------------------------------- activeStencilFace :: StateVar (Maybe Face) activeStencilFace = makeStateVarMaybe (return CapStencilTestTwoSide) (getEnum1 unmarshalFace GetActiveStencilFace) (glActiveStencilFaceEXT . marshalFace) -------------------------------------------------------------------------------- depthFunc :: StateVar (Maybe ComparisonFunction) depthFunc = makeStateVarMaybe (return CapDepthTest) (getEnum1 unmarshalComparisonFunction GetDepthFunc) (glDepthFunc . marshalComparisonFunction) -------------------------------------------------------------------------------- blend :: StateVar Capability blend = makeCapability CapBlend -- | enable or disable blending based on the buffer bound to the /i/'th drawBuffer -- that is the buffer fmap (!! i) (get drawBuffers) blendBuffer :: DrawBufferIndex -> StateVar Capability blendBuffer = makeIndexedCapability ((fromIntegral gl_DRAW_BUFFER0) +) BlendI -------------------------------------------------------------------------------- data BlendEquation = FuncAdd | FuncSubtract | FuncReverseSubtract | Min | Max | LogicOp deriving ( Eq, Ord, Show ) marshalBlendEquation :: BlendEquation -> GLenum marshalBlendEquation x = case x of FuncAdd -> gl_FUNC_ADD FuncSubtract -> gl_FUNC_SUBTRACT FuncReverseSubtract -> gl_FUNC_REVERSE_SUBTRACT Min -> gl_MIN Max -> gl_MAX LogicOp -> gl_INDEX_LOGIC_OP unmarshalBlendEquation :: GLenum -> BlendEquation unmarshalBlendEquation x | x == gl_FUNC_ADD = FuncAdd | x == gl_FUNC_SUBTRACT = FuncSubtract | x == gl_FUNC_REVERSE_SUBTRACT = FuncReverseSubtract | x == gl_MIN = Min | x == gl_MAX = Max | x == gl_INDEX_LOGIC_OP = LogicOp | otherwise = error ("unmarshalBlendEquation: illegal value " ++ show x) -------------------------------------------------------------------------------- blendEquation :: StateVar BlendEquation blendEquation = makeStateVar (getEnum1 unmarshalBlendEquation GetBlendEquation) (glBlendEquation . marshalBlendEquation) blendEquationSeparate :: StateVar (BlendEquation,BlendEquation) blendEquationSeparate = makeStateVar (liftM2 (,) (getEnum1 unmarshalBlendEquation GetBlendEquation) (getEnum1 unmarshalBlendEquation GetBlendEquationAlpha)) (\(funcRGB, funcAlpha) -> glBlendEquationSeparate (marshalBlendEquation funcRGB) (marshalBlendEquation funcAlpha)) -------------------------------------------------------------------------------- blendFuncSeparate :: StateVar ((BlendingFactor, BlendingFactor), (BlendingFactor, BlendingFactor)) blendFuncSeparate = makeStateVar (do srcRGB <- getEnum1 unmarshalBlendingFactor GetBlendSrcRGB srcAlpha <- getEnum1 unmarshalBlendingFactor GetBlendSrcAlpha dstRGB <- getEnum1 unmarshalBlendingFactor GetBlendDstRGB dstAlpha <- getEnum1 unmarshalBlendingFactor GetBlendDstAlpha return ((srcRGB, srcAlpha), (dstRGB, dstAlpha))) (\((srcRGB, srcAlpha), (dstRGB, dstAlpha)) -> glBlendFuncSeparate (marshalBlendingFactor srcRGB) (marshalBlendingFactor srcAlpha) (marshalBlendingFactor dstRGB) (marshalBlendingFactor dstAlpha)) blendFunc :: StateVar (BlendingFactor, BlendingFactor) blendFunc = makeStateVar (liftM2 (,) (getEnum1 unmarshalBlendingFactor GetBlendSrc) (getEnum1 unmarshalBlendingFactor GetBlendDst)) (\(s, d) -> glBlendFunc (marshalBlendingFactor s) (marshalBlendingFactor d)) blendColor :: StateVar (Color4 GLclampf) blendColor = makeStateVar (getClampf4 Color4 GetBlendColor) (\(Color4 r g b a) -> glBlendColor r g b a) -------------------------------------------------------------------------------- dither :: StateVar Capability dither = makeCapability CapDither -------------------------------------------------------------------------------- data LogicOp = Clear | And | AndReverse | Copy | AndInverted | Noop | Xor | Or | Nor | Equiv | Invert | OrReverse | CopyInverted | OrInverted | Nand | Set deriving ( Eq, Ord, Show ) marshalLogicOp :: LogicOp -> GLenum marshalLogicOp x = case x of Clear -> gl_CLEAR And -> gl_AND AndReverse -> gl_AND_REVERSE Copy -> gl_COPY AndInverted -> gl_AND_INVERTED Noop -> gl_NOOP Xor -> gl_XOR Or -> gl_OR Nor -> gl_NOR Equiv -> gl_EQUIV Invert -> gl_INVERT OrReverse -> gl_OR_REVERSE CopyInverted -> gl_COPY_INVERTED OrInverted -> gl_OR_INVERTED Nand -> gl_NAND Set -> gl_SET unmarshalLogicOp :: GLenum -> LogicOp unmarshalLogicOp x | x == gl_CLEAR = Clear | x == gl_AND = And | x == gl_AND_REVERSE = AndReverse | x == gl_COPY = Copy | x == gl_AND_INVERTED = AndInverted | x == gl_NOOP = Noop | x == gl_XOR = Xor | x == gl_OR = Or | x == gl_NOR = Nor | x == gl_EQUIV = Equiv | x == gl_INVERT = Invert | x == gl_OR_REVERSE = OrReverse | x == gl_COPY_INVERTED = CopyInverted | x == gl_OR_INVERTED = OrInverted | x == gl_NAND = Nand | x == gl_SET = Set | otherwise = error ("unmarshalLogicOp: illegal value " ++ show x) -------------------------------------------------------------------------------- logicOp :: StateVar (Maybe LogicOp) logicOp = makeStateVarMaybe (do rgba <- get rgbaMode return $ if rgba then CapColorLogicOp else CapIndexLogicOp) (getEnum1 unmarshalLogicOp GetLogicOpMode) (glLogicOp . marshalLogicOp) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Feedback.hs0000644000000000000000000001507412521420345021164 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Feedback -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 5.3 (Feedback) of the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Feedback ( FeedbackToken(..), VertexInfo(..), ColorInfo, FeedbackType(..), getFeedbackTokens, PassThroughValue(..), passThrough ) where import Control.Monad import Data.StateVar import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.GL.IOState import Graphics.Rendering.OpenGL.GL.RenderMode import Graphics.Rendering.OpenGL.GL.Tensor import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data FeedbackToken = PointToken VertexInfo | LineToken VertexInfo VertexInfo | LineResetToken VertexInfo VertexInfo | PolygonToken [VertexInfo] | BitmapToken VertexInfo | DrawPixelToken VertexInfo | CopyPixelToken VertexInfo | PassThroughToken PassThroughValue deriving ( Eq, Ord, Show ) data VertexInfo = Vertex2D (Vertex2 GLfloat) | Vertex3D (Vertex3 GLfloat) | Vertex3DColor (Vertex3 GLfloat) ColorInfo | Vertex3DColorTexture (Vertex3 GLfloat) ColorInfo (TexCoord4 GLfloat) | Vertex4DColorTexture (Vertex4 GLfloat) ColorInfo (TexCoord4 GLfloat) deriving ( Eq, Ord, Show ) type ColorInfo = Either (Index1 GLint) (Color4 GLfloat) -------------------------------------------------------------------------------- data FeedbackTag = PointTag | LineTag | LineResetTag | PolygonTag | BitmapTag | DrawPixelTag | CopyPixelTag | PassThroughTag unmarshalFeedbackTag :: GLenum -> FeedbackTag unmarshalFeedbackTag x | x == gl_POINT_TOKEN = PointTag | x == gl_LINE_TOKEN = LineTag | x == gl_LINE_RESET_TOKEN = LineResetTag | x == gl_POLYGON_TOKEN = PolygonTag | x == gl_BITMAP_TOKEN = BitmapTag | x == gl_DRAW_PIXEL_TOKEN = DrawPixelTag | x == gl_COPY_PIXEL_TOKEN = CopyPixelTag | x == gl_PASS_THROUGH_TOKEN = PassThroughTag | otherwise = error ("unmarshalFeedbackTag: illegal value " ++ show x) -------------------------------------------------------------------------------- data FeedbackType = TwoD | ThreeD | ThreeDColor | ThreeDColorTexture | FourDColorTexture deriving ( Eq, Ord, Show ) marshalFeedbackType :: FeedbackType -> GLenum marshalFeedbackType x = case x of TwoD -> gl_2D ThreeD -> gl_3D ThreeDColor -> gl_3D_COLOR ThreeDColorTexture -> gl_3D_COLOR_TEXTURE FourDColorTexture -> gl_4D_COLOR_TEXTURE -------------------------------------------------------------------------------- getFeedbackTokens :: GLsizei -> FeedbackType -> IO a -> IO (a, Maybe [FeedbackToken]) getFeedbackTokens bufSize feedbackType action = allocaArray (fromIntegral bufSize) $ \buf -> do glFeedbackBuffer bufSize (marshalFeedbackType feedbackType) buf (value, numValues) <- withRenderMode Feedback action tokens <- parseFeedbackBuffer numValues buf feedbackType return (value, tokens) -------------------------------------------------------------------------------- parseFeedbackBuffer :: GLint -> Ptr GLfloat -> FeedbackType -> IO (Maybe [FeedbackToken]) parseFeedbackBuffer numValues buf feedbackType | numValues < 0 = return Nothing | otherwise = do rgba <- get rgbaMode let end = buf `plusPtr` (sizeOf (undefined :: GLfloat) * fromIntegral numValues) infoParser = calcInfoParser feedbackType (calcColorParser rgba) loop tokens = do ptr <- getIOState if ptr == end then return (reverse tokens) else do token <- tokenParser infoParser loop (token : tokens) fmap Just $ evalIOState (loop []) buf type Parser a = IOState GLfloat a tokenParser :: Parser VertexInfo -> Parser FeedbackToken tokenParser infoParser = do tag <- parseGLenum case unmarshalFeedbackTag tag of PointTag -> fmap PointToken infoParser LineTag -> liftM2 LineToken infoParser infoParser LineResetTag -> liftM2 LineResetToken infoParser infoParser PolygonTag -> do n <- parseGLint; fmap PolygonToken (nTimes n infoParser) BitmapTag -> fmap BitmapToken infoParser DrawPixelTag -> fmap DrawPixelToken infoParser CopyPixelTag -> fmap CopyPixelToken infoParser PassThroughTag -> fmap PassThroughToken parsePassThroughValue calcInfoParser :: FeedbackType -> Parser ColorInfo -> Parser VertexInfo calcInfoParser feedbackType colorParser = case feedbackType of TwoD -> fmap Vertex2D parseVertex2 ThreeD -> fmap Vertex3D parseVertex3 ThreeDColor -> liftM2 Vertex3DColor parseVertex3 colorParser ThreeDColorTexture -> liftM3 Vertex3DColorTexture parseVertex3 colorParser parseTexCoord4 FourDColorTexture -> liftM3 Vertex4DColorTexture parseVertex4 colorParser parseTexCoord4 parseVertex2 :: Parser (Vertex2 GLfloat) parseVertex2 = liftM2 Vertex2 parseGLfloat parseGLfloat parseVertex3 :: Parser (Vertex3 GLfloat) parseVertex3 = liftM3 Vertex3 parseGLfloat parseGLfloat parseGLfloat parseVertex4 :: Parser (Vertex4 GLfloat) parseVertex4 = liftM4 Vertex4 parseGLfloat parseGLfloat parseGLfloat parseGLfloat calcColorParser :: Bool -> Parser ColorInfo calcColorParser False = fmap Left parseIndex1 calcColorParser True = fmap Right parseColor4 parseIndex1 :: Parser (Index1 GLint) parseIndex1 = fmap Index1 parseGLint parseColor4 :: Parser (Color4 GLfloat) parseColor4 = liftM4 Color4 parseGLfloat parseGLfloat parseGLfloat parseGLfloat parseTexCoord4 :: Parser (TexCoord4 GLfloat) parseTexCoord4 = liftM4 TexCoord4 parseGLfloat parseGLfloat parseGLfloat parseGLfloat parsePassThroughValue :: Parser PassThroughValue parsePassThroughValue = fmap PassThroughValue parseGLfloat parseGLenum :: Parser GLenum parseGLenum = fmap round parseGLfloat parseGLint :: Parser GLint parseGLint = fmap round parseGLfloat parseGLfloat :: Parser GLfloat parseGLfloat = peekIOState -------------------------------------------------------------------------------- newtype PassThroughValue = PassThroughValue GLfloat deriving ( Eq, Ord, Show ) passThrough :: PassThroughValue -> IO () passThrough (PassThroughValue ptv) = glPassThrough ptv OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/QueryObjects.hs0000644000000000000000000001404512521420345022114 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.QueryObjects -- Copyright : (c) Sven Panne, Lars Corbijn 2004-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 4.2 (Query Objects and Asynchronous -- Queries) of the OpenGL 4.4 specs. -- ----------------------------------------------------------------------------- {-# LANGUAGE TypeSynonymInstances #-} module Graphics.Rendering.OpenGL.GL.QueryObjects ( -- * Creating and Delimiting Queries QueryObject, QueryIndex, maxVertexStreams, QueryTarget(..), beginQuery, endQuery, withQuery, -- * Query Target Queries currentQuery, queryCounterBits, -- * Query Object Queries queryResultAvailable, QueryResult, queryResult, -- * Time Queries timestampQuery, timestamp ) where import Data.StateVar import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.GL.Exception import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.QueryObject import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- type QueryIndex = GLuint maxVertexStreams :: GettableStateVar QueryIndex maxVertexStreams = makeGettableStateVar (getInteger1 fromIntegral GetMaxVertexStreams) -------------------------------------------------------------------------------- data QueryTarget = SamplesPassed | AnySamplesPassed | AnySamplesPassedConservative | TimeElapsed | PrimitivesGenerated QueryIndex | TransformFeedbackPrimitivesWritten QueryIndex deriving ( Eq, Ord, Show ) marshalQueryTarget :: QueryTarget -> (GLenum, QueryIndex) marshalQueryTarget x = case x of SamplesPassed -> (gl_SAMPLES_PASSED, 0) AnySamplesPassed -> (gl_ANY_SAMPLES_PASSED, 0) AnySamplesPassedConservative -> (gl_ANY_SAMPLES_PASSED_CONSERVATIVE, 0) TimeElapsed -> (gl_TIME_ELAPSED, 0) PrimitivesGenerated n -> (gl_PRIMITIVES_GENERATED, n) TransformFeedbackPrimitivesWritten n -> (gl_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN, n) -------------------------------------------------------------------------------- beginQuery :: QueryTarget -> QueryObject -> IO () beginQuery target = case marshalQueryTarget target of (t, 0) -> glBeginQuery t . queryID (t, n) -> glBeginQueryIndexed t n . queryID endQuery :: QueryTarget -> IO () endQuery target = case marshalQueryTarget target of (t, 0) -> glEndQuery t (t, n) -> glEndQueryIndexed t n -- | Convenience function for an exception-safe combination of 'beginQuery' and -- 'endQuery'. withQuery :: QueryTarget -> QueryObject -> IO a -> IO a withQuery t q = bracket_ (beginQuery t q) (endQuery t) -------------------------------------------------------------------------------- data GetQueryPName = QueryCounterBits | CurrentQuery marshalGetQueryPName :: GetQueryPName -> GLenum marshalGetQueryPName x = case x of QueryCounterBits -> gl_QUERY_COUNTER_BITS CurrentQuery -> gl_CURRENT_QUERY -------------------------------------------------------------------------------- currentQuery :: QueryTarget -> GettableStateVar (Maybe QueryObject) currentQuery = getQueryi (toMaybeQueryObject . toQueryObject) CurrentQuery where toQueryObject = QueryObject . fromIntegral toMaybeQueryObject q = if q == noQueryObject then Nothing else Just q queryCounterBits :: QueryTarget -> GettableStateVar GLsizei queryCounterBits = getQueryi fromIntegral QueryCounterBits getQueryi :: (GLint -> a) -> GetQueryPName -> QueryTarget -> GettableStateVar a getQueryi f p t = makeGettableStateVar $ with 0 $ \buf -> do getQueryiv' t p buf peek1 f buf getQueryiv' :: QueryTarget -> GetQueryPName -> Ptr GLint -> IO () getQueryiv' target = case marshalQueryTarget target of (t, 0) -> glGetQueryiv t . marshalGetQueryPName (t, n) -> glGetQueryIndexediv t n . marshalGetQueryPName -------------------------------------------------------------------------------- data GetQueryObjectPName = QueryResultAvailable | QueryResult marshalGetQueryObjectPName :: GetQueryObjectPName -> GLenum marshalGetQueryObjectPName x = case x of QueryResultAvailable -> gl_QUERY_RESULT_AVAILABLE QueryResult -> gl_QUERY_RESULT -------------------------------------------------------------------------------- queryResultAvailable :: QueryObject -> GettableStateVar Bool queryResultAvailable = getQueryObject (unmarshalGLboolean :: GLuint -> Bool) QueryResultAvailable queryResult :: QueryResult a => QueryObject -> GettableStateVar a queryResult = getQueryObject id QueryResult class Storable a => QueryResult a where getQueryObjectv :: GLuint -> GLenum -> Ptr a -> IO () instance QueryResult GLint where getQueryObjectv = glGetQueryObjectiv instance QueryResult GLuint where getQueryObjectv = glGetQueryObjectuiv instance QueryResult GLint64 where getQueryObjectv = glGetQueryObjecti64v instance QueryResult GLuint64 where getQueryObjectv = glGetQueryObjectui64v getQueryObject :: (QueryResult a) => (a -> b) -> GetQueryObjectPName -> QueryObject -> GettableStateVar b getQueryObject f p q = makeGettableStateVar $ alloca $ \buf -> do getQueryObjectv (queryID q) (marshalGetQueryObjectPName p) buf peek1 f buf -------------------------------------------------------------------------------- -- | Record the time after all previous commands on the GL client and server -- state and the framebuffer have been fully realized timestampQuery :: QueryObject -> IO () timestampQuery q = glQueryCounter (queryID q) gl_TIMESTAMP -- | Contains the GL time after all previous commands have reached the GL server -- but have not yet necessarily executed. timestamp :: GettableStateVar GLuint64 timestamp = makeGettableStateVar (getInteger64 fromIntegral GetTimestamp) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/SavingState.hs0000644000000000000000000000703712521420345021730 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.SavingState -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 6.1.14 (Saving and Restoring State) of the -- OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.SavingState ( ServerAttributeGroup(..), preservingAttrib, ClientAttributeGroup(..), preservingClientAttrib ) where import Graphics.Rendering.OpenGL.GL.Exception ( bracket_ ) import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data ServerAttributeGroup = CurrentAttributes | PointAttributes | LineAttributes | PolygonAttributes | PolygonStippleAttributes | PixelModeAttributes | LightingAttributes | FogAttributes | DepthBufferAttributes | AccumBufferAttributes | StencilBufferAttributes | ViewportAttributes | TransformAttributes | EnableAttributes | ColorBufferAttributes | HintAttributes | EvalAttributes | ListAttributes | TextureAttributes | ScissorAttributes | MultisampleAttributes | AllServerAttributes deriving ( Eq, Ord, Show ) marshalServerAttributeGroup :: ServerAttributeGroup -> GLbitfield marshalServerAttributeGroup x = case x of CurrentAttributes -> gl_CURRENT_BIT PointAttributes -> gl_POINT_BIT LineAttributes -> gl_LINE_BIT PolygonAttributes -> gl_POLYGON_BIT PolygonStippleAttributes -> gl_POLYGON_STIPPLE_BIT PixelModeAttributes -> gl_PIXEL_MODE_BIT LightingAttributes -> gl_LIGHTING_BIT FogAttributes -> gl_FOG_BIT DepthBufferAttributes -> gl_DEPTH_BUFFER_BIT AccumBufferAttributes -> gl_ACCUM_BUFFER_BIT StencilBufferAttributes -> gl_STENCIL_BUFFER_BIT ViewportAttributes -> gl_VIEWPORT_BIT TransformAttributes -> gl_TRANSFORM_BIT EnableAttributes -> gl_ENABLE_BIT ColorBufferAttributes -> gl_COLOR_BUFFER_BIT HintAttributes -> gl_HINT_BIT EvalAttributes -> gl_EVAL_BIT ListAttributes -> gl_LIST_BIT TextureAttributes -> gl_TEXTURE_BIT ScissorAttributes -> gl_SCISSOR_BIT MultisampleAttributes -> gl_MULTISAMPLE_BIT AllServerAttributes -> gl_ALL_ATTRIB_BITS -------------------------------------------------------------------------------- preservingAttrib :: [ServerAttributeGroup] -> IO a -> IO a preservingAttrib groups = bracket_ (pushAttrib groups) glPopAttrib pushAttrib :: [ServerAttributeGroup] -> IO () pushAttrib = glPushAttrib . sum . map marshalServerAttributeGroup -------------------------------------------------------------------------------- data ClientAttributeGroup = PixelStoreAttributes | VertexArrayAttributes | AllClientAttributes deriving ( Eq, Ord, Show ) marshalClientAttributeGroup :: ClientAttributeGroup -> GLbitfield marshalClientAttributeGroup x = case x of PixelStoreAttributes -> gl_CLIENT_PIXEL_STORE_BIT VertexArrayAttributes -> gl_CLIENT_VERTEX_ARRAY_BIT AllClientAttributes -> gl_CLIENT_ALL_ATTRIB_BITS -------------------------------------------------------------------------------- preservingClientAttrib :: [ClientAttributeGroup] -> IO a -> IO a preservingClientAttrib groups = bracket_ (pushClientAttrib groups) glPopClientAttrib pushClientAttrib :: [ClientAttributeGroup] -> IO () pushClientAttrib = glPushClientAttrib . sum . map marshalClientAttributeGroup OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Evaluators.hs0000644000000000000000000003272412521420345021626 0ustar0000000000000000{-# LANGUAGE KindSignatures #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Evaluators -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 5.1 (Evaluators) of the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Evaluators ( -- * Evaluator-related Types Order, maxOrder, Domain, MapDescriptor(..), ControlPoint, -- * Defining Evaluator Maps -- ** One-dimensional Evaluator Maps Map1(..), GLmap1, map1, -- ** Two-dimensional Evaluator Maps Map2(..), GLmap2, map2, -- * Using Evaluator Maps -- ** Evaluating an Arbitrary Coordinate Value evalCoord1, evalCoord1v, evalCoord2, evalCoord2v, -- ** Using Evenly Spaced Coordinate Values -- *** Defining a Grid mapGrid1, mapGrid2, -- *** Evaluating a Whole Mesh evalMesh1, evalMesh2, -- *** Evaluating a Single Point on a Mesh evalPoint1, evalPoint2, -- * Normal Generation autoNormal ) where import Control.Monad import Data.List import Data.StateVar import Foreign.ForeignPtr import Foreign.Marshal.Array import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.ControlPoint import Graphics.Rendering.OpenGL.GL.Domain import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.PolygonMode import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.VertexArrays import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- type Order = GLint maxOrder :: GettableStateVar Order maxOrder = makeGettableStateVar (getInteger1 id GetMaxEvalOrder) -------------------------------------------------------------------------------- data MapDescriptor d = MapDescriptor (d, d) Stride Order NumComponents deriving ( Eq, Ord, Show ) totalComponents1 :: Domain d => MapDescriptor d -> Int totalComponents1 (MapDescriptor _ stride order numComp) = fromIntegral stride * (fromIntegral order - 1) + fromIntegral numComp totalComponents2 :: Domain d => MapDescriptor d -> MapDescriptor d -> Int totalComponents2 uDescriptor vDescriptor@(MapDescriptor _ _ _ numComp) = totalComponents1 uDescriptor + totalComponents1 vDescriptor - fromIntegral numComp -------------------------------------------------------------------------------- peekControlPoints1 :: (ControlPoint c, Domain d) => MapDescriptor d -> Ptr d -> IO [c d] peekControlPoints1 descriptor ptr = mapM peekControlPoint (controlPointPtrs1 descriptor ptr) peekControlPoints2 :: (ControlPoint c, Domain d) => MapDescriptor d -> MapDescriptor d -> Ptr d -> IO [[c d]] peekControlPoints2 uDescriptor vDescriptor ptr = mapM (mapM peekControlPoint) (controlPointPtrs2 uDescriptor vDescriptor ptr) pokeControlPoints1 :: (ControlPoint c, Domain d) => MapDescriptor d -> Ptr d -> [c d] -> IO () pokeControlPoints1 descriptor ptr = zipWithM_ pokeControlPoint (controlPointPtrs1 descriptor ptr) pokeControlPoints2 :: (ControlPoint c, Domain d) => MapDescriptor d -> MapDescriptor d -> Ptr d -> [[c d]] -> IO () pokeControlPoints2 uDescriptor vDescriptor ptr = zipWithM_ (zipWithM_ pokeControlPoint) (controlPointPtrs2 uDescriptor vDescriptor ptr) controlPointPtrs1 :: Domain d => MapDescriptor d -> Ptr d -> [Ptr a] controlPointPtrs1 (MapDescriptor _ stride order _) ptr = [ ptr `plusPtr` (o * s) | o <- [ 0 .. fromIntegral order - 1 ] ] where s = sizeOfPtr ptr * fromIntegral stride controlPointPtrs2 :: Domain d => MapDescriptor d -> MapDescriptor d -> Ptr d -> [[Ptr a]] controlPointPtrs2 uDescriptor vDescriptor ptr = [ controlPointPtrs1 vDescriptor p | p <- controlPointPtrs1 uDescriptor ptr ] sizeOfPtr :: Storable a => Ptr a -> Int sizeOfPtr = sizeOf . (const undefined :: Ptr a -> a) -------------------------------------------------------------------------------- class Map1 m where withNewMap1 :: (ControlPoint c, Domain d) => MapDescriptor d -> (Ptr d -> IO ()) -> IO (m c d) withMap1 :: (ControlPoint c, Domain d) => m c d -> (MapDescriptor d -> Ptr d -> IO a) -> IO a newMap1 :: (ControlPoint c, Domain d) => (d, d) -> [c d] -> IO (m c d) getMap1Components :: (ControlPoint c, Domain d) => m c d -> IO ((d, d), [c d]) withNewMap1 descriptor@(MapDescriptor domain _ _ _) act = do allocaArray (totalComponents1 descriptor) $ \ptr -> do act ptr controlPoints <- peekControlPoints1 descriptor ptr newMap1 domain controlPoints withMap1 m act = do (domain, controlPoints) <- getMap1Components m let stride = numComponents (head controlPoints) order = genericLength controlPoints descriptor = MapDescriptor domain stride order (fromIntegral stride) allocaArray (totalComponents1 descriptor) $ \ptr -> do pokeControlPoints1 descriptor ptr controlPoints act descriptor ptr newMap1 domain controlPoints = do let stride = numComponents (head controlPoints) order = genericLength controlPoints descriptor = MapDescriptor domain stride order (fromIntegral stride) withNewMap1 descriptor $ \ptr -> pokeControlPoints1 descriptor ptr controlPoints getMap1Components m = withMap1 m $ \descriptor@(MapDescriptor domain _ _ _) ptr -> do controlPoints <- peekControlPoints1 descriptor ptr return (domain, controlPoints) -------------------------------------------------------------------------------- data GLmap1 (c :: * -> *) d = GLmap1 (MapDescriptor d) (ForeignPtr d) deriving ( Eq, Ord, Show ) instance Map1 GLmap1 where withNewMap1 descriptor act = do fp <- mallocForeignPtrArray (totalComponents1 descriptor) withForeignPtr fp act return $ GLmap1 descriptor fp withMap1 (GLmap1 descriptor fp) act = withForeignPtr fp $ act descriptor -------------------------------------------------------------------------------- map1 :: (Map1 m, ControlPoint c, Domain d) => StateVar (Maybe (m c d)) map1 = makeMap1StateVar enableCap1 getMap1 setMap1 makeMap1StateVar :: (c d -> EnableCap) -> (c d -> IO (m c d)) -> (c d -> m c d -> IO ()) -> StateVar (Maybe (m c d)) makeMap1StateVar getCap getAct setAct = makeStateVarMaybe (return (getCap undefined)) (getAct undefined) (setAct undefined) getMap1 :: (Map1 m, ControlPoint c, Domain d) => c d -> IO (m c d) getMap1 dummyControlPoint = do let target = map1Target dummyControlPoint numComp = fromIntegral (numComponents dummyControlPoint) domain <- allocaArray 2 $ \ptr -> do glGetMapv target (marshalGetMapQuery Domain) ptr peek2 (,) ptr order <- with 0 $ \ptr -> do glGetMapiv target (marshalGetMapQuery Order) ptr fmap fromIntegral $ peek ptr withNewMap1 (MapDescriptor domain (numComponents dummyControlPoint) order numComp) $ glGetMapv target (marshalGetMapQuery Coeff) setMap1 :: (Map1 m, ControlPoint c, Domain d) => c d -> m c d -> IO () setMap1 dummyControlPoint m = withMap1 m $ \(MapDescriptor (u1, u2) stride order _) -> glMap1 (map1Target dummyControlPoint) u1 u2 (fromIntegral stride) (fromIntegral order) -------------------------------------------------------------------------------- class Map2 m where withNewMap2 :: (ControlPoint c, Domain d) => MapDescriptor d -> MapDescriptor d -> (Ptr d -> IO ()) -> IO (m c d) withMap2 :: (ControlPoint c, Domain d) => m c d -> (MapDescriptor d -> MapDescriptor d -> Ptr d -> IO a) -> IO a newMap2 :: (ControlPoint c, Domain d) => (d, d) -> (d, d) -> [[c d]] -> IO (m c d) getMap2Components :: (ControlPoint c, Domain d) => m c d -> IO ((d, d), (d, d), [[c d]]) withNewMap2 uDescriptor@(MapDescriptor uDomain _ _ _) vDescriptor@(MapDescriptor vDomain _ _ _) act = allocaArray (totalComponents2 uDescriptor vDescriptor) $ \ptr -> do act ptr controlPoints <- peekControlPoints2 uDescriptor vDescriptor ptr newMap2 uDomain vDomain controlPoints withMap2 m act = do (uDomain, vDomain, controlPoints) <- getMap2Components m let vStride = numComponents (head (head controlPoints)) vOrder = genericLength (head controlPoints) uStride = vStride * fromIntegral vOrder uOrder = genericLength controlPoints numComp = fromIntegral vStride uDescriptor = MapDescriptor uDomain uStride uOrder numComp vDescriptor = MapDescriptor vDomain vStride vOrder numComp allocaArray (totalComponents2 uDescriptor vDescriptor) $ \ptr -> do pokeControlPoints2 uDescriptor vDescriptor ptr controlPoints act uDescriptor vDescriptor ptr newMap2 uDomain vDomain controlPoints = do let vStride = numComponents (head (head controlPoints)) vOrder = genericLength (head controlPoints) uStride = vStride * fromIntegral vOrder uOrder = genericLength controlPoints numComp = fromIntegral vStride uDescriptor = MapDescriptor uDomain uStride uOrder numComp vDescriptor = MapDescriptor vDomain vStride vOrder numComp withNewMap2 uDescriptor vDescriptor $ \ptr -> pokeControlPoints2 uDescriptor vDescriptor ptr controlPoints getMap2Components m = withMap2 m $ \uDescriptor@(MapDescriptor uDomain _ _ _) vDescriptor@(MapDescriptor vDomain _ _ _) ptr -> do controlPoints <- peekControlPoints2 uDescriptor vDescriptor ptr return (uDomain, vDomain, controlPoints) -------------------------------------------------------------------------------- data GLmap2 (c :: * -> *) d = GLmap2 (MapDescriptor d) (MapDescriptor d) (ForeignPtr d) deriving ( Eq, Ord, Show ) instance Map2 GLmap2 where withNewMap2 uDescriptor vDescriptor act = do fp <- mallocForeignPtrArray (totalComponents2 uDescriptor vDescriptor) withForeignPtr fp act return $ GLmap2 uDescriptor vDescriptor fp withMap2 (GLmap2 uDescriptor vDescriptor fp) act = withForeignPtr fp $ act uDescriptor vDescriptor -------------------------------------------------------------------------------- map2 :: (Map2 m, ControlPoint c, Domain d) => StateVar (Maybe (m c d)) map2 = makeMap2StateVar enableCap2 getMap2 setMap2 makeMap2StateVar :: (c d -> EnableCap) -> (c d -> IO (m c d)) -> (c d -> m c d -> IO ()) -> StateVar (Maybe (m c d)) makeMap2StateVar getCap getAct setAct = makeStateVarMaybe (return (getCap undefined)) (getAct undefined) (setAct undefined) getMap2 :: (Map2 m, ControlPoint c, Domain d) => c d -> IO (m c d) getMap2 dummyControlPoint = do let target = map2Target dummyControlPoint (uDomain, vDomain) <- allocaArray 4 $ \ptr -> do glGetMapv target (marshalGetMapQuery Domain) ptr peek4 (\u1 u2 v1 v2 -> ((u1, u2), (v1, v2))) ptr (uOrder, vOrder) <- withArray [0,0] $ \ptr -> do glGetMapiv target (marshalGetMapQuery Order) ptr peek2 (,) ptr let vStride = numComponents dummyControlPoint uStride = vStride * fromIntegral vOrder withNewMap2 (MapDescriptor uDomain uStride uOrder (fromIntegral vStride)) (MapDescriptor vDomain vStride vOrder (fromIntegral vStride)) $ glGetMapv target (marshalGetMapQuery Coeff) setMap2 :: (Map2 m, ControlPoint c, Domain d) => c d -> m c d -> IO () setMap2 dummyControlPoint m = withMap2 m $ \(MapDescriptor (u1, u2) uStride uOrder _) (MapDescriptor (v1, v2) vStride vOrder _) -> glMap2 (map2Target dummyControlPoint) u1 u2 (fromIntegral uStride) (fromIntegral uOrder) v1 v2 (fromIntegral vStride) (fromIntegral vOrder) -------------------------------------------------------------------------------- data GetMapQuery = Coeff | Order | Domain marshalGetMapQuery :: GetMapQuery -> GLenum marshalGetMapQuery x = case x of Coeff -> gl_COEFF Order -> gl_ORDER Domain -> gl_DOMAIN -------------------------------------------------------------------------------- mapGrid1 :: Domain d => StateVar (GLint, (d, d)) mapGrid1 = makeStateVar (do n <- getInteger1 id GetMap1GridSegments domain <- get2 (,) GetMap1GridDomain return (n, domain)) (\(n, (u1, u2)) -> glMapGrid1 n u1 u2) mapGrid2 :: Domain d => StateVar ((GLint, (d, d)), (GLint, (d, d))) mapGrid2 = makeStateVar (do (un, vn) <- getInteger2 (,) GetMap2GridSegments (u1, u2, v1, v2) <- get4 (,,,) GetMap2GridDomain return ((un, (u1, u2)), (vn, (v1, v2)))) (\((un, (u1, u2)), (vn, (v1, v2))) -> glMapGrid2 un u1 u2 vn v1 v2) -------------------------------------------------------------------------------- evalMesh1 :: PolygonMode -> (GLint, GLint) -> IO () evalMesh1 m (p1, p2) = glEvalMesh1 (marshalPolygonMode m) p1 p2 evalMesh2 :: PolygonMode -> (GLint, GLint) -> (GLint, GLint) -> IO () evalMesh2 m (p1, p2) (q1, q2) = glEvalMesh2 (marshalPolygonMode m) p1 p2 q1 q2 -------------------------------------------------------------------------------- evalPoint1 :: GLint -> IO () evalPoint1 = glEvalPoint1 evalPoint2 :: (GLint, GLint) -> IO () evalPoint2 = uncurry glEvalPoint2 -------------------------------------------------------------------------------- autoNormal :: StateVar Capability autoNormal = makeCapability CapAutoNormal OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Capability.hs0000644000000000000000000002475712521420345021571 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Capability -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for handling OpenGL capabilities, i.e. -- boolean state variables. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Capability ( Capability(..), marshalCapability, unmarshalCapability, EnableCap(..), makeCapability, makeStateVarMaybe, IndexedEnableCap(..), makeIndexedCapability, ) where import Data.StateVar import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data Capability = Disabled | Enabled deriving ( Eq, Ord, Show ) -------------------------------------------------------------------------------- marshalCapability :: Capability -> GLboolean marshalCapability = marshalGLboolean . (Enabled ==) unmarshalCapability :: GLboolean -> Capability unmarshalCapability x = if unmarshalGLboolean x then Enabled else Disabled -------------------------------------------------------------------------------- data EnableCap = CapFog | CapLighting | CapTexture1D | CapTexture2D | CapTexture2DMultisample | CapTexture1DArray | CapTextureRectangle | CapTextureCubeMap | CapTexture3D | CapTexture2DArray | CapTexture2DMultisampleArray | CapTextureCubeMapArray | CapLineStipple | CapPolygonStipple | CapCullFace | CapAlphaTest | CapBlend | CapIndexLogicOp | CapColorLogicOp | CapDither | CapStencilTest | CapDepthTest | CapClipPlane GLsizei | CapLight GLsizei | CapTextureGenS | CapTextureGenT | CapTextureGenR | CapTextureGenQ | CapMap1Vertex3 | CapMap1Vertex4 | CapMap1Color4 | CapMap1Index | CapMap1Normal | CapMap1TextureCoord1 | CapMap1TextureCoord2 | CapMap1TextureCoord3 | CapMap1TextureCoord4 | CapMap2Vertex3 | CapMap2Vertex4 | CapMap2Color4 | CapMap2Index | CapMap2Normal | CapMap2TextureCoord1 | CapMap2TextureCoord2 | CapMap2TextureCoord3 | CapMap2TextureCoord4 | CapPointSmooth | CapLineSmooth | CapPolygonSmooth | CapScissorTest | CapColorMaterial | CapNormalize | CapAutoNormal | CapPolygonOffsetPoint | CapPolygonOffsetLine | CapPolygonOffsetFill | CapVertexArray | CapNormalArray | CapColorArray | CapIndexArray | CapTextureCoordArray | CapEdgeFlagArray | CapFogCoordArray | CapSecondaryColorArray | CapMatrixIndexArray | CapConvolution1D | CapConvolution2D | CapSeparable2D | CapHistogram | CapMinmax | CapRescaleNormal | CapSharedTexturePalette | CapMultisample | CapSampleAlphaToCoverage | CapSampleAlphaToOne | CapSampleCoverage | CapColorTable | CapPostConvolutionColorTable | CapPostColorMatrixColorTable | CapColorSum | CapWeightSumUnity | CapVertexBlend | CapWeightArray | CapMatrixPalette | CapDepthClamp | CapDepthBoundsTest | CapPrimitiveRestart | CapPointSprite | CapStencilTestTwoSide | CapRasterPositionUnclipped | CapRasterizerDiscard | CapTextureColorTable | CapVertexProgramPointSize | CapVertexProgramTwoSide | CapDebugOutput | CapDebugOutputSynchronous marshalEnableCap :: EnableCap -> Maybe GLenum marshalEnableCap x = case x of CapFog -> Just gl_FOG CapLighting -> Just gl_LIGHTING CapTexture1D -> Just gl_TEXTURE_1D CapTexture2D -> Just gl_TEXTURE_2D CapTexture2DMultisample -> Just gl_TEXTURE_2D_MULTISAMPLE CapTexture1DArray -> Just gl_TEXTURE_1D_ARRAY CapTextureRectangle -> Just gl_TEXTURE_RECTANGLE CapTextureCubeMap -> Just gl_TEXTURE_CUBE_MAP CapTexture3D -> Just gl_TEXTURE_3D CapTexture2DArray -> Just gl_TEXTURE_2D_ARRAY CapTexture2DMultisampleArray -> Just gl_TEXTURE_2D_MULTISAMPLE_ARRAY CapTextureCubeMapArray -> Just gl_TEXTURE_CUBE_MAP_ARRAY CapLineStipple -> Just gl_LINE_STIPPLE CapPolygonStipple -> Just gl_POLYGON_STIPPLE CapCullFace -> Just gl_CULL_FACE CapAlphaTest -> Just gl_ALPHA_TEST CapBlend -> Just gl_BLEND CapIndexLogicOp -> Just gl_INDEX_LOGIC_OP CapColorLogicOp -> Just gl_COLOR_LOGIC_OP CapDither -> Just gl_DITHER CapStencilTest -> Just gl_STENCIL_TEST CapDepthTest -> Just gl_DEPTH_TEST CapClipPlane i -> clipPlaneIndexToEnum i CapLight i -> lightIndexToEnum i CapTextureGenS -> Just gl_TEXTURE_GEN_S CapTextureGenT -> Just gl_TEXTURE_GEN_T CapTextureGenR -> Just gl_TEXTURE_GEN_R CapTextureGenQ -> Just gl_TEXTURE_GEN_Q CapMap1Vertex3 -> Just gl_MAP1_VERTEX_3 CapMap1Vertex4 -> Just gl_MAP1_VERTEX_4 CapMap1Color4 -> Just gl_MAP1_COLOR_4 CapMap1Index -> Just gl_MAP1_INDEX CapMap1Normal -> Just gl_MAP1_NORMAL CapMap1TextureCoord1 -> Just gl_MAP1_TEXTURE_COORD_1 CapMap1TextureCoord2 -> Just gl_MAP1_TEXTURE_COORD_2 CapMap1TextureCoord3 -> Just gl_MAP1_TEXTURE_COORD_3 CapMap1TextureCoord4 -> Just gl_MAP1_TEXTURE_COORD_4 CapMap2Vertex3 -> Just gl_MAP2_VERTEX_3 CapMap2Vertex4 -> Just gl_MAP2_VERTEX_4 CapMap2Color4 -> Just gl_MAP2_COLOR_4 CapMap2Index -> Just gl_MAP2_INDEX CapMap2Normal -> Just gl_MAP2_NORMAL CapMap2TextureCoord1 -> Just gl_MAP2_TEXTURE_COORD_1 CapMap2TextureCoord2 -> Just gl_MAP2_TEXTURE_COORD_2 CapMap2TextureCoord3 -> Just gl_MAP2_TEXTURE_COORD_3 CapMap2TextureCoord4 -> Just gl_MAP2_TEXTURE_COORD_4 CapPointSmooth -> Just gl_POINT_SMOOTH CapLineSmooth -> Just gl_LINE_SMOOTH CapPolygonSmooth -> Just gl_POLYGON_SMOOTH CapScissorTest -> Just gl_SCISSOR_TEST CapColorMaterial -> Just gl_COLOR_MATERIAL CapNormalize -> Just gl_NORMALIZE CapAutoNormal -> Just gl_AUTO_NORMAL CapPolygonOffsetPoint -> Just gl_POLYGON_OFFSET_POINT CapPolygonOffsetLine -> Just gl_POLYGON_OFFSET_LINE CapPolygonOffsetFill -> Just gl_POLYGON_OFFSET_FILL CapVertexArray -> Just gl_VERTEX_ARRAY CapNormalArray -> Just gl_NORMAL_ARRAY CapColorArray -> Just gl_COLOR_ARRAY CapIndexArray -> Just gl_INDEX_ARRAY CapTextureCoordArray -> Just gl_TEXTURE_COORD_ARRAY CapEdgeFlagArray -> Just gl_EDGE_FLAG_ARRAY CapFogCoordArray -> Just gl_FOG_COORD_ARRAY CapSecondaryColorArray -> Just gl_SECONDARY_COLOR_ARRAY CapMatrixIndexArray -> Just gl_MATRIX_INDEX_ARRAY_ARB CapConvolution1D -> Just gl_CONVOLUTION_1D CapConvolution2D -> Just gl_CONVOLUTION_2D CapSeparable2D -> Just gl_SEPARABLE_2D CapHistogram -> Just gl_HISTOGRAM CapMinmax -> Just gl_MINMAX CapRescaleNormal -> Just gl_RESCALE_NORMAL CapSharedTexturePalette -> Just gl_SHARED_TEXTURE_PALETTE_EXT CapMultisample -> Just gl_MULTISAMPLE CapSampleAlphaToCoverage -> Just gl_SAMPLE_ALPHA_TO_COVERAGE CapSampleAlphaToOne -> Just gl_SAMPLE_ALPHA_TO_ONE CapSampleCoverage -> Just gl_SAMPLE_COVERAGE CapColorTable -> Just gl_COLOR_TABLE CapPostConvolutionColorTable -> Just gl_POST_CONVOLUTION_COLOR_TABLE CapPostColorMatrixColorTable -> Just gl_POST_COLOR_MATRIX_COLOR_TABLE CapColorSum -> Just gl_COLOR_SUM CapWeightSumUnity -> Just gl_WEIGHT_SUM_UNITY_ARB CapVertexBlend -> Just gl_VERTEX_BLEND_ARB CapWeightArray -> Just gl_WEIGHT_ARRAY_ARB CapMatrixPalette -> Just gl_MATRIX_PALETTE_ARB CapDepthClamp -> Just gl_DEPTH_CLAMP CapDepthBoundsTest -> Just gl_DEPTH_BOUNDS_TEST_EXT CapPrimitiveRestart -> Just gl_PRIMITIVE_RESTART CapPointSprite -> Just gl_POINT_SPRITE CapStencilTestTwoSide -> Just gl_STENCIL_TEST_TWO_SIDE_EXT CapRasterPositionUnclipped -> Just gl_RASTER_POSITION_UNCLIPPED_IBM CapRasterizerDiscard -> Just gl_RASTERIZER_DISCARD CapTextureColorTable -> Just gl_TEXTURE_COLOR_TABLE_SGI CapVertexProgramPointSize -> Just gl_VERTEX_PROGRAM_POINT_SIZE CapVertexProgramTwoSide -> Just gl_VERTEX_PROGRAM_TWO_SIDE CapDebugOutput -> Just gl_DEBUG_OUTPUT CapDebugOutputSynchronous -> Just gl_DEBUG_OUTPUT_SYNCHRONOUS -------------------------------------------------------------------------------- makeCapability :: EnableCap -> StateVar Capability makeCapability cap = makeStateVar (isEnabled cap) (enable cap) -------------------------------------------------------------------------------- isEnabled :: EnableCap -> IO Capability isEnabled = maybe (do recordInvalidEnum; return Disabled) (fmap unmarshalCapability . glIsEnabled) . marshalEnableCap -------------------------------------------------------------------------------- enable :: EnableCap -> Capability -> IO () enable cap state = maybe recordInvalidEnum (f state) (marshalEnableCap cap) where f Disabled = glDisable f Enabled = glEnable -------------------------------------------------------------------------------- makeStateVarMaybe :: IO EnableCap -> IO a -> (a -> IO ()) -> StateVar (Maybe a) makeStateVarMaybe getCap getAct setAct = makeStateVar (getStateVarMaybe getCap getAct) (setStateVarMaybe getCap setAct) getStateVarMaybe :: IO EnableCap -> IO a -> IO (Maybe a) getStateVarMaybe getCap act = do capability <- fmap makeCapability getCap state <- get capability if state == Enabled then fmap Just act else return Nothing setStateVarMaybe :: IO EnableCap -> (a -> IO ()) -> Maybe a -> IO () setStateVarMaybe getCap act val = do capability <- fmap makeCapability getCap maybe (capability $= Disabled) (\x -> act x >> capability $= Enabled) val -------------------------------------------------------------------------------- data IndexedEnableCap = BlendI marshalIndexedEnableCap :: IndexedEnableCap -> Maybe GLenum marshalIndexedEnableCap x = case x of BlendI -> Just gl_BLEND makeIndexedCapability ::(a -> GLuint) -> IndexedEnableCap -> a -> StateVar Capability makeIndexedCapability f cap val = makeStateVar (isIndexedEnabled (f val) cap) (\state -> enableIndexed (f val) cap state) isIndexedEnabled :: GLuint -> IndexedEnableCap -> IO Capability isIndexedEnabled i = maybe (do recordInvalidEnum; return Disabled) (\cap -> fmap unmarshalCapability $ glIsEnabledi cap i) . marshalIndexedEnableCap enableIndexed :: GLuint -> IndexedEnableCap -> Capability -> IO () enableIndexed i cap state = maybe recordInvalidEnum (f state) (marshalIndexedEnableCap cap) where f Enabled = \c -> glEnablei c i f Disabled = \c -> glDisablei c i OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Shaders.hs0000644000000000000000000000251412521420345021064 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Shaders -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 7 (Programs and Shaders) of the OpenGL 4.4 -- specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Shaders ( module Graphics.Rendering.OpenGL.GL.Shaders.ShaderObjects, module Graphics.Rendering.OpenGL.GL.Shaders.ShaderBinaries, module Graphics.Rendering.OpenGL.GL.Shaders.ProgramObjects, module Graphics.Rendering.OpenGL.GL.Shaders.ProgramBinaries, module Graphics.Rendering.OpenGL.GL.Shaders.Attribs, module Graphics.Rendering.OpenGL.GL.Shaders.Uniform, module Graphics.Rendering.OpenGL.GL.Shaders.Limits ) where import Graphics.Rendering.OpenGL.GL.Shaders.ShaderObjects import Graphics.Rendering.OpenGL.GL.Shaders.ShaderBinaries import Graphics.Rendering.OpenGL.GL.Shaders.ProgramObjects import Graphics.Rendering.OpenGL.GL.Shaders.ProgramBinaries import Graphics.Rendering.OpenGL.GL.Shaders.Attribs import Graphics.Rendering.OpenGL.GL.Shaders.Uniform import Graphics.Rendering.OpenGL.GL.Shaders.Limits OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Fog.hs0000644000000000000000000001323112521420345020204 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Fog -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 3.10 (Fog) of the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Fog ( fog, FogMode(..), fogMode, fogColor, fogIndex, FogCoordSrc(..), fogCoordSrc, FogDistanceMode(..), fogDistanceMode ) where import Data.StateVar import Foreign.Marshal.Utils import Foreign.Ptr import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- fog :: StateVar Capability fog = makeCapability CapFog -------------------------------------------------------------------------------- data FogParameter = FogIndex | FogDensity | FogStart | FogEnd | FogMode | FogColor | FogCoordSrc | FogDistanceMode marshalFogParameter :: FogParameter -> GLenum marshalFogParameter x = case x of FogIndex -> gl_FOG_INDEX FogDensity -> gl_FOG_DENSITY FogStart -> gl_FOG_START FogEnd -> gl_FOG_END FogMode -> gl_FOG_MODE FogColor -> gl_FOG_COLOR FogCoordSrc -> gl_FOG_COORD_SRC FogDistanceMode -> gl_FOG_DISTANCE_MODE_NV -------------------------------------------------------------------------------- data FogMode' = Linear' | Exp' | Exp2' marshalFogMode' :: FogMode' -> GLint marshalFogMode' x = fromIntegral $ case x of Linear' -> gl_LINEAR Exp' -> gl_EXP Exp2' -> gl_EXP2 unmarshalFogMode' :: GLint -> FogMode' unmarshalFogMode' x | y == gl_LINEAR = Linear' | y == gl_EXP = Exp' | y == gl_EXP2 = Exp2' | otherwise = error ("unmarshalFogMode': illegal value " ++ show x) where y = fromIntegral x -------------------------------------------------------------------------------- data FogMode = Linear GLfloat GLfloat | Exp GLfloat | Exp2 GLfloat deriving ( Eq, Ord, Show ) -------------------------------------------------------------------------------- fogMode :: StateVar FogMode fogMode = makeStateVar getFogMode setFogMode getFogMode :: IO FogMode getFogMode = do mode <- getInteger1 unmarshalFogMode' GetFogMode case mode of Linear' -> do start <- getFloat1 id GetFogStart end <- getFloat1 id GetFogEnd return $ Linear start end Exp' -> getFloat1 Exp GetFogDensity Exp2' -> getFloat1 Exp2 GetFogDensity setFogMode :: FogMode -> IO () setFogMode (Linear start end) = do fogi FogMode (marshalFogMode' Linear') fogf FogStart start fogf FogEnd end setFogMode (Exp density) = do fogi FogMode (marshalFogMode' Exp') fogf FogDensity density setFogMode (Exp2 density) = do fogi FogMode (marshalFogMode' Exp2') fogf FogDensity density -------------------------------------------------------------------------------- fogi :: FogParameter -> GLint -> IO () fogi = glFogi . marshalFogParameter fogf :: FogParameter -> GLfloat -> IO () fogf = glFogf . marshalFogParameter fogfv :: FogParameter -> Ptr (Color4 GLfloat) -> IO () fogfv param ptr = glFogfv (marshalFogParameter param) (castPtr ptr) -------------------------------------------------------------------------------- fogColor :: StateVar (Color4 GLclampf) fogColor = makeStateVar (getClampf4 Color4 GetFogColor) (\c -> with c $ (fogfv FogColor . castPtr)) -------------------------------------------------------------------------------- fogIndex :: StateVar (Index1 GLint) fogIndex = makeStateVar (getInteger1 Index1 GetFogIndex) (\(Index1 i) -> fogi FogIndex i) -------------------------------------------------------------------------------- data FogCoordSrc = FogCoord | FragmentDepth deriving ( Eq, Ord, Show ) marshalFogCoordSrc :: FogCoordSrc -> GLint marshalFogCoordSrc x = fromIntegral $ case x of FogCoord -> gl_FOG_COORD FragmentDepth -> gl_FRAGMENT_DEPTH unmarshalFogCoordSrc :: GLint -> FogCoordSrc unmarshalFogCoordSrc x | y == gl_FOG_COORD = FogCoord | y == gl_FRAGMENT_DEPTH = FragmentDepth | otherwise = error ("unmarshalFogCoordSrc: illegal value " ++ show x) where y = fromIntegral x -------------------------------------------------------------------------------- fogCoordSrc :: StateVar FogCoordSrc fogCoordSrc = makeStateVar (getInteger1 unmarshalFogCoordSrc GetFogCoordSrc) (fogi FogCoordSrc . marshalFogCoordSrc) -------------------------------------------------------------------------------- data FogDistanceMode = EyeRadial | EyePlaneSigned | EyePlaneAbsolute deriving ( Eq, Ord, Show ) marshalFogDistanceMode :: FogDistanceMode -> GLint marshalFogDistanceMode x = fromIntegral $ case x of EyeRadial -> gl_EYE_RADIAL_NV EyePlaneSigned ->gl_EYE_PLANE EyePlaneAbsolute -> gl_EYE_PLANE_ABSOLUTE_NV unmarshalFogDistanceMode :: GLint -> FogDistanceMode unmarshalFogDistanceMode x | y == gl_EYE_RADIAL_NV = EyeRadial | y == gl_EYE_PLANE = EyePlaneSigned | y == gl_EYE_PLANE_ABSOLUTE_NV = EyePlaneAbsolute | otherwise = error ("unmarshalFogDistanceMode: illegal value " ++ show x) where y = fromIntegral x -------------------------------------------------------------------------------- fogDistanceMode :: StateVar FogDistanceMode fogDistanceMode = makeStateVar (getInteger1 unmarshalFogDistanceMode GetFogDistanceMode) (fogi FogDistanceMode . marshalFogDistanceMode) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/GLboolean.hs0000644000000000000000000000165412521420345021341 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.GLboolean -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for (un-)marshaling GLboolean. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.GLboolean ( marshalGLboolean, unmarshalGLboolean ) where import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- marshalGLboolean :: Num a => Bool -> a marshalGLboolean x = fromIntegral $ case x of False -> gl_FALSE True -> gl_TRUE unmarshalGLboolean :: (Eq a, Num a) => a -> Bool unmarshalGLboolean = (/= fromIntegral gl_FALSE) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PolygonMode.hs0000644000000000000000000000223612521420345021730 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PolygonMode -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for (un-)marshaling PolygonMode. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PolygonMode ( PolygonMode(..), marshalPolygonMode, unmarshalPolygonMode ) where import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data PolygonMode = Point | Line | Fill deriving ( Eq, Ord, Show ) marshalPolygonMode :: PolygonMode -> GLenum marshalPolygonMode x = case x of Point -> gl_POINT Line -> gl_LINE Fill -> gl_FILL unmarshalPolygonMode :: GLenum -> PolygonMode unmarshalPolygonMode x | x == gl_POINT = Point | x == gl_LINE = Line | x == gl_FILL = Fill | otherwise = error ("unmarshalPolygonMode: illegal value " ++ show x) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Hints.hs0000644000000000000000000000513212521420345020557 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Hints -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 5.6 (Hints) of the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Hints ( HintTarget(..), HintMode(..), hint ) where import Data.StateVar import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data HintTarget = PerspectiveCorrection | PointSmooth | LineSmooth | PolygonSmooth | Fog | GenerateMipmap | TextureCompression | PackCMYK | UnpackCMYK deriving ( Eq, Ord, Show ) marshalHintTarget :: HintTarget -> GLenum marshalHintTarget x = case x of PerspectiveCorrection -> gl_PERSPECTIVE_CORRECTION_HINT PointSmooth -> gl_POINT_SMOOTH_HINT LineSmooth -> gl_LINE_SMOOTH_HINT PolygonSmooth -> gl_POLYGON_SMOOTH_HINT Fog -> gl_FOG_HINT GenerateMipmap -> gl_GENERATE_MIPMAP_HINT TextureCompression -> gl_TEXTURE_COMPRESSION_HINT PackCMYK -> gl_PACK_CMYK_HINT_EXT UnpackCMYK -> gl_UNPACK_CMYK_HINT_EXT hintTargetToGetPName :: HintTarget -> PName1I hintTargetToGetPName x = case x of PerspectiveCorrection -> GetPerspectiveCorrectionHint PointSmooth -> GetPointSmoothHint LineSmooth -> GetLineSmoothHint PolygonSmooth -> GetPolygonSmoothHint Fog -> GetFogHint GenerateMipmap -> GetGenerateMipmapHint TextureCompression -> GetTextureCompressionHint PackCMYK -> GetPackCMYKHint UnpackCMYK -> GetUnpackCMYKHint -------------------------------------------------------------------------------- data HintMode = DontCare | Fastest | Nicest deriving ( Eq, Ord, Show ) marshalHintMode :: HintMode -> GLenum marshalHintMode x = case x of DontCare -> gl_DONT_CARE Fastest -> gl_FASTEST Nicest -> gl_NICEST unmarshalHintMode :: GLenum -> HintMode unmarshalHintMode x | x == gl_DONT_CARE = DontCare | x == gl_FASTEST = Fastest | x == gl_NICEST = Nicest | otherwise = error ("unmarshalHintMode: illegal value " ++ show x) -------------------------------------------------------------------------------- hint :: HintTarget -> StateVar HintMode hint t = makeStateVar (getEnum1 unmarshalHintMode (hintTargetToGetPName t)) (glHint (marshalHintTarget t) . marshalHintMode) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/QueryObject.hs0000644000000000000000000000332212521420345021725 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.QueryObject -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for handling QueryObjects. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.QueryObject ( QueryObject(..), noQueryObject ) where import Control.Monad.IO.Class import Data.ObjectName import Foreign.Marshal.Array ( allocaArray, peekArray, withArrayLen ) import Graphics.Rendering.OpenGL.GL.DebugOutput import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- newtype QueryObject = QueryObject { queryID :: GLuint } deriving ( Eq, Ord, Show ) noQueryObject :: QueryObject noQueryObject = QueryObject 0 -------------------------------------------------------------------------------- instance ObjectName QueryObject where isObjectName = liftIO . fmap unmarshalGLboolean . glIsQuery . queryID deleteObjectNames queryObjects = liftIO . withArrayLen (map queryID queryObjects) $ glDeleteQueries . fromIntegral instance GeneratableObjectName QueryObject where genObjectNames n = liftIO . allocaArray n $ \buf -> do glGenQueries (fromIntegral n) buf fmap (map QueryObject) $ peekArray n buf instance CanBeLabeled QueryObject where objectLabel = objectNameLabel gl_QUERY . queryID OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Colors.hs0000644000000000000000000004275112521420345020743 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Colors -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 2.14 (Colors and Coloring) of the -- OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Colors ( -- * Lighting lighting, Light(..), light, maxLights, FrontFaceDirection(..), frontFace, -- * Lighting Parameter Specification Face(..), materialAmbient, materialDiffuse, materialAmbientAndDiffuse, materialSpecular, materialEmission, materialShininess, maxShininess, materialColorIndexes, ambient, diffuse, specular, position, spotDirection, spotExponent, maxSpotExponent, spotCutoff, attenuation, lightModelAmbient, lightModelLocalViewer, lightModelTwoSide, vertexProgramTwoSide, LightModelColorControl(..), lightModelColorControl, -- * ColorMaterial ColorMaterialParameter(..), colorMaterial, -- * Flatshading ShadingModel(..), shadeModel, -- * Color clamping ClampTarget(..), ClampMode(..), clampColor, ) where import Control.Monad import Data.StateVar import Foreign.Marshal.Alloc import Foreign.Marshal.Array import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.GL.Tensor import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.Face import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- lighting :: StateVar Capability lighting = makeCapability CapLighting -------------------------------------------------------------------------------- newtype Light = Light GLsizei deriving ( Eq, Ord, Show ) marshalLight :: Light -> Maybe GLenum marshalLight (Light l) = lightIndexToEnum l -------------------------------------------------------------------------------- light :: Light -> StateVar Capability light (Light l) = makeCapability (CapLight l) maxLights :: GettableStateVar GLsizei maxLights = makeGettableStateVar (getSizei1 id GetMaxLights) -------------------------------------------------------------------------------- data FrontFaceDirection = CW | CCW deriving ( Eq, Ord, Show ) marshalFrontFaceDirection :: FrontFaceDirection -> GLenum marshalFrontFaceDirection x = case x of CW -> gl_CW CCW -> gl_CCW unmarshalFrontFaceDirection :: GLenum -> FrontFaceDirection unmarshalFrontFaceDirection x | x == gl_CW = CW | x == gl_CCW = CCW | otherwise = error ("unmarshalFrontFaceDirection: illegal value " ++ show x) -------------------------------------------------------------------------------- frontFace :: StateVar FrontFaceDirection frontFace = makeStateVar (getEnum1 unmarshalFrontFaceDirection GetFrontFace) (glFrontFace . marshalFrontFaceDirection) -------------------------------------------------------------------------------- data MaterialParameter = MaterialEmission | MaterialShininess | MaterialAmbientAndDiffuse | MaterialColorIndexes | MaterialAmbient | MaterialDiffuse | MaterialSpecular marshalMaterialParameter :: MaterialParameter -> GLenum marshalMaterialParameter x = case x of MaterialEmission -> gl_EMISSION MaterialShininess -> gl_SHININESS MaterialAmbientAndDiffuse -> gl_AMBIENT_AND_DIFFUSE MaterialColorIndexes -> gl_COLOR_INDEXES MaterialAmbient -> gl_AMBIENT MaterialDiffuse -> gl_DIFFUSE MaterialSpecular -> gl_SPECULAR -------------------------------------------------------------------------------- materialAmbient :: Face -> StateVar (Color4 GLfloat) materialAmbient = makeMaterialVar glGetMaterialfvc glMaterialfvc MaterialAmbient materialDiffuse :: Face -> StateVar (Color4 GLfloat) materialDiffuse = makeMaterialVar glGetMaterialfvc glMaterialfvc MaterialDiffuse materialAmbientAndDiffuse :: Face -> StateVar (Color4 GLfloat) materialAmbientAndDiffuse = makeMaterialVar glGetMaterialfvc glMaterialfvc MaterialAmbientAndDiffuse materialSpecular :: Face -> StateVar (Color4 GLfloat) materialSpecular = makeMaterialVar glGetMaterialfvc glMaterialfvc MaterialSpecular materialEmission :: Face -> StateVar (Color4 GLfloat) materialEmission = makeMaterialVar glGetMaterialfvc glMaterialfvc MaterialEmission makeMaterialVar :: Storable a => (GLenum -> GLenum -> Ptr a -> IO ()) -> (GLenum -> GLenum -> Ptr a -> IO ()) -> MaterialParameter -> Face -> StateVar a makeMaterialVar getter setter materialParameter face = makeStateVar (alloca $ \buf -> do getter f mp buf ; peek buf) (\val -> with val $ setter f mp) where mp = marshalMaterialParameter materialParameter f = marshalFace face glGetMaterialfvc :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO () glGetMaterialfvc face pname ptr = glGetMaterialfv face pname (castPtr ptr) glMaterialfvc :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO () glMaterialfvc face pname ptr = glMaterialfv face pname (castPtr ptr) -------------------------------------------------------------------------------- materialShininess :: Face -> StateVar GLfloat materialShininess = makeMaterialVar glGetMaterialfvf glMaterialff MaterialShininess glGetMaterialfvf :: GLenum -> GLenum -> Ptr GLfloat -> IO () glGetMaterialfvf face pname ptr = glGetMaterialfv face pname (castPtr ptr) glMaterialff :: GLenum -> GLenum -> Ptr GLfloat -> IO () glMaterialff face pname ptr = glMaterialfv face pname (castPtr ptr) maxShininess :: GettableStateVar GLfloat maxShininess = makeGettableStateVar $ getFloat1 id GetMaxShininess -------------------------------------------------------------------------------- -- Alas, (Index1 GLint, Index1 GLint, Index1 GLint) is not an instance of -- Storable... materialColorIndexes :: Face -> StateVar (Index1 GLint, Index1 GLint, Index1 GLint) materialColorIndexes face = makeStateVar (getMaterialColorIndexes face) (setMaterialColorIndexes face) getMaterialColorIndexes :: Face -> IO (Index1 GLint, Index1 GLint, Index1 GLint) getMaterialColorIndexes face = allocaArray 3 $ \buf -> do glGetMaterialiv (marshalFace face) (marshalMaterialParameter MaterialColorIndexes) buf peek3 (\a d s -> (Index1 a, Index1 d, Index1 s)) buf setMaterialColorIndexes :: Face -> (Index1 GLint, Index1 GLint, Index1 GLint) -> IO () setMaterialColorIndexes face (Index1 a, Index1 d, Index1 s) = withArray [a, d, s] $ glMaterialiv (marshalFace face) (marshalMaterialParameter MaterialColorIndexes) -------------------------------------------------------------------------------- data LightParameter = Ambient' | Diffuse' | Specular' | Position | SpotDirection | SpotExponent | SpotCutoff | ConstantAttenuation | LinearAttenuation | QuadraticAttenuation marshalLightParameter :: LightParameter -> GLenum marshalLightParameter x = case x of Ambient' -> gl_AMBIENT Diffuse' -> gl_DIFFUSE Specular' -> gl_SPECULAR Position -> gl_POSITION SpotDirection -> gl_SPOT_DIRECTION SpotExponent -> gl_SPOT_EXPONENT SpotCutoff -> gl_SPOT_CUTOFF ConstantAttenuation -> gl_CONSTANT_ATTENUATION LinearAttenuation -> gl_LINEAR_ATTENUATION QuadraticAttenuation -> gl_QUADRATIC_ATTENUATION -------------------------------------------------------------------------------- ambient :: Light -> StateVar (Color4 GLfloat) ambient = makeLightVar glGetLightfvc glLightfvc Ambient' black black :: Color4 GLfloat black = Color4 0 0 0 0 diffuse :: Light -> StateVar (Color4 GLfloat) diffuse = makeLightVar glGetLightfvc glLightfvc Diffuse' black specular :: Light -> StateVar (Color4 GLfloat) specular = makeLightVar glGetLightfvc glLightfvc Specular' black makeLightVar :: Storable a => (GLenum -> GLenum -> Ptr a -> IO ()) -> (GLenum -> GLenum -> Ptr a -> IO ()) -> LightParameter -> a -> Light -> StateVar a makeLightVar getter setter lightParameter defaultValue theLight = makeStateVar (maybe (return defaultValue) getLightVar ml) (\val -> maybe recordInvalidEnum (setLightVar val) ml) where lp = marshalLightParameter lightParameter ml = marshalLight theLight getLightVar = \l -> alloca $ \buf -> do getter l lp buf ; peek buf setLightVar = \val l -> with val $ setter l lp glGetLightfvc :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO () glGetLightfvc l pname ptr = glGetLightfv l pname (castPtr ptr) glLightfvc :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO () glLightfvc l pname ptr = glLightfv l pname (castPtr ptr) -------------------------------------------------------------------------------- position :: Light -> StateVar (Vertex4 GLfloat) position = makeLightVar glGetLightfvv glLightfvv Position (Vertex4 0 0 0 0) glLightfvv :: GLenum -> GLenum -> Ptr (Vertex4 GLfloat) -> IO () glLightfvv l pname ptr = glLightfv l pname (castPtr ptr) glGetLightfvv :: GLenum -> GLenum -> Ptr (Vertex4 GLfloat) -> IO () glGetLightfvv l pname ptr = glGetLightfv l pname (castPtr ptr) -------------------------------------------------------------------------------- spotDirection :: Light -> StateVar (Normal3 GLfloat) spotDirection = makeLightVar glGetLightfvn glLightfvn SpotDirection (Normal3 0 0 0) glLightfvn :: GLenum -> GLenum -> Ptr (Normal3 GLfloat) -> IO () glLightfvn l pname ptr = glLightfv l pname (castPtr ptr) glGetLightfvn :: GLenum -> GLenum -> Ptr (Normal3 GLfloat) -> IO () glGetLightfvn l pname ptr = glGetLightfv l pname (castPtr ptr) -------------------------------------------------------------------------------- spotExponent :: Light -> StateVar GLfloat spotExponent = makeLightVar glGetLightfv glLightfv SpotExponent 0 maxSpotExponent :: GettableStateVar GLfloat maxSpotExponent = makeGettableStateVar $ getFloat1 id GetMaxSpotExponent -------------------------------------------------------------------------------- spotCutoff :: Light -> StateVar GLfloat spotCutoff = makeLightVar glGetLightfv glLightfv SpotCutoff 0 -------------------------------------------------------------------------------- attenuation :: Light -> StateVar (GLfloat, GLfloat, GLfloat) attenuation theLight = makeStateVar (liftM3 (,,) (get (constantAttenuation theLight)) (get (linearAttenuation theLight)) (get (quadraticAttenuation theLight))) (\(constant, linear, quadratic) -> do constantAttenuation theLight $= constant linearAttenuation theLight $= linear quadraticAttenuation theLight $= quadratic) constantAttenuation :: Light -> StateVar GLfloat constantAttenuation = makeLightVar glGetLightfv glLightfv ConstantAttenuation 0 linearAttenuation :: Light -> StateVar GLfloat linearAttenuation = makeLightVar glGetLightfv glLightfv LinearAttenuation 0 quadraticAttenuation :: Light -> StateVar GLfloat quadraticAttenuation = makeLightVar glGetLightfv glLightfv QuadraticAttenuation 0 -------------------------------------------------------------------------------- data LightModelParameter = LightModelAmbient | LightModelLocalViewer | LightModelTwoSide | LightModelColorControl marshalLightModelParameter :: LightModelParameter -> GLenum marshalLightModelParameter x = case x of LightModelAmbient -> gl_LIGHT_MODEL_AMBIENT LightModelLocalViewer -> gl_LIGHT_MODEL_LOCAL_VIEWER LightModelTwoSide -> gl_LIGHT_MODEL_TWO_SIDE LightModelColorControl -> gl_LIGHT_MODEL_COLOR_CONTROL -------------------------------------------------------------------------------- lightModelAmbient :: StateVar (Color4 GLfloat) lightModelAmbient = makeStateVar (getFloat4 Color4 GetLightModelAmbient) (\c -> with c $ glLightModelfv (marshalLightModelParameter LightModelAmbient) . castPtr) -------------------------------------------------------------------------------- lightModelLocalViewer :: StateVar Capability lightModelLocalViewer = makeLightModelCapVar GetLightModelLocalViewer LightModelLocalViewer makeLightModelCapVar :: PName1I -> LightModelParameter -> StateVar Capability makeLightModelCapVar pname lightModelParameter = makeStateVar (getBoolean1 unmarshalCapability pname) (glLightModeli (marshalLightModelParameter lightModelParameter) . fromIntegral . marshalCapability) -------------------------------------------------------------------------------- lightModelTwoSide :: StateVar Capability lightModelTwoSide = makeLightModelCapVar GetLightModelTwoSide LightModelTwoSide vertexProgramTwoSide :: StateVar Capability vertexProgramTwoSide = makeCapability CapVertexProgramTwoSide -------------------------------------------------------------------------------- data LightModelColorControl = SingleColor | SeparateSpecularColor deriving ( Eq, Ord, Show ) marshalLightModelColorControl :: LightModelColorControl -> GLenum marshalLightModelColorControl x = case x of SingleColor -> gl_SINGLE_COLOR SeparateSpecularColor -> gl_SEPARATE_SPECULAR_COLOR unmarshalLightModelColorControl :: GLenum -> LightModelColorControl unmarshalLightModelColorControl x | x == gl_SINGLE_COLOR = SingleColor | x == gl_SEPARATE_SPECULAR_COLOR = SeparateSpecularColor | otherwise = error ("unmarshalLightModelColorControl: illegal value " ++ show x) -------------------------------------------------------------------------------- lightModelColorControl :: StateVar LightModelColorControl lightModelColorControl = makeStateVar (getEnum1 unmarshalLightModelColorControl GetLightModelColorControl) (glLightModeli (marshalLightModelParameter LightModelColorControl) . fromIntegral . marshalLightModelColorControl) -------------------------------------------------------------------------------- data ColorMaterialParameter = Ambient | Diffuse | Specular | Emission | AmbientAndDiffuse deriving ( Eq, Ord, Show ) marshalColorMaterialParameter :: ColorMaterialParameter -> GLenum marshalColorMaterialParameter x = case x of Ambient -> gl_AMBIENT Diffuse -> gl_DIFFUSE Specular -> gl_SPECULAR Emission -> gl_EMISSION AmbientAndDiffuse -> gl_AMBIENT_AND_DIFFUSE unmarshalColorMaterialParameter :: GLenum -> ColorMaterialParameter unmarshalColorMaterialParameter x | x == gl_AMBIENT = Ambient | x == gl_DIFFUSE = Diffuse | x == gl_SPECULAR = Specular | x == gl_EMISSION = Emission | x == gl_AMBIENT_AND_DIFFUSE = AmbientAndDiffuse | otherwise = error ("unmarshalColorMaterialParameter: illegal value " ++ show x) -------------------------------------------------------------------------------- colorMaterial :: StateVar (Maybe (Face, ColorMaterialParameter)) colorMaterial = makeStateVarMaybe (return CapColorMaterial) (liftM2 (,) (getEnum1 unmarshalFace GetColorMaterialFace) (getEnum1 unmarshalColorMaterialParameter GetColorMaterialParameter)) (\(face, param) -> glColorMaterial (marshalFace face) (marshalColorMaterialParameter param)) -------------------------------------------------------------------------------- data ShadingModel = Flat | Smooth deriving ( Eq, Ord, Show ) marshalShadingModel :: ShadingModel -> GLenum marshalShadingModel x = case x of Flat -> gl_FLAT Smooth -> gl_SMOOTH unmarshalShadingModel :: GLenum -> ShadingModel unmarshalShadingModel x | x == gl_FLAT = Flat | x == gl_SMOOTH = Smooth | otherwise = error ("unmarshalShadingModel: illegal value " ++ show x) -------------------------------------------------------------------------------- shadeModel :: StateVar ShadingModel shadeModel = makeStateVar (getEnum1 unmarshalShadingModel GetShadeModel) (glShadeModel . marshalShadingModel) -------------------------------------------------------------------------------- data ClampTarget = ClampVertexColor | ClampFragmentColor | ClampReadColor deriving ( Eq, Ord, Show ) marshalClampTarget :: ClampTarget -> GLenum marshalClampTarget x = case x of ClampVertexColor -> gl_CLAMP_VERTEX_COLOR ClampFragmentColor -> gl_CLAMP_FRAGMENT_COLOR ClampReadColor -> gl_CLAMP_READ_COLOR marshalClampTargetToPName :: ClampTarget -> PName1I marshalClampTargetToPName x = case x of ClampFragmentColor -> GetFragmentColorClamp ClampVertexColor -> GetVertexColorClamp ClampReadColor -> GetReadColorClamp -------------------------------------------------------------------------------- data ClampMode = ClampOn | FixedOnly | ClampOff deriving ( Eq, Ord, Show ) marshalClampMode :: ClampMode -> GLenum marshalClampMode x = case x of ClampOn -> gl_TRUE FixedOnly -> gl_FIXED_ONLY ClampOff -> gl_FALSE unmarshalClampMode :: GLenum -> ClampMode unmarshalClampMode x | x == gl_TRUE = ClampOn | x == gl_FIXED_ONLY = FixedOnly | x == gl_FALSE = ClampOff | otherwise = error $ "unmarshalClampMode: unknown enum value " ++ show x -------------------------------------------------------------------------------- clampColor :: ClampTarget -> StateVar ClampMode clampColor ct = makeStateVar (getClampColor ct) (setClampColor ct) where getClampColor = getEnum1 unmarshalClampMode . marshalClampTargetToPName setClampColor t = glClampColor (marshalClampTarget t) . marshalClampMode OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/BufferObjects.hs0000644000000000000000000004014012521420345022213 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.BufferObjects -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 2.9 (Buffer Objects) of the OpenGL 2.1 -- specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.BufferObjects ( -- * Buffer Objects BufferObject, -- * Binding Buffer Objects BufferTarget(..), bindBuffer, arrayBufferBinding, vertexAttribArrayBufferBinding, -- * Handling Buffer Data BufferUsage(..), bufferData, TransferDirection(..), bufferSubData, -- * Mapping Buffer Objects BufferAccess(..), MappingFailure(..), withMappedBuffer, mapBuffer, unmapBuffer, bufferAccess, bufferMapped, MapBufferUsage(..), Offset, Length, mapBufferRange, flushMappedBufferRange, -- * Indexed Buffer manipulation BufferIndex, RangeStartIndex, RangeSize, BufferRange, IndexedBufferTarget(..), bindBufferBase, bindBufferRange, indexedBufferStart, indexedBufferSize ) where import Control.Monad.IO.Class import Data.Maybe ( fromMaybe ) import Data.ObjectName import Data.StateVar import Foreign.Marshal.Array ( allocaArray, peekArray, withArrayLen ) import Foreign.Marshal.Utils ( with ) import Foreign.Ptr ( Ptr, nullPtr ) import Graphics.Rendering.OpenGL.GL.DebugOutput import Graphics.Rendering.OpenGL.GL.Exception import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.VertexArrays import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- newtype BufferObject = BufferObject { bufferID :: GLuint } deriving ( Eq, Ord, Show ) -------------------------------------------------------------------------------- instance ObjectName BufferObject where isObjectName = liftIO . fmap unmarshalGLboolean . glIsBuffer . bufferID deleteObjectNames bufferObjects = liftIO . withArrayLen (map bufferID bufferObjects) $ glDeleteBuffers . fromIntegral instance GeneratableObjectName BufferObject where genObjectNames n = liftIO . allocaArray n $ \buf -> do glGenBuffers (fromIntegral n) buf fmap (map BufferObject) $ peekArray n buf instance CanBeLabeled BufferObject where objectLabel = objectNameLabel gl_BUFFER . bufferID -------------------------------------------------------------------------------- data BufferTarget = ArrayBuffer | AtomicCounterBuffer | CopyReadBuffer | CopyWriteBuffer | DispatchIndirectBuffer | DrawIndirectBuffer | ElementArrayBuffer | PixelPackBuffer | PixelUnpackBuffer | QueryBuffer | ShaderStorageBuffer | TextureBuffer | TransformFeedbackBuffer | UniformBuffer deriving ( Eq, Ord, Show ) marshalBufferTarget :: BufferTarget -> GLenum marshalBufferTarget x = case x of ArrayBuffer -> gl_ARRAY_BUFFER AtomicCounterBuffer -> gl_ATOMIC_COUNTER_BUFFER CopyReadBuffer -> gl_COPY_READ_BUFFER CopyWriteBuffer -> gl_COPY_WRITE_BUFFER DispatchIndirectBuffer -> gl_DISPATCH_INDIRECT_BUFFER DrawIndirectBuffer -> gl_DRAW_INDIRECT_BUFFER ElementArrayBuffer -> gl_ELEMENT_ARRAY_BUFFER PixelPackBuffer -> gl_PIXEL_PACK_BUFFER PixelUnpackBuffer -> gl_PIXEL_UNPACK_BUFFER QueryBuffer -> gl_QUERY_BUFFER ShaderStorageBuffer -> gl_SHADER_STORAGE_BUFFER TextureBuffer -> gl_TEXTURE_BUFFER TransformFeedbackBuffer -> gl_TRANSFORM_FEEDBACK_BUFFER UniformBuffer -> gl_UNIFORM_BUFFER bufferTargetToGetPName :: BufferTarget -> PName1I bufferTargetToGetPName x = case x of ArrayBuffer -> GetArrayBufferBinding AtomicCounterBuffer -> GetAtomicCounterBufferBinding CopyReadBuffer -> GetCopyReadBufferBinding CopyWriteBuffer -> GetCopyWriteBufferBinding DispatchIndirectBuffer -> GetDispatchIndirectBufferBinding DrawIndirectBuffer -> GetDrawIndirectBufferBinding ElementArrayBuffer -> GetElementArrayBufferBinding PixelPackBuffer -> GetPixelPackBufferBinding PixelUnpackBuffer -> GetPixelUnpackBufferBinding QueryBuffer -> GetQueryBufferBinding ShaderStorageBuffer -> GetShaderStorageBufferBinding TextureBuffer -> GetTextureBindingBuffer TransformFeedbackBuffer -> GetTransformFeedbackBufferBinding UniformBuffer -> GetUniformBufferBinding -------------------------------------------------------------------------------- data BufferUsage = StreamDraw | StreamRead | StreamCopy | StaticDraw | StaticRead | StaticCopy | DynamicDraw | DynamicRead | DynamicCopy deriving ( Eq, Ord, Show ) marshalBufferUsage :: BufferUsage -> GLenum marshalBufferUsage x = case x of StreamDraw -> gl_STREAM_DRAW StreamRead -> gl_STREAM_READ StreamCopy -> gl_STREAM_COPY StaticDraw -> gl_STATIC_DRAW StaticRead -> gl_STATIC_READ StaticCopy -> gl_STATIC_COPY DynamicDraw -> gl_DYNAMIC_DRAW DynamicRead -> gl_DYNAMIC_READ DynamicCopy -> gl_DYNAMIC_COPY unmarshalBufferUsage :: GLenum -> BufferUsage unmarshalBufferUsage x | x == gl_STREAM_DRAW = StreamDraw | x == gl_STREAM_READ = StreamRead | x == gl_STREAM_COPY = StreamCopy | x == gl_STATIC_DRAW = StaticDraw | x == gl_STATIC_READ = StaticRead | x == gl_STATIC_COPY = StaticCopy | x == gl_DYNAMIC_DRAW = DynamicDraw | x == gl_DYNAMIC_READ = DynamicRead | x == gl_DYNAMIC_COPY = DynamicCopy | otherwise = error ("unmarshalBufferUsage: illegal value " ++ show x) -------------------------------------------------------------------------------- data BufferAccess = ReadOnly | WriteOnly | ReadWrite deriving ( Eq, Ord, Show ) marshalBufferAccess :: BufferAccess -> GLenum marshalBufferAccess x = case x of ReadOnly -> gl_READ_ONLY WriteOnly -> gl_WRITE_ONLY ReadWrite -> gl_READ_WRITE unmarshalBufferAccess :: GLenum -> BufferAccess unmarshalBufferAccess x | x == gl_READ_ONLY = ReadOnly | x == gl_WRITE_ONLY = WriteOnly | x == gl_READ_WRITE = ReadWrite | otherwise = error ("unmarshalBufferAccess: illegal value " ++ show x) -------------------------------------------------------------------------------- bindBuffer :: BufferTarget -> StateVar (Maybe BufferObject) bindBuffer t = makeStateVar (getBindBuffer t) (setBindBuffer t) getBindBuffer :: BufferTarget -> IO (Maybe BufferObject) getBindBuffer = bufferQuery bufferTargetToGetPName bufferQuery :: (a -> PName1I) -> a -> IO (Maybe BufferObject) bufferQuery func t = do buf <- getInteger1 (BufferObject . fromIntegral) (func t) return $ if buf == noBufferObject then Nothing else Just buf noBufferObject :: BufferObject noBufferObject = BufferObject 0 setBindBuffer :: BufferTarget -> Maybe BufferObject -> IO () setBindBuffer t = glBindBuffer (marshalBufferTarget t) . bufferID . fromMaybe noBufferObject clientArrayTypeToGetPName :: ClientArrayType -> PName1I clientArrayTypeToGetPName x = case x of VertexArray -> GetVertexArrayBufferBinding NormalArray -> GetNormalArrayBufferBinding ColorArray -> GetColorArrayBufferBinding IndexArray -> GetIndexArrayBufferBinding TextureCoordArray -> GetTextureCoordArrayBufferBinding EdgeFlagArray -> GetEdgeFlagArrayBufferBinding FogCoordArray -> GetFogCoordArrayBufferBinding SecondaryColorArray -> GetSecondaryColorArrayBufferBinding MatrixIndexArray -> error "clientArrayTypeToGetPName: impossible" arrayBufferBinding :: ClientArrayType -> GettableStateVar (Maybe BufferObject) arrayBufferBinding t = makeGettableStateVar $ case t of MatrixIndexArray -> do recordInvalidEnum ; return Nothing _ -> bufferQuery clientArrayTypeToGetPName t vertexAttribArrayBufferBinding :: AttribLocation -> GettableStateVar (Maybe BufferObject) vertexAttribArrayBufferBinding location = makeGettableStateVar $ do buf <- getVertexAttribInteger1 (BufferObject . fromIntegral) location GetVertexAttribArrayBufferBinding return $ if buf == noBufferObject then Nothing else Just buf -------------------------------------------------------------------------------- bufferData :: BufferTarget -> StateVar (GLsizeiptr, Ptr a, BufferUsage) bufferData t = makeStateVar (getBufferData t) (setBufferData t) getBufferData :: BufferTarget -> IO (GLsizeiptr, Ptr a, BufferUsage) getBufferData t = do s <- getBufferParameter t fromIntegral GetBufferSize p <- getBufferPointer t u <- getBufferParameter t unmarshalBufferUsage GetBufferUsage return (s, p, u) setBufferData :: BufferTarget -> (GLsizeiptr, Ptr a, BufferUsage) -> IO () setBufferData t (s, p, u) = glBufferData (marshalBufferTarget t) s p (marshalBufferUsage u) -------------------------------------------------------------------------------- data TransferDirection = ReadFromBuffer | WriteToBuffer deriving ( Eq, Ord, Show ) bufferSubData :: BufferTarget -> TransferDirection -> GLintptr -> GLsizeiptr -> Ptr a -> IO () bufferSubData t WriteToBuffer = glBufferSubData (marshalBufferTarget t) bufferSubData t ReadFromBuffer = glGetBufferSubData (marshalBufferTarget t) -------------------------------------------------------------------------------- data GetBufferPName = GetBufferSize | GetBufferUsage | GetBufferAccess | GetBufferMapped marshalGetBufferPName :: GetBufferPName -> GLenum marshalGetBufferPName x = case x of GetBufferSize -> gl_BUFFER_SIZE GetBufferUsage -> gl_BUFFER_USAGE GetBufferAccess -> gl_BUFFER_ACCESS GetBufferMapped -> gl_BUFFER_MAPPED getBufferParameter :: BufferTarget -> (GLenum -> a) -> GetBufferPName -> IO a getBufferParameter t f p = with 0 $ \buf -> do glGetBufferParameteriv (marshalBufferTarget t) (marshalGetBufferPName p) buf peek1 (f . fromIntegral) buf -------------------------------------------------------------------------------- getBufferPointer :: BufferTarget -> IO (Ptr a) getBufferPointer t = with nullPtr $ \buf -> do glGetBufferPointerv (marshalBufferTarget t) gl_BUFFER_MAP_POINTER buf peek1 id buf -------------------------------------------------------------------------------- data MappingFailure = MappingFailed | UnmappingFailed deriving ( Eq, Ord, Show ) -- | Convenience function for an exception-safe combination of 'mapBuffer' and -- 'unmapBuffer'. withMappedBuffer :: BufferTarget -> BufferAccess -> (Ptr a -> IO b) -> (MappingFailure -> IO b) -> IO b withMappedBuffer t a action err = do maybeBuf <- mapBuffer t a case maybeBuf of Nothing -> err MappingFailed Just buf -> do (ret, ok) <- action buf `finallyRet` unmapBuffer t if ok then return ret else err UnmappingFailed mapBuffer :: BufferTarget -> BufferAccess -> IO (Maybe (Ptr a)) mapBuffer t = fmap (maybeNullPtr Nothing Just) . mapBuffer_ t mapBuffer_ :: BufferTarget -> BufferAccess -> IO (Ptr a) mapBuffer_ t = glMapBuffer (marshalBufferTarget t) . marshalBufferAccess unmapBuffer :: BufferTarget -> IO Bool unmapBuffer = fmap unmarshalGLboolean . glUnmapBuffer . marshalBufferTarget bufferAccess :: BufferTarget -> GettableStateVar BufferAccess bufferAccess t = makeGettableStateVar $ getBufferParameter t unmarshalBufferAccess GetBufferAccess bufferMapped :: BufferTarget -> GettableStateVar Bool bufferMapped t = makeGettableStateVar $ getBufferParameter t unmarshalGLboolean GetBufferMapped -------------------------------------------------------------------------------- data MapBufferUsage = Read | Write | InvalidateRange | InvalidateBuffer | FlushExplicit | Unsychronized deriving ( Eq, Ord, Show ) type Offset = GLintptr type Length = GLsizeiptr marshalMapBufferUsage :: MapBufferUsage -> GLbitfield marshalMapBufferUsage x = case x of Read -> gl_MAP_READ_BIT Write -> gl_MAP_WRITE_BIT InvalidateRange -> gl_MAP_INVALIDATE_RANGE_BIT InvalidateBuffer -> gl_MAP_INVALIDATE_BUFFER_BIT FlushExplicit -> gl_MAP_FLUSH_EXPLICIT_BIT Unsychronized -> gl_MAP_FLUSH_EXPLICIT_BIT -------------------------------------------------------------------------------- mapBufferRange_ :: BufferTarget -> Offset -> Length -> [MapBufferUsage] -> IO (Ptr a) mapBufferRange_ t o l b = glMapBufferRange (marshalBufferTarget t) o l (sum (map marshalMapBufferUsage b)) mapBufferRange :: BufferTarget -> Offset -> Length -> [MapBufferUsage] -> IO (Maybe (Ptr a)) mapBufferRange t o l b = fmap (maybeNullPtr Nothing Just) $ mapBufferRange_ t o l b flushMappedBufferRange :: BufferTarget -> Offset -> Length -> IO () flushMappedBufferRange t = glFlushMappedBufferRange (marshalBufferTarget t) -------------------------------------------------------------------------------- type BufferIndex = GLuint type RangeStartIndex = GLintptr type RangeSize = GLsizeiptr type BufferRange = (BufferObject, RangeStartIndex, RangeSize) data IndexedBufferTarget = IndexedAtomicCounterBuffer | IndexedShaderStorageBuffer | IndexedTransformFeedbackBuffer | IndexedUniformBuffer deriving ( Eq, Ord, Show ) marshalIndexedBufferTarget :: IndexedBufferTarget -> IPName1I marshalIndexedBufferTarget x = case x of IndexedAtomicCounterBuffer -> GetAtomicCounterBuffer IndexedShaderStorageBuffer -> GetShaderStorageBuffer IndexedTransformFeedbackBuffer -> GetTransformFeedbackBuffer IndexedUniformBuffer -> GetUniformBuffer bindBufferBase :: IndexedBufferTarget -> BufferIndex -> StateVar (Maybe BufferObject) bindBufferBase t i = makeStateVar (getIndexedBufferBinding t i) (setIndexedBufferBase t i) getIndexedBufferBinding :: IndexedBufferTarget -> BufferIndex -> IO (Maybe BufferObject) getIndexedBufferBinding t i = do buf <- getInteger1i (BufferObject . fromIntegral) (marshalIndexedBufferTarget t) i return $ if buf == noBufferObject then Nothing else Just buf setIndexedBufferBase :: IndexedBufferTarget -> BufferIndex -> Maybe BufferObject -> IO () setIndexedBufferBase t i buf = case marshalGetPName . marshalIndexedBufferTarget $ t of Nothing -> recordInvalidEnum Just t' -> glBindBufferBase t' i . bufferID . fromMaybe noBufferObject $ buf bindBufferRange :: IndexedBufferTarget -> BufferIndex -> StateVar (Maybe BufferRange) bindBufferRange t i = makeStateVar (getIndexedBufferRange t i) (setIndexedBufferRange t i) getIndexedBufferRange :: IndexedBufferTarget -> BufferIndex -> IO (Maybe BufferRange) getIndexedBufferRange t i = do buf <- getInteger1i (BufferObject . fromIntegral) (marshalIndexedBufferTarget t) i if buf == noBufferObject then return Nothing else do start <- get $ indexedBufferStart t i size <- get $ indexedBufferSize t i return $ Just (buf, start, size) setIndexedBufferRange :: IndexedBufferTarget -> BufferIndex -> Maybe BufferRange -> IO () setIndexedBufferRange t i br = case marshalGetPName . marshalIndexedBufferTarget $ t of Nothing -> recordInvalidEnum Just t' -> glBindBufferRange t' i (bufferID buf) start range where (buf, start, range) = fromMaybe (noBufferObject, 0, 0) br getIndexed :: Num a => IPName1I -> BufferIndex -> GettableStateVar a getIndexed e i = makeGettableStateVar $ getInteger641i fromIntegral e i marshalIndexedBufferStart :: IndexedBufferTarget -> IPName1I marshalIndexedBufferStart x = case x of IndexedAtomicCounterBuffer -> GetAtomicCounterBufferStart IndexedShaderStorageBuffer -> GetShaderStorageBufferStart IndexedTransformFeedbackBuffer -> GetTransformFeedbackBufferStart IndexedUniformBuffer -> GetUniformBufferStart indexedBufferStart :: IndexedBufferTarget -> BufferIndex -> GettableStateVar RangeStartIndex indexedBufferStart = getIndexed . marshalIndexedBufferStart marshalIndexedBufferSize :: IndexedBufferTarget -> IPName1I marshalIndexedBufferSize x = case x of IndexedAtomicCounterBuffer -> GetAtomicCounterBufferSize IndexedShaderStorageBuffer -> GetShaderStorageBufferSize IndexedTransformFeedbackBuffer -> GetTransformFeedbackBufferSize IndexedUniformBuffer -> GetUniformBufferSize indexedBufferSize :: IndexedBufferTarget -> BufferIndex -> GettableStateVar RangeSize indexedBufferSize = getIndexed . marshalIndexedBufferSize OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PrimitiveModeInternal.hs0000644000000000000000000000325712521420345023752 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PrimitiveModeInternal -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for (un-)marshaling PrimitiveMode. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PrimitiveModeInternal ( marshalPrimitiveMode, unmarshalPrimitiveMode ) where import Graphics.Rendering.OpenGL.Raw import Graphics.Rendering.OpenGL.GL.PrimitiveMode -------------------------------------------------------------------------------- marshalPrimitiveMode :: PrimitiveMode -> GLenum marshalPrimitiveMode x = case x of Points -> gl_POINTS Lines -> gl_LINES LineLoop -> gl_LINE_LOOP LineStrip -> gl_LINE_STRIP Triangles -> gl_TRIANGLES TriangleStrip -> gl_TRIANGLE_STRIP TriangleFan -> gl_TRIANGLE_FAN Quads -> gl_QUADS QuadStrip -> gl_QUAD_STRIP Polygon -> gl_POLYGON Patches -> gl_PATCHES unmarshalPrimitiveMode :: GLenum -> PrimitiveMode unmarshalPrimitiveMode x | x == gl_POINTS = Points | x == gl_LINES = Lines | x == gl_LINE_LOOP = LineLoop | x == gl_LINE_STRIP = LineStrip | x == gl_TRIANGLES = Triangles | x == gl_TRIANGLE_STRIP = TriangleStrip | x == gl_TRIANGLE_FAN = TriangleFan | x == gl_QUADS = Quads | x == gl_QUAD_STRIP = QuadStrip | x == gl_POLYGON = Polygon | x == gl_PATCHES = Patches | otherwise = error ("unmarshalPrimitiveMode: illegal value " ++ show x) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/BeginEnd.hs0000644000000000000000000001276212521420345021154 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.BeginEnd -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 10.8 (Drawing Commands Using Begin and -- End) of the OpenGL 4.4 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.BeginEnd ( -- * Begin and End Objects renderPrimitive, unsafeRenderPrimitive, primitiveRestart, -- * Polygon Edges EdgeFlag(..), edgeFlag ) where import Data.StateVar import Graphics.Rendering.OpenGL.GL.EdgeFlag import Graphics.Rendering.OpenGL.GL.Exception import Graphics.Rendering.OpenGL.GL.PrimitiveMode import Graphics.Rendering.OpenGL.GL.PrimitiveModeInternal import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- | Delimit the vertices that define a primitive or a group of like primitives. -- -- Only a subset of GL commands can be used in the delimited action: -- Those for specifying vertex coordinates -- ('Graphics.Rendering.OpenGL.GL.VertexSpec.vertex', -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.vertexv'), -- vertex colors -- ('Graphics.Rendering.OpenGL.GL.VertexSpec.color', -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.colorv', -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.secondaryColor', -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.secondaryColorv', -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.index', -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.indexv'), -- normal -- ('Graphics.Rendering.OpenGL.GL.VertexSpec.normal', -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.normalv'), -- texture coordinates -- ('Graphics.Rendering.OpenGL.GL.VertexSpec.texCoord', -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.texCoordv', -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.multiTexCoord', -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.multiTexCoordv'), -- and fog coordinates -- ('Graphics.Rendering.OpenGL.GL.VertexSpec.fogCoord', -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.fogCoordv'). -- Additionally, -- 'Graphics.Rendering.OpenGL.GL.Evaluators.evalPoint1', -- 'Graphics.Rendering.OpenGL.GL.Evaluators.evalPoint2', -- 'Graphics.Rendering.OpenGL.GL.Evaluators.evalCoord1', -- 'Graphics.Rendering.OpenGL.GL.Evaluators.evalCoord1v', -- 'Graphics.Rendering.OpenGL.GL.Evaluators.evalCoord2', -- 'Graphics.Rendering.OpenGL.GL.Evaluators.evalCoord2v', -- 'Graphics.Rendering.OpenGL.GL.Colors.materialAmbient', -- 'Graphics.Rendering.OpenGL.GL.Colors.materialDiffuse', -- 'Graphics.Rendering.OpenGL.GL.Colors.materialAmbientAndDiffuse', -- 'Graphics.Rendering.OpenGL.GL.Colors.materialSpecular', -- 'Graphics.Rendering.OpenGL.GL.Colors.materialEmission', -- 'Graphics.Rendering.OpenGL.GL.Colors.materialShininess', -- 'Graphics.Rendering.OpenGL.GL.DisplayLists.callList', -- 'Graphics.Rendering.OpenGL.GL.DisplayLists.callLists', -- and setting 'edgeFlag' are allowed. Writing the respective state variables -- is allowed in the delimited action, too. -- -- Regardless of the chosen 'PrimitiveMode', there is no limit to the number of -- vertices that can be defined during a single 'renderPrimitive'. Lines, -- triangles, quadrilaterals, and polygons that are incompletely specified are -- not drawn. Incomplete specification results when either too few vertices are -- provided to specify even a single primitive or when an incorrect multiple of -- vertices is specified. The incomplete primitive is ignored; the rest are -- drawn. -- -- The minimum specification of vertices for each primitive is as follows: 1 -- for a point, 2 for a line, 3 for a triangle, 4 for a quadrilateral, and 3 for -- a polygon. Modes that require a certain multiple of vertices are 'Lines' (2), -- 'Triangles' (3), 'Quads' (4), and 'QuadStrip' (2). renderPrimitive :: PrimitiveMode -> IO a -> IO a renderPrimitive = renderPrim bracket_ -- | A more efficient, but potentially dangerous version of 'renderPrimitive': -- The given action is not allowed to throw an exception. unsafeRenderPrimitive :: PrimitiveMode -> IO a -> IO a unsafeRenderPrimitive = renderPrim unsafeBracket_ {-# INLINE renderPrim #-} renderPrim :: (IO () -> IO () -> IO a -> IO a) -> PrimitiveMode -> IO a -> IO a renderPrim brack_ beginMode = brack_ (glBegin (marshalPrimitiveMode beginMode)) glEnd -------------------------------------------------------------------------------- primitiveRestart :: IO () primitiveRestart = glPrimitiveRestartNV -------------------------------------------------------------------------------- -- | Each vertex of a polygon, separate triangle, or separate quadrilateral -- specified during 'renderPrimitive' is marked as the start of either a boundary -- or nonboundary (interior) edge. -- -- The vertices of connected triangles and connected quadrilaterals are always -- marked as boundary, regardless of the value of the edge flag. -- -- Boundary and nonboundary edge flags on vertices are significant only if -- 'Graphics.Rendering.OpenGL.GL.Polygons.polygonMode' is set to -- 'Graphics.Rendering.OpenGL.GL.Polygons.Point' or -- 'Graphics.Rendering.OpenGL.GL.Polygons.Line'. -- -- Note that the current edge flag can be updated at any time, in particular -- during 'renderPrimitive'. edgeFlag :: StateVar EdgeFlag edgeFlag = makeStateVar (getBoolean1 unmarshalEdgeFlag GetEdgeFlag) (glEdgeFlag . marshalEdgeFlag) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PointParameter.hs0000644000000000000000000000270512521420345022427 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PointParameter -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for setting point parameters. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PointParameter ( PointParameter(..), pointParameterf, pointParameterfv ) where import Foreign.Ptr import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data PointParameter = PointSizeMin | PointSizeMax | PointFadeThresholdSize | PointDistanceAttenuation marshalPointParameter :: PointParameter -> GLenum marshalPointParameter x = case x of PointSizeMin -> gl_POINT_SIZE_MIN PointSizeMax -> gl_POINT_SIZE_MAX PointFadeThresholdSize -> gl_POINT_FADE_THRESHOLD_SIZE PointDistanceAttenuation -> gl_POINT_DISTANCE_ATTENUATION -------------------------------------------------------------------------------- pointParameterf :: PointParameter -> GLfloat -> IO () pointParameterf = glPointParameterf . marshalPointParameter pointParameterfv :: PointParameter -> Ptr GLfloat -> IO () pointParameterfv = glPointParameterfv . marshalPointParameter OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Framebuffer.hs0000644000000000000000000004457012521420345021727 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Framebuffer -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 4.2 (Whole Framebuffer Operations) of the -- OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Framebuffer ( -- * Querying the Buffer Configuration auxBuffers, doubleBuffer, stereoBuffer, rgbaBits, stencilBits, depthBits, accumBits, rgbaSignedComponents, -- * Selecting a Buffer for Writing DrawBufferIndex, BufferMode(..), drawBuffer, drawBuffers, drawBufferi, maxDrawBuffers, -- * Fine Control of Buffer Updates indexMask, colorMask, colorMaski, stencilMask, stencilMaskSeparate, depthMask, -- * Clearing the Buffers ClearBuffer(..), clear, clearColor, clearIndex, clearStencil, clearDepth, clearAccum, -- * The Accumulation Buffer AccumOp(..), accum ) where import Control.Monad import Data.List import Data.Maybe import Data.StateVar import Foreign.Marshal.Array import Graphics.Rendering.OpenGL.GL.BufferMode import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.Face import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- | The implementation and context dependent number of auxiliary buffers. auxBuffers :: GettableStateVar GLsizei auxBuffers = makeGettableStateVar $ getSizei1 id GetAuxBuffers -- | 'True' if front and back buffers exist. doubleBuffer :: GettableStateVar Bool doubleBuffer = makeGettableStateVar $ getBoolean1 unmarshalGLboolean GetDoublebuffer -- | 'True' if left and right buffers exist. stereoBuffer :: GettableStateVar Bool stereoBuffer = makeGettableStateVar $ getBoolean1 unmarshalGLboolean GetStereo rgbaBits :: GettableStateVar (Color4 GLsizei) rgbaBits = makeGettableStateVar $ liftM4 Color4 (getSizei1 id GetRedBits) (getSizei1 id GetGreenBits) (getSizei1 id GetBlueBits) (getSizei1 id GetAlphaBits) stencilBits :: GettableStateVar GLsizei stencilBits = makeGettableStateVar $ getSizei1 id GetStencilBits depthBits :: GettableStateVar GLsizei depthBits = makeGettableStateVar $ getSizei1 id GetDepthBits accumBits :: GettableStateVar (Color4 GLsizei) accumBits = makeGettableStateVar $ liftM4 Color4 (getSizei1 id GetAccumRedBits) (getSizei1 id GetAccumGreenBits) (getSizei1 id GetAccumBlueBits) (getSizei1 id GetAccumAlphaBits) rgbaSignedComponents :: GettableStateVar (Color4 Bool) rgbaSignedComponents = makeGettableStateVar $ getInteger4 (\r g b a -> Color4 (unmarshalGLboolean r) (unmarshalGLboolean g) (unmarshalGLboolean b) (unmarshalGLboolean a)) GetRGBASignedComponents -------------------------------------------------------------------------------- -- | When colors are written to the framebuffer, they are written into the color -- buffers specified by 'drawBuffer'. -- -- If more than one color buffer is selected for drawing, then blending or -- logical operations are computed and applied independently for each color -- buffer and can produce different results in each buffer. -- -- Monoscopic contexts include only left buffers, and stereoscopic contexts -- include both left and right buffers. Likewise, single-buffered contexts -- include only front buffers, and double-buffered contexts include both front -- and back buffers. The context is selected at GL initialization. -- -- The initial value is 'FrontBuffers' for single-buffered contexts, and -- 'BackBuffers' for double-buffered contexts. drawBuffer :: StateVar BufferMode drawBuffer = makeStateVar (getEnum1 unmarshalBufferMode GetDrawBuffer) (maybe recordInvalidValue glDrawBuffer . marshalBufferMode) -------------------------------------------------------------------------------- type DrawBufferIndex = GLuint -- | 'drawBuffers' defines the draw buffers to which all fragment colors are -- written. The draw buffers being defined correspond in order to the respective -- fragment colors. The draw buffer for fragment colors beyond those specified -- is set to 'NoBuffers'. -- -- Except for 'NoBuffers', a buffer may not appear more then once in the given -- list. Specifying a buffer more then once will result in an -- 'Graphics.Rendering.OpenGL.GLU.Errors.InvalidOperation'. -- -- If fixed-function fragment shading is being performed, 'drawBuffers' -- specifies a set of draw buffers into which the fragment color is written. -- -- If a fragment shader writes to @gl_FragColor@, 'drawBuffers' specifies a set -- of draw buffers into which the single fragment color defined by -- @gl_FragColor@ is written. If a fragment shader writes to @gl_FragData@, -- 'drawBuffers' specifies a set of draw buffers into which each of the multiple -- fragment colors defined by @gl_FragData@ are separately written. If a -- fragment shader writes to neither @gl_FragColor@ nor @gl_FragData@, the -- values of the fragment colors following shader execution are undefined, and -- may differ for each fragment color. drawBuffers :: StateVar [BufferMode] drawBuffers = makeStateVar getDrawBuffers setDrawBuffers getDrawBuffers :: IO [BufferMode] getDrawBuffers = do n <- get maxDrawBuffers mapM (getEnum1 unmarshalBufferMode . GetDrawBufferN) [ 0 .. n ] setDrawBuffers :: [BufferMode] -> IO () setDrawBuffers modes = do let ms = map marshalBufferMode modes if all isJust ms then withArray (map fromJust ms) $ glDrawBuffers (genericLength ms) else recordInvalidValue -- | 'drawBufferi' is a fast query function. For indices in the range 0..maxDrawBuffers it's results -- are the same as selection the index from the list returned by drawBuffers. Though this function -- only uses one gl-function call instead of maxDrawBuffers + 1. drawBufferi :: DrawBufferIndex -> GettableStateVar BufferMode drawBufferi ind = makeGettableStateVar (getEnum1 unmarshalBufferMode . GetDrawBufferN $ fromIntegral ind) -------------------------------------------------------------------------------- -- | Contains the maximum number of buffers that can activated via 'drawBuffers' -- or which can be simultaneously written into from within a fragment shader -- using the special output variable array @gl_FragData@. This constant -- effectively defines the size of the @gl_FragData@ array. The minimum legal -- value is 1. maxDrawBuffers :: GettableStateVar GLsizei maxDrawBuffers = makeGettableStateVar $ getSizei1 id GetMaxDrawBuffers -------------------------------------------------------------------------------- -- | Controls the writing of individual bits in the color index buffers. The -- least significant /n/ bits of its value, where /n/ is the number of bits in a -- color index buffer, specify a mask. Where a 1 appears in the mask, it is -- possible to write to the corresponding bit in the color index buffer (or -- buffers). Where a 0 appears, the corresponding bit is write-protected. -- -- This mask is used only in color index mode, and it affects only the buffers -- currently selected for writing (see 'drawBuffer'). Initially, all bits are -- enabled for writing. indexMask :: StateVar GLuint indexMask = makeStateVar (getInteger1 fromIntegral GetIndexWritemask) glIndexMask -------------------------------------------------------------------------------- -- | Controls whether the individual color components in the framebuffer can or -- cannot be written. If the red flag is 'Disabled', for example, no change is -- made to the red component of any pixel in any of the color buffers, -- regardless of the drawing operation attempted. Initially, all color -- components can be written. -- -- Changes to individual bits of components cannot be controlled. Rather, -- changes are either enabled or disabled for entire color components. -- Furthermore, this mask is used only in RGBA mode. colorMask :: StateVar (Color4 Capability) colorMask = makeStateVar (getBoolean4 (\r g b a -> Color4 (unmarshalCapability r) (unmarshalCapability g) (unmarshalCapability b) (unmarshalCapability a)) GetColorWritemask) (\(Color4 r g b a) -> glColorMask (marshalCapability r) (marshalCapability g) (marshalCapability b) (marshalCapability a)) -- | 'colorMaski' is a version of 'colorMask' that only applies to the specified drawbuffer colorMaski :: DrawBufferIndex -> StateVar (Color4 Capability) colorMaski x = makeStateVar (getBoolean4i (\r g b a -> Color4 (unmarshalCapability r) (unmarshalCapability g) (unmarshalCapability b) (unmarshalCapability a)) GetColorWritemask x) (\(Color4 r g b a) -> glColorMaski (x) (marshalCapability r) (marshalCapability g) (marshalCapability b) (marshalCapability a)) -------------------------------------------------------------------------------- -- | Controls whether the depth buffer is enabled for writing. The initial state -- is 'Enabled'. depthMask :: StateVar Capability depthMask = makeStateVar (getBoolean1 unmarshalCapability GetDepthWritemask) (glDepthMask . marshalCapability) -------------------------------------------------------------------------------- -- | Controls the writing of individual bits in the stencil planes. The least -- significant /n/ bits of its value, where /n/ is the number of bits in the -- stencil buffer, specify a mask. Where a 1 appears in the mask, it is -- possible to write to the corresponding bit in the stencil buffer. Where a 0 -- appears, the corresponding bit is write-protected. -- Initially, all bits are enabled for writing. stencilMask :: StateVar GLuint stencilMask = makeStateVar (getInteger1 fromIntegral GetStencilWritemask) glStencilMask stencilMaskSeparate :: Face -> SettableStateVar GLuint stencilMaskSeparate face = makeSettableStateVar $ glStencilMaskSeparate (marshalFace face) -------------------------------------------------------------------------------- -- | The buffers which can be cleared with 'clear'. data ClearBuffer = ColorBuffer -- ^ The buffers currently enabled for color writing. | AccumBuffer -- ^ The accumulation buffer. | StencilBuffer -- ^ The stencil buffer. | DepthBuffer -- ^ The depth buffer. deriving ( Eq, Ord, Show ) marshalClearBuffer :: ClearBuffer -> GLbitfield marshalClearBuffer x = case x of ColorBuffer -> gl_COLOR_BUFFER_BIT AccumBuffer -> gl_ACCUM_BUFFER_BIT StencilBuffer -> gl_STENCIL_BUFFER_BIT DepthBuffer -> gl_DEPTH_BUFFER_BIT -------------------------------------------------------------------------------- -- | Set the bitplane area of the window to values previously selected by -- 'clearColor', 'clearIndex', 'clearDepth', 'clearStencil', and 'clearAccum'. -- Multiple color buffers can be cleared simultaneously by selecting more than -- one buffer at a time using 'drawBuffer'. -- -- The pixel ownership test, the scissor test, dithering, and the buffer -- writemasks affect the operation of 'clear'. The scissor box bounds the -- cleared region. Alpha function, blend function, logical operation, -- stenciling, texure mapping, and depth-buffering are ignored by 'clear'. -- -- 'clear' takes a list of buffers, indicating which buffers are to be cleared. -- If a buffer is not present, then a 'clear' directed at that buffer has no -- effect. -- -- The value to which each buffer is cleared depends on the setting of the clear -- value for that buffer. clear :: [ClearBuffer] -> IO () clear = glClear . sum . map marshalClearBuffer -------------------------------------------------------------------------------- -- | Controls the red, green, blue, and alpha values used by 'clear' to clear -- the color buffers. Values written into 'clearColor' are clamped to the range -- [0, 1]. Initially, all values are 0. clearColor :: StateVar (Color4 GLclampf) clearColor = makeStateVar (getClampf4 Color4 GetColorClearValue) (\(Color4 r g b a) -> glClearColor r g b a) -------------------------------------------------------------------------------- -- | Controls the index /c/ used by 'clear' to clear the color index buffers. -- /c/ is not clamped. Rather, /c/ is converted to a fixed-point value with -- unspecified precision to the right of the binary point. The integer part of -- this value is then masked with 2^/m/-1, where /m/ is the number of bits in a -- color index stored in the framebuffer. Initially, the value is 0. clearIndex :: StateVar (Index1 GLfloat) clearIndex = makeStateVar (getFloat1 Index1 GetIndexClearValue) (\(Index1 i) -> glClearIndex i) -------------------------------------------------------------------------------- -- | Controls the depth value used by 'clear' to clear the depth buffer. Values -- written into 'clearDepth' are clamped to the range [0, 1]. The initial value -- is 1. clearDepth :: StateVar GLclampd clearDepth = makeStateVar (getClampd1 id GetDepthClearValue) glClearDepth -------------------------------------------------------------------------------- -- | Controls the value /s/ used by 'clear' to clear the stencil buffer. /s/ is -- masked with 2^/m/-1, where /m/ is the number of bits in the stencil buffer. -- Initially, the value is 0. clearStencil :: StateVar GLint clearStencil = makeStateVar (getInteger1 id GetStencilClearValue) glClearStencil -------------------------------------------------------------------------------- -- | Controls the red, green, blue, and alpha values used by 'clear' to clear -- the accumulation buffer. Values written into 'clearAccum' are clamped to the -- range [-1, 1]. The initial values are all 0. clearAccum :: StateVar (Color4 GLfloat) clearAccum = makeStateVar (getFloat4 Color4 GetAccumClearValue) (\(Color4 r g b a) -> glClearAccum r g b a) -------------------------------------------------------------------------------- -- | An operation on the accumulation buffer. data AccumOp = Accum -- ^ Obtains /R/, /G/, /B/, and /A/ values from the buffer currently -- selected for reading (see -- 'Graphics.Rendering.OpenGL.GL.ReadCopyPixels.readBuffer'). Each -- component value is divided by 2^/n/-1, where /n/ is the number of bits -- allocated to each color component in the currently selected buffer. The -- result is a floating-point value in the range [0, 1], which is -- multiplied by the value given to 'accum' and added to the corresponding -- pixel component in the accumulation buffer, thereby updating the -- accumulation buffer. | Load -- ^ Similar to 'Accum', except that the current value in the accumulation -- buffer is not used in the calculation of the new value. That is, the -- /R/, /G/, /B/, and /A/ values from the currently selected buffer are -- divided by 2^/n/-1, multiplied by the value given to 'accum', and then -- stored in the corresponding accumulation buffer cell, overwriting the -- current value. | Return -- ^ Transfers accumulation buffer values to the color buffer or buffers -- currently selected for writing. Each /R/, /G/, /B/, and /A/ component -- is multiplied by the value given to 'accum', then multiplied by 2^/n/-1, -- clamped to the range [0, 2^/n/-1], and stored in the corresponding -- display buffer cell. The only fragment operations that are applied to -- this transfer are pixel ownership, scissor, dithering, and color -- writemasks. | Mult -- ^ Multiplies each /R/, /G/, /B/, and /A/ in the accumulation buffer by -- the value given to 'accum' and returns the scaled component to its -- corresponding accumulation buffer location. | Add -- ^ Adds the value given to 'accum' to each /R/, /G/, /B/, and /A/ in the -- accumulation buffer. deriving ( Eq, Ord, Show ) marshalAccumOp :: AccumOp -> GLenum marshalAccumOp x = case x of Accum -> gl_ACCUM Load -> gl_LOAD Return -> gl_RETURN Mult -> gl_MULT Add -> gl_ADD -------------------------------------------------------------------------------- -- | The accumulation buffer is an extended-range color buffer. Images are not -- rendered into it. Rather, images rendered into one of the color buffers are -- added to the contents of the accumulation buffer after rendering. Effects -- such as antialiasing (of points, lines, and polygons), motion blur, and -- depth of field can be created by accumulating images generated with different -- transformation matrices. -- -- Each pixel in the accumulation buffer consists of red, green, blue, and alpha -- values. The number of bits per component in the accumulation buffer depends -- on the implementation (see 'accumBits'). Regardless of the number of bits per -- component, the range of values stored by each component is [-1, 1]. The -- accumulation buffer pixels are mapped one-to-one with frame buffer pixels. -- -- 'accum' operates on the accumulation buffer. The first argument selects an -- accumulation buffer operation. The second argument, is a floating-point value -- to be used in that operation, see 'AccumOp'. -- -- All accumulation buffer operations are limited to the area of the current -- scissor box and applied identically to the red, green, blue, and alpha -- components of each pixel. If an 'accum' operation results in a value outside -- the range [-1, 1], the contents of an accumulation buffer pixel component -- are undefined. -- -- To clear the accumulation buffer, use 'clearAccum' to specify the clear -- value, then call 'clear' with the accumulation buffer enabled. accum :: AccumOp -> GLfloat -> IO () accum = glAccum . marshalAccumOp OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/DebugOutput.hs0000644000000000000000000003032612521420345021744 0ustar0000000000000000{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.DebugOutput -- Copyright : (c) Sven Panne 2015 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 20 (Debug Output) of the OpenGL 4.5 -- specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.DebugOutput ( -- * Debug Messages debugOutput, DebugMessage(..), DebugSource(..), DebugType(..), DebugMessageID(DebugMessageID), DebugSeverity(..), maxDebugMessageLength, -- * Debug Message Callback debugMessageCallback, -- * Debug Message Log maxDebugLoggedMessages, debugLoggedMessages, -- * Controlling Debug Messages MessageGroup(..), debugMessageControl, -- * Externally Generated Messages debugMessageInsert, -- * Debug Groups DebugGroup(..), pushDebugGroup, popDebugGroup, withDebugGroup, maxDebugGroupStackDepth, -- * Debug Labels CanBeLabeled(..), maxLabelLength, -- * Asynchronous and Synchronous Debug Output debugOutputSynchronous ) where import Control.Monad ( unless, replicateM ) import Data.StateVar import Foreign.C.String ( peekCStringLen, withCStringLen ) import Foreign.C.Types import Foreign.Marshal.Alloc ( alloca ) import Foreign.Marshal.Array ( allocaArray, withArrayLen ) import Foreign.Ptr ( nullPtr, castPtrToFunPtr, FunPtr, nullFunPtr, freeHaskellFunPtr ) import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.Exception import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- debugOutput :: StateVar Capability debugOutput = makeCapability CapDebugOutput -------------------------------------------------------------------------------- data DebugMessage = DebugMessage DebugSource DebugType DebugMessageID DebugSeverity String deriving ( Eq, Ord, Show ) -------------------------------------------------------------------------------- data DebugSource = DebugSourceAPI | DebugSourceShaderCompiler | DebugSourceWindowSystem | DebugSourceThirdParty | DebugSourceApplication | DebugSourceOther deriving ( Eq, Ord, Show ) marshalDebugSource :: DebugSource -> GLenum marshalDebugSource x = case x of DebugSourceAPI -> gl_DEBUG_SOURCE_API DebugSourceShaderCompiler -> gl_DEBUG_SOURCE_SHADER_COMPILER DebugSourceWindowSystem -> gl_DEBUG_SOURCE_WINDOW_SYSTEM DebugSourceThirdParty -> gl_DEBUG_SOURCE_THIRD_PARTY DebugSourceApplication -> gl_DEBUG_SOURCE_APPLICATION DebugSourceOther -> gl_DEBUG_SOURCE_OTHER unmarshalDebugSource :: GLenum -> DebugSource unmarshalDebugSource x | x == gl_DEBUG_SOURCE_API = DebugSourceAPI | x == gl_DEBUG_SOURCE_SHADER_COMPILER = DebugSourceShaderCompiler | x == gl_DEBUG_SOURCE_WINDOW_SYSTEM = DebugSourceWindowSystem | x == gl_DEBUG_SOURCE_THIRD_PARTY = DebugSourceThirdParty | x == gl_DEBUG_SOURCE_APPLICATION = DebugSourceApplication | x == gl_DEBUG_SOURCE_OTHER = DebugSourceOther | otherwise = error ("unmarshalDebugSource: illegal value " ++ show x) -------------------------------------------------------------------------------- data DebugType = DebugTypeError | DebugTypeDeprecatedBehavior | DebugTypeUndefinedBehavior | DebugTypePerformance | DebugTypePortability | DebugTypeMarker | DebugTypePushGroup | DebugTypePopGroup | DebugTypeOther deriving ( Eq, Ord, Show ) marshalDebugType :: DebugType -> GLenum marshalDebugType x = case x of DebugTypeError -> gl_DEBUG_TYPE_ERROR DebugTypeDeprecatedBehavior -> gl_DEBUG_TYPE_DEPRECATED_BEHAVIOR DebugTypeUndefinedBehavior -> gl_DEBUG_TYPE_UNDEFINED_BEHAVIOR DebugTypePerformance -> gl_DEBUG_TYPE_PERFORMANCE DebugTypePortability -> gl_DEBUG_TYPE_PORTABILITY DebugTypeMarker -> gl_DEBUG_TYPE_MARKER DebugTypePushGroup -> gl_DEBUG_TYPE_PUSH_GROUP DebugTypePopGroup -> gl_DEBUG_TYPE_POP_GROUP DebugTypeOther -> gl_DEBUG_TYPE_OTHER unmarshalDebugType :: GLenum -> DebugType unmarshalDebugType x | x == gl_DEBUG_TYPE_ERROR = DebugTypeError | x == gl_DEBUG_TYPE_DEPRECATED_BEHAVIOR = DebugTypeDeprecatedBehavior | x == gl_DEBUG_TYPE_UNDEFINED_BEHAVIOR = DebugTypeUndefinedBehavior | x == gl_DEBUG_TYPE_PERFORMANCE = DebugTypePerformance | x == gl_DEBUG_TYPE_PORTABILITY = DebugTypePortability | x == gl_DEBUG_TYPE_MARKER = DebugTypeMarker | x == gl_DEBUG_TYPE_PUSH_GROUP = DebugTypePushGroup | x == gl_DEBUG_TYPE_POP_GROUP = DebugTypePopGroup | x == gl_DEBUG_TYPE_OTHER = DebugTypeOther | otherwise = error ("unmarshalDebugType: illegal value " ++ show x) -------------------------------------------------------------------------------- newtype DebugMessageID = DebugMessageID { debugMessageID :: GLuint } deriving ( Eq, Ord, Show ) -------------------------------------------------------------------------------- data DebugSeverity = DebugSeverityHigh | DebugSeverityMedium | DebugSeverityLow | DebugSeverityNotification deriving ( Eq, Ord, Show ) marshalDebugSeverity :: DebugSeverity -> GLenum marshalDebugSeverity x = case x of DebugSeverityHigh -> gl_DEBUG_SEVERITY_HIGH DebugSeverityMedium -> gl_DEBUG_SEVERITY_MEDIUM DebugSeverityLow -> gl_DEBUG_SEVERITY_LOW DebugSeverityNotification -> gl_DEBUG_SEVERITY_NOTIFICATION unmarshalDebugSeverity :: GLenum -> DebugSeverity unmarshalDebugSeverity x | x == gl_DEBUG_SEVERITY_HIGH = DebugSeverityHigh | x == gl_DEBUG_SEVERITY_MEDIUM = DebugSeverityMedium | x == gl_DEBUG_SEVERITY_LOW = DebugSeverityLow | x == gl_DEBUG_SEVERITY_NOTIFICATION = DebugSeverityNotification | otherwise = error ("unmarshalDebugSeverity: illegal value " ++ show x) -------------------------------------------------------------------------------- maxDebugMessageLength :: GettableStateVar GLsizei maxDebugMessageLength = makeGettableStateVar (getSizei1 id GetMaxDebugMessageLength) -------------------------------------------------------------------------------- debugMessageCallback :: StateVar (Maybe (DebugMessage -> IO ())) debugMessageCallback = makeStateVar getDebugMessageCallback setDebugMessageCallback getDebugMessageCallback :: IO (Maybe (DebugMessage -> IO ())) getDebugMessageCallback = do cb <- getDebugCallbackFunction return $ if (cb == nullFunPtr) then Nothing else Just . toDebugProc . dyn_debugProc $ cb foreign import CALLCONV "dynamic" dyn_debugProc :: FunPtr GLDEBUGPROCFunc -> GLDEBUGPROCFunc toDebugProc:: GLDEBUGPROCFunc -> DebugMessage -> IO () toDebugProc debugFunc (DebugMessage source typ msgID severity message) = withCStringLen message $ \(msg, len) -> do debugFunc (marshalDebugSource source) (marshalDebugType typ) (marshalDebugSeverity severity) (debugMessageID msgID) (fromIntegral len) msg nullPtr setDebugMessageCallback :: Maybe (DebugMessage -> IO ()) -> IO () setDebugMessageCallback maybeDebugProc = do oldCB <- getDebugCallbackFunction unless (oldCB == nullFunPtr) $ freeHaskellFunPtr oldCB newCB <- maybe (return nullFunPtr) (makeGLDEBUGPROC . fromDebugProc) maybeDebugProc glDebugMessageCallbackARB newCB nullPtr fromDebugProc:: (DebugMessage -> IO ()) -> GLDEBUGPROCFunc fromDebugProc debugProc source typ msgID severity len message _userParam = do msg <- peekCStringLen (message, fromIntegral len) debugProc (DebugMessage (unmarshalDebugSource source) (unmarshalDebugType typ) (DebugMessageID msgID) (unmarshalDebugSeverity severity) msg) getDebugCallbackFunction :: IO (FunPtr GLDEBUGPROCFunc) getDebugCallbackFunction = castPtrToFunPtr `fmap` getPointer DebugCallbackFunction -------------------------------------------------------------------------------- maxDebugLoggedMessages :: GettableStateVar GLsizei maxDebugLoggedMessages = makeGettableStateVar (getSizei1 id GetMaxDebugLoggedMessages) debugLoggedMessages :: IO [DebugMessage] debugLoggedMessages = do count <- getSizei1 fromIntegral GetDebugLoggedMessages replicateM count debugNextLoggedMessage debugNextLoggedMessage :: IO DebugMessage debugNextLoggedMessage = do len <- getSizei1 id GetDebugNextLoggedMessageLength alloca $ \sourceBuf -> alloca $ \typeBuf -> alloca $ \idBuf -> alloca $ \severityBuf -> allocaArray (fromIntegral len) $ \messageBuf -> do _ <- glGetDebugMessageLog 1 len sourceBuf typeBuf idBuf severityBuf nullPtr messageBuf source <- peek1 unmarshalDebugSource sourceBuf typ <- peek1 unmarshalDebugType typeBuf msgID <- peek1 DebugMessageID idBuf severity <- peek1 unmarshalDebugSeverity severityBuf message <- peekCStringLen (messageBuf, fromIntegral len) return $ DebugMessage source typ msgID severity message -------------------------------------------------------------------------------- data MessageGroup = MessageGroup (Maybe DebugSource) (Maybe DebugType) (Maybe DebugSeverity) | MessageGroupWithIDs DebugSource DebugType [DebugMessageID] deriving ( Eq, Ord, Show ) debugMessageControl :: MessageGroup -> SettableStateVar Capability debugMessageControl x = case x of MessageGroup maybeSource maybeType maybeSeverity -> doDebugMessageControl maybeSource maybeType maybeSeverity [] MessageGroupWithIDs source typ messageIDs -> doDebugMessageControl (Just source) (Just typ) Nothing messageIDs doDebugMessageControl :: Maybe DebugSource -> Maybe DebugType -> Maybe DebugSeverity -> [DebugMessageID] -> SettableStateVar Capability doDebugMessageControl maybeSource maybeType maybeSeverity messageIDs = makeSettableStateVar $ \cap -> withArrayLen (map debugMessageID messageIDs) $ \len idsBuf -> glDebugMessageControl (maybe gl_DONT_CARE marshalDebugSource maybeSource) (maybe gl_DONT_CARE marshalDebugType maybeType) (maybe gl_DONT_CARE marshalDebugSeverity maybeSeverity) (fromIntegral len) idsBuf (marshalCapability cap) -------------------------------------------------------------------------------- debugMessageInsert :: DebugMessage -> IO () debugMessageInsert (DebugMessage source typ msgID severity message) = withCStringLen message $ \(msg, len) -> glDebugMessageInsert (marshalDebugSource source) (marshalDebugType typ) (debugMessageID msgID) (marshalDebugSeverity severity) (fromIntegral len) msg -------------------------------------------------------------------------------- data DebugGroup = DebugGroup DebugSource DebugMessageID String pushDebugGroup :: DebugSource -> DebugMessageID -> String -> IO () pushDebugGroup source msgID message = withCStringLen message $ \(msg, len) -> glPushDebugGroup (marshalDebugSource source) (debugMessageID msgID) (fromIntegral len) msg popDebugGroup :: IO () popDebugGroup = glPopDebugGroup withDebugGroup :: DebugSource -> DebugMessageID -> String -> IO a -> IO a withDebugGroup source msgID message = bracket_ (pushDebugGroup source msgID message) popDebugGroup maxDebugGroupStackDepth :: GettableStateVar GLsizei maxDebugGroupStackDepth = makeGettableStateVar (getSizei1 id GetMaxDebugGroupStackDepth) -------------------------------------------------------------------------------- -- TODO: Make instances for the following features when we have them: -- * PROGRAM_PIPELINE / glGenProgramPipelines -- * SAMPLER / glGenSamplers -- * TRANSFORM_FEEDBACK / glGenTransformFeedbacks class CanBeLabeled a where objectLabel :: a -> StateVar (Maybe String) -------------------------------------------------------------------------------- debugOutputSynchronous :: StateVar Capability debugOutputSynchronous = makeCapability CapDebugOutputSynchronous OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/StringQueries.hs0000644000000000000000000000630012521420345022274 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.StringQueries -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to parts of section 6.1.5 (String Queries) of the -- OpenGL 3.2 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.StringQueries ( vendor, renderer, glVersion, glExtensions, shadingLanguageVersion, majorMinor, ContextProfile'(..), contextProfile ) where import Data.Bits import Data.Char import Data.StateVar import Foreign.C.String import Foreign.Ptr import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- vendor :: GettableStateVar String vendor = makeGettableStateVar (getString gl_VENDOR) renderer :: GettableStateVar String renderer = makeGettableStateVar (getString gl_RENDERER) glVersion :: GettableStateVar String glVersion = makeGettableStateVar (getString gl_VERSION) glExtensions :: GettableStateVar [String] glExtensions = makeGettableStateVar (fmap words $ getString gl_EXTENSIONS) shadingLanguageVersion :: GettableStateVar String shadingLanguageVersion = makeGettableStateVar (getString gl_SHADING_LANGUAGE_VERSION) -------------------------------------------------------------------------------- data ContextProfile' = CoreProfile' | CompatibilityProfile' deriving ( Eq, Ord, Show ) marshalContextProfile' :: ContextProfile' -> GLbitfield marshalContextProfile' x = case x of CoreProfile' -> gl_CONTEXT_CORE_PROFILE_BIT CompatibilityProfile' -> gl_CONTEXT_COMPATIBILITY_PROFILE_BIT contextProfile :: GettableStateVar [ContextProfile'] contextProfile = makeGettableStateVar (getInteger1 i2cps GetContextProfileMask) i2cps :: GLint -> [ContextProfile'] i2cps bitfield = [ c | c <- [ CoreProfile', CompatibilityProfile' ] , (fromIntegral bitfield .&. marshalContextProfile' c) /= 0 ] -------------------------------------------------------------------------------- getString :: GLenum -> IO String getString n = glGetString n >>= maybeNullPtr (return "") (peekCString . castPtr) -------------------------------------------------------------------------------- -- | A utility function to be used with e.g. 'glVersion' or -- 'shadingLanguageVersion', transforming a variable containing a string of the -- form /major.minor[optional rest]/ into a variable containing a numeric -- major\/minor version. If the string is malformed, which should never happen -- with a sane OpenGL implementation, it is transformed to @(-1,-1)@. majorMinor :: GettableStateVar String -> GettableStateVar (Int, Int) majorMinor = makeGettableStateVar . fmap parse . get where defaultVersion = (-1, -1) parse str = case span isDigit str of (major@(_:_), '.':rest) -> case span isDigit rest of (minor@(_:_), _) -> (read major, read minor) _ -> defaultVersion _ -> defaultVersion OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/BufferMode.hs0000644000000000000000000001065712521420345021520 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.BufferMode -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for (un-)marshaling BufferMode. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.BufferMode ( BufferMode(..), marshalBufferMode, unmarshalBufferMode, unmarshalBufferModeSafe, maxColorAttachments, ) where import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- | The set of color buffers which are selected for reading and writing. data BufferMode = NoBuffers -- ^ No color buffers are selected. | FrontLeftBuffer -- ^ Only the front left color buffer is selected. | FrontRightBuffer -- ^ Only the front right color buffer is selected. | BackLeftBuffer -- ^ Only the back left color buffer is selected. | BackRightBuffer -- ^ Only the back right color buffer is selected. | FrontBuffers -- ^ Only the front left and front right color buffers are selected. If -- there is no front right color buffer, only the front left color buffer -- is selected. | BackBuffers -- ^ Only the back left and back right color buffers are selected. If there -- is no back right color buffer, only the back left color buffer is -- selected. | LeftBuffers -- ^ Only the front left and back left color buffers are selected. If there -- is no back left color buffer, only the front left color buffer is -- selected. | RightBuffers -- ^ Only the front right and back right color buffers are selected. If -- there is no back right color buffer, only the front right color buffer -- is selected. | FrontAndBackBuffers -- ^ All the front and back color buffers (front left, front right, back -- left, back right) are selected. If there are no back color buffers, only -- the front left and front right color buffers are selected. If there are -- no right color buffers, only the front left and back left color buffers -- are selected. If there are no right or back color buffers, only the -- front left color buffer is selected. | AuxBuffer GLsizei -- ^ Only the given auxiliary color buffer no. /i/ is selected. | FBOColorAttachment GLsizei -- ^ Only the given color attachment of the bound framebufferobject is selected for reading -- or writing. deriving ( Eq, Ord, Show ) marshalBufferMode :: BufferMode -> Maybe GLenum marshalBufferMode x = case x of NoBuffers -> Just gl_NONE FrontLeftBuffer -> Just gl_FRONT_LEFT FrontRightBuffer -> Just gl_FRONT_RIGHT BackLeftBuffer -> Just gl_BACK_LEFT BackRightBuffer -> Just gl_BACK_RIGHT FrontBuffers -> Just gl_FRONT BackBuffers -> Just gl_BACK LeftBuffers -> Just gl_LEFT RightBuffers -> Just gl_RIGHT FrontAndBackBuffers -> Just gl_FRONT_AND_BACK AuxBuffer i | fromIntegral i <= maxAuxBuffer -> Just (gl_AUX0 + fromIntegral i) | otherwise -> Nothing FBOColorAttachment i | fromIntegral i <= maxColorAttachments -> Just (gl_COLOR_ATTACHMENT0 + fromIntegral i) | otherwise -> Nothing unmarshalBufferMode :: GLenum -> BufferMode unmarshalBufferMode x = maybe (error ("unmarshalBufferMode: illegal value " ++ show x)) id $ unmarshalBufferModeSafe x unmarshalBufferModeSafe :: GLenum -> Maybe BufferMode unmarshalBufferModeSafe x | x == gl_NONE = Just NoBuffers | x == gl_FRONT_LEFT = Just FrontLeftBuffer | x == gl_FRONT_RIGHT = Just FrontRightBuffer | x == gl_BACK_LEFT = Just BackLeftBuffer | x == gl_BACK_RIGHT = Just BackRightBuffer | x == gl_FRONT = Just FrontBuffers | x == gl_BACK = Just BackBuffers | x == gl_LEFT = Just LeftBuffers | x == gl_RIGHT = Just RightBuffers | x == gl_FRONT_AND_BACK = Just FrontAndBackBuffers | gl_AUX0 <= x && x <= gl_AUX0 + maxAuxBuffer = Just . AuxBuffer . fromIntegral $ x - gl_AUX0 | gl_COLOR_ATTACHMENT0 <= x && x <= gl_COLOR_ATTACHMENT0 + maxColorAttachments = Just . FBOColorAttachment . fromIntegral $ x - gl_COLOR_ATTACHMENT0 | otherwise = Nothing maxAuxBuffer :: GLenum maxAuxBuffer = 246 maxColorAttachments :: GLenum maxColorAttachments = 16 OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Points.hs0000644000000000000000000002203412521420345020746 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Points -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 3.3 (Points) of the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Points ( -- * Point Rasterization pointSize, vertexProgramPointSize, -- * Controlling the Derived Size pointSizeRange, pointDistanceAttenuation, -- * Fading Points pointFadeThresholdSize, -- * Point Antialiasing pointSmooth, -- * Point Sprites pointSprite, -- * Implementation-Dependent Limits aliasedPointSizeRange, smoothPointSizeRange, smoothPointSizeGranularity ) where import Control.Monad import Data.StateVar import Foreign.Marshal.Array import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.PointParameter import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- | 'pointSize' contains the rasterized diameter of both aliased and -- antialiased points. The initial value is 1. Using a point size other than 1 -- has different effects, depending on whether point antialiasing is enabled -- (see 'pointSmooth') or point sprites are enabled (see 'pointSprite'). Both -- are initially disabled. -- -- The specified point size is multiplied with a distance attenuation factor -- and clamped to the specified 'pointSizeRange', and further clamped to the -- implementation-dependent point size range to produce the derived point size -- using -- -- @ /derivedSize/ = /clamp/ (/size/ * /sqrt/ (1 \/ (/a/ + /b/ * /d/ + /c/ * /d/^2)))@ -- -- where /d/ is the eye-coordinate distance from the eye to the vertex, and /a/, -- /b/, and /c/ are the distance attenuation coefficients (see -- 'pointDistanceAttenuation'). -- -- If multisampling is disabled, the computed point size is used as the point\'s -- width. -- -- If multisampling is enabled, the point may be faded by modifying the point -- alpha value (see 'Graphics.Rendering.OpenGL.GL.PerFragment.sampleCoverage') -- instead of allowing the point width to go below a given -- 'pointFadeThresholdSize'. In this case, the width is further modified in -- the following manner: -- -- @ /width/ = if /derivedSize/ >= /threshold/ then /derivedSize/ else /threshold/@ -- -- The point alpha value is modified by computing: -- -- @ /alpha/ = if /derivedSize/ >= /threshold/ then 1 else (/derivedSize/ \/ /threshold/)^2@ -- -- If point antialiasing is disabled, the actual size is determined by rounding -- the supplied size to the nearest integer. (If the rounding results in the -- value 0, it is as if the point size were 1.) If the rounded size is odd, -- then the center point (/x/, /y/) of the pixel fragment that represents -- the point is computed as -- -- @ (/x/, /y/) = (/floor/ /xw/ + 0.5, /floor/ /yw/ + 0.5)@ -- -- where /xw/ and /yw/ indicate window coordinates. All pixels that lie within -- the square grid of the rounded size centered at (/x/, /y/) make up the -- fragment. If the size is even, the center point is -- -- @ (/x/, /y/) = (/floor/ (/xw/ + 0.5), /floor/ (/yw/ + 0.5))@ -- -- and the rasterized fragment\'s centers are the half-integer window -- coordinates within the square of the rounded size centered at (/x/, /y/). All -- pixel fragments produced in rasterizing a nonantialiased point are assigned -- the same associated data, that of the vertex corresponding to the point. -- -- If antialiasing is enabled, then point rasterization produces a fragment for -- each pixel square that intersects the region lying within the circle having -- diameter equal to the current point size and centered at the point\'s -- (/xw/, /yw/). The coverage value for each fragment is the window coordinate -- area of the intersection of the circular region with the corresponding pixel -- square. This value is saved and used in the final rasterization step. The -- data associated with each fragment is the data associated with the point -- being rasterized. -- -- Not all sizes are supported when point antialiasing is enabled. If an -- unsupported size is requested, the nearest supported size is used. Only size -- 1 is guaranteed to be supported; others depend on the implementation. To -- query the range of supported sizes for antialiased points and the size -- difference between supported sizes within the range, query -- 'smoothPointSizeRange' and 'smoothPointSizeGranularity', respectively. For -- aliased points, query the supported range with 'aliasedPointSizeRange'. -- -- The point size specified when 'pointSize' is set is always returned when it -- is queried. Clamping and rounding for aliased and antialiased points have no -- effect on the specified value. -- -- A non-antialiased point size may be clamped to an implementation-dependent -- maximum. Although this maximum cannot be queried, it must be no less than the -- maximum value for antialiased points, rounded to the nearest integer value. -- -- An 'Graphics.Rendering.OpenGL.GLU.Errors.InvalidValue' is generated if -- 'pointSize' is set to a value less than or equal to zero. -- -- An 'Graphics.Rendering.OpenGL.GLU.Errors.InvalidOperation' is generated if -- 'pointSize' is set during -- 'Graphics.Rendering.OpenGL.GL.BeginEnd.renderPrimitive'. pointSize :: StateVar GLfloat pointSize = makeStateVar (getFloat1 id GetPointSize) glPointSize -------------------------------------------------------------------------------- vertexProgramPointSize :: StateVar Capability vertexProgramPointSize = makeCapability CapVertexProgramPointSize -------------------------------------------------------------------------------- -- | The range to which the derived point size is clamped, see 'pointSize'. Note -- that the size is further clamped to the implementation-dependent limits, see -- 'aliasedPointSizeRange' and 'smoothPointSizeRange'. The initial range is -- (0, 1). -- -- An 'Graphics.Rendering.OpenGL.GLU.Errors.InvalidValue' is generated if the -- lower or upper bound of the range is set to a value less than zero. If the -- lower bound is greater than the upper bound, the point size after clamping is -- undefined, but no error is generated. pointSizeRange :: StateVar (GLfloat, GLfloat) pointSizeRange = makeStateVar (liftM2 (,) (getFloat1 id GetPointSizeMin) (getFloat1 id GetPointSizeMax)) (\(sizeMin, sizeMax) -> do pointParameterf PointSizeMin sizeMin pointParameterf PointSizeMax sizeMax) -------------------------------------------------------------------------------- -- | The constant, linear, and quadratic distance attenuation coefficients, see -- 'pointSize'. The initial coefficients are (1, 0, 0). pointDistanceAttenuation :: StateVar (GLfloat, GLfloat, GLfloat) pointDistanceAttenuation = makeStateVar (getFloat3 (,,) GetPointDistanceAttenuation) (\(a, b, c) -> withArray [a, b, c] $ pointParameterfv PointDistanceAttenuation) -------------------------------------------------------------------------------- -- | The threshold for alpha attenuation of points when multisampling is used, -- see 'pointSize'. The initial threshold is 1. -- -- An 'Graphics.Rendering.OpenGL.GLU.Errors.InvalidValue' is generated if the -- threshold is set to a value less than zero. pointFadeThresholdSize :: StateVar GLfloat pointFadeThresholdSize = makeStateVar (getFloat1 id GetPointFadeThresholdSize) (pointParameterf PointFadeThresholdSize) -------------------------------------------------------------------------------- -- | Controls whether point antialiasing is enabled. The initial state is -- 'Graphics.Rendering.OpenGL.GL.Capability.Disabled'. pointSmooth :: StateVar Capability pointSmooth = makeCapability CapPointSmooth -------------------------------------------------------------------------------- -- | Controls whether point sprites are enabled. The initial state is -- 'Graphics.Rendering.OpenGL.GL.Capability.Disabled'. When point sprites are -- enabled, the state of point antialiasing (i.e. 'pointSmooth') is ignored. pointSprite :: StateVar Capability pointSprite = makeCapability CapPointSprite -------------------------------------------------------------------------------- -- | The smallest and largest supported size of aliased points. aliasedPointSizeRange :: GettableStateVar (GLfloat, GLfloat) aliasedPointSizeRange = makeGettableStateVar $ getFloat2 (,) GetAliasedPointSizeRange -- | The smallest and largest supported size of antialiased points. smoothPointSizeRange :: GettableStateVar (GLfloat, GLfloat) smoothPointSizeRange = makeGettableStateVar $ getFloat2 (,) GetSmoothPointSizeRange -- | The antialiased point size granularity, i.e. the size difference between -- supported sizes. smoothPointSizeGranularity :: GettableStateVar GLfloat smoothPointSizeGranularity = makeGettableStateVar $ getFloat1 id GetSmoothPointSizeGranularity OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Polygons.hs0000644000000000000000000001204612521420345021306 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Polygons -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 3.5 (Polygons) of the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Polygons ( polygonSmooth, cullFace, PolygonStipple(..), GLpolygonstipple, polygonStipple, PolygonMode(..), polygonMode, polygonOffset, polygonOffsetPoint, polygonOffsetLine, polygonOffsetFill ) where import Control.Monad import Data.StateVar import Foreign.ForeignPtr import Foreign.Marshal.Array import Foreign.Ptr import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.Face import Graphics.Rendering.OpenGL.GL.PixelRectangles import Graphics.Rendering.OpenGL.GL.PolygonMode import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.SavingState import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- polygonSmooth :: StateVar Capability polygonSmooth = makeCapability CapPolygonSmooth -------------------------------------------------------------------------------- cullFace :: StateVar (Maybe Face) cullFace = makeStateVarMaybe (return CapCullFace) (getEnum1 unmarshalFace GetCullFaceMode) (glCullFace . marshalFace) -------------------------------------------------------------------------------- numPolygonStippleBytes :: Int numPolygonStippleBytes = 128 -- 32x32 bits divided into GLubytes class PolygonStipple s where withNewPolygonStipple :: (Ptr GLubyte -> IO ()) -> IO s withPolygonStipple :: s -> (Ptr GLubyte -> IO a) -> IO a newPolygonStipple :: [GLubyte] -> IO s getPolygonStippleComponents :: s -> IO [GLubyte] withNewPolygonStipple act = allocaArray numPolygonStippleBytes $ \p -> do act p components <- peekArray numPolygonStippleBytes p newPolygonStipple components withPolygonStipple s act = do components <- getPolygonStippleComponents s withArray components act newPolygonStipple components = withNewPolygonStipple $ flip pokeArray (take numPolygonStippleBytes components) getPolygonStippleComponents s = withPolygonStipple s $ peekArray numPolygonStippleBytes -------------------------------------------------------------------------------- data GLpolygonstipple = GLpolygonstipple (ForeignPtr GLubyte) deriving ( Eq, Ord, Show ) instance PolygonStipple GLpolygonstipple where withNewPolygonStipple f = do fp <- mallocForeignPtrArray numPolygonStippleBytes withForeignPtr fp f return $ GLpolygonstipple fp withPolygonStipple (GLpolygonstipple fp) = withForeignPtr fp -------------------------------------------------------------------------------- polygonStipple :: PolygonStipple s => StateVar (Maybe s) polygonStipple = makeStateVarMaybe (return CapPolygonStipple) (withoutGaps Pack $ withNewPolygonStipple glGetPolygonStipple) (\s -> withoutGaps Unpack $ withPolygonStipple s glPolygonStipple) -- Note: No need to set rowAlignment, our memory allocator always returns a -- region which is at least 8-byte aligned (the maximum) withoutGaps :: PixelStoreDirection -> IO a -> IO a withoutGaps direction action = preservingClientAttrib [ PixelStoreAttributes ] $ do rowLength direction $= 0 skipRows direction $= 0 skipPixels direction $= 0 action -------------------------------------------------------------------------------- polygonMode :: StateVar (PolygonMode, PolygonMode) polygonMode = makeStateVar getPolygonMode setPolygonMode getPolygonMode :: IO (PolygonMode, PolygonMode) getPolygonMode = getInteger2 (\front back -> (un front, un back)) GetPolygonMode where un = unmarshalPolygonMode . fromIntegral setPolygonMode :: (PolygonMode, PolygonMode) -> IO () setPolygonMode (front, back) -- OpenGL 3 deprecated separate polygon draw modes, so try to avoid them. | front == back = setPM FrontAndBack front | otherwise = do setPM Front front; setPM Back back where setPM f m = glPolygonMode (marshalFace f) (marshalPolygonMode m) -------------------------------------------------------------------------------- polygonOffset :: StateVar (GLfloat, GLfloat) polygonOffset = makeStateVar (liftM2 (,) (getFloat1 id GetPolygonOffsetFactor) (getFloat1 id GetPolygonOffsetUnits)) (uncurry glPolygonOffset) -------------------------------------------------------------------------------- polygonOffsetPoint :: StateVar Capability polygonOffsetPoint = makeCapability CapPolygonOffsetPoint polygonOffsetLine :: StateVar Capability polygonOffsetLine = makeCapability CapPolygonOffsetLine polygonOffsetFill :: StateVar Capability polygonOffsetFill = makeCapability CapPolygonOffsetFill OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Domain.hs0000644000000000000000000000427112521420345020704 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Domain -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for handling evaluator domains. -- -------------------------------------------------------------------------------- {-# LANGUAGE TypeSynonymInstances #-} module Graphics.Rendering.OpenGL.GL.Domain ( Domain(..) ) where import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- class Storable d => Domain d where glMap1 :: GLenum -> d -> d -> GLint -> GLint -> Ptr d -> IO () glMap2 :: GLenum -> d -> d -> GLint -> GLint -> d -> d -> GLint -> GLint -> Ptr d -> IO () glGetMapv :: GLenum -> GLenum -> Ptr d -> IO () evalCoord1 :: d -> IO () evalCoord1v :: Ptr d -> IO () evalCoord2 :: (d, d) -> IO () evalCoord2v :: Ptr d -> IO () glMapGrid1 :: GLint -> d -> d -> IO () glMapGrid2 :: GLint -> d -> d -> GLint -> d -> d -> IO () get2 :: GetPName2F p => (d -> d -> a) -> p -> IO a get4 :: GetPName4F p => (d -> d -> d -> d -> a) -> p -> IO a -------------------------------------------------------------------------------- instance Domain GLfloat where glMap1 = glMap1f glMap2 = glMap2f glGetMapv = glGetMapfv evalCoord1 = glEvalCoord1f evalCoord1v = glEvalCoord1fv evalCoord2 = uncurry glEvalCoord2f evalCoord2v = glEvalCoord2fv glMapGrid1 = glMapGrid1f glMapGrid2 = glMapGrid2f get2 = getFloat2 get4 = getFloat4 instance Domain GLdouble where glMap1 = glMap1d glMap2 = glMap2d glGetMapv = glGetMapdv evalCoord1 = glEvalCoord1d evalCoord1v = glEvalCoord1dv evalCoord2 = uncurry glEvalCoord2d evalCoord2v = glEvalCoord2dv glMapGrid1 = glMapGrid1d glMapGrid2 = glMapGrid2d get2 = getDouble2 get4 = getDouble4 OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Shaders/0000755000000000000000000000000012521420345020526 5ustar0000000000000000OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Shaders/ShaderBinaries.hs0000644000000000000000000000325212521420345023747 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Shaders.ShaderBinaries -- Copyright : (c) Sven Panne 2006-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 7.2 (Shader Binaries) of the OpenGL 4.4 -- spec. -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Shaders.ShaderBinaries ( ShaderBinaryFormat(..), shaderBinaryFormats, ShaderBinary(..), shaderBinary, ) where import Data.StateVar import Foreign.Marshal.Array import Graphics.Rendering.OpenGL.GL.ByteString import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.Shaders.Shader import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- newtype ShaderBinaryFormat = ShaderBinaryFormat GLenum deriving ( Eq, Ord, Show ) shaderBinaryFormats :: GettableStateVar [ShaderBinaryFormat] shaderBinaryFormats = makeGettableStateVar $ do n <- getInteger1 fromIntegral GetNumShaderBinaryFormats getEnumN ShaderBinaryFormat GetShaderBinaryFormats n data ShaderBinary = ShaderBinary ShaderBinaryFormat ByteString deriving ( Eq, Ord, Show ) shaderBinary :: [Shader] -> SettableStateVar ShaderBinary shaderBinary shaders = makeSettableStateVar $ \(ShaderBinary (ShaderBinaryFormat format) bs) -> withArrayLen (map shaderID shaders) $ \numShaders shadersBuf -> withByteString bs $ glShaderBinary (fromIntegral numShaders) shadersBuf format OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Shaders/Attribs.hs0000644000000000000000000000433012521420345022472 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Shaders.Attribs -- Copyright : (c) Sven Panne 2006-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module contains functions related to shader attributes, corresponding -- to section 2.20.3 of the OpenGL 3.1 spec (Shader Variables). -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Shaders.Attribs ( attribLocation, VariableType(..), activeAttribs, ) where import Data.StateVar import Graphics.Rendering.OpenGL.GL.ByteString import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.Shaders.Program import Graphics.Rendering.OpenGL.GL.Shaders.Variables import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- activeAttributes :: Program -> GettableStateVar GLuint activeAttributes = programVar1 fromIntegral ActiveAttributes activeAttributeMaxLength :: Program -> GettableStateVar GLsizei activeAttributeMaxLength = programVar1 fromIntegral ActiveAttributeMaxLength -------------------------------------------------------------------------------- attribLocation :: Program -> String -> StateVar AttribLocation attribLocation program name = makeStateVar (getAttribLocation program name) (\location -> bindAttribLocation program location name) getAttribLocation :: Program -> String -> IO AttribLocation getAttribLocation (Program program) name = fmap (AttribLocation . fromIntegral) $ withGLstring name $ glGetAttribLocation program bindAttribLocation :: Program -> AttribLocation -> String -> IO () bindAttribLocation (Program program) (AttribLocation location) name = withGLstring name $ glBindAttribLocation program location -------------------------------------------------------------------------------- activeAttribs :: Program -> GettableStateVar [(GLint,VariableType,String)] activeAttribs = activeVars activeAttributes activeAttributeMaxLength glGetActiveAttrib unmarshalVariableType OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Shaders/Program.hs0000644000000000000000000001044712521420345022477 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Shaders.Program -- Copyright : (c) Sven Panne 2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for handling program objects and related -- queries. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Shaders.Program ( Program(..), GetProgramPName(..), marshalGetProgramPName, programVar1, programVar3 ) where import Control.Monad.IO.Class import Data.ObjectName import Data.StateVar import Foreign.Marshal.Utils ( with ) import Foreign.Ptr ( Ptr ) import Graphics.Rendering.OpenGL.GL.DebugOutput import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- newtype Program = Program { programID :: GLuint } deriving ( Eq, Ord, Show ) instance ObjectName Program where isObjectName = liftIO . fmap unmarshalGLboolean . glIsProgram . programID deleteObjectName = liftIO . glDeleteProgram . programID instance CanBeLabeled Program where objectLabel = objectNameLabel gl_PROGRAM . programID -------------------------------------------------------------------------------- data GetProgramPName = ProgramDeleteStatus | LinkStatus | ValidateStatus | ProgramInfoLogLength | AttachedShaders | ActiveAttributes | ActiveAttributeMaxLength | ActiveUniforms | ActiveUniformMaxLength | TransformFeedbackBufferMode | TransformFeedbackVaryings | TransformFeedbackVaryingMaxLength | ActiveUniformBlocks | ActiveUniformBlockMaxNameLength | GeometryVerticesOut | GeometryInputType | GeometryOutputType | GeometryShaderInvocations | TessControlOutputVertices | TessGenMode | TessGenSpacing | TessGenVertexOrder | TessGenPointMode | ComputeWorkGroupSize -- 3 integers! | ProgramSeparable | ProgramBinaryRetrievableHint | ActiveAtomicCounterBuffers | ProgramBinaryLength marshalGetProgramPName :: GetProgramPName -> GLenum marshalGetProgramPName x = case x of ProgramDeleteStatus -> gl_DELETE_STATUS LinkStatus -> gl_LINK_STATUS ValidateStatus -> gl_VALIDATE_STATUS ProgramInfoLogLength -> gl_INFO_LOG_LENGTH AttachedShaders -> gl_ATTACHED_SHADERS ActiveAttributes -> gl_ACTIVE_ATTRIBUTES ActiveAttributeMaxLength -> gl_ACTIVE_ATTRIBUTE_MAX_LENGTH ActiveUniforms -> gl_ACTIVE_UNIFORMS ActiveUniformMaxLength -> gl_ACTIVE_UNIFORM_MAX_LENGTH TransformFeedbackBufferMode -> gl_TRANSFORM_FEEDBACK_BUFFER_MODE TransformFeedbackVaryings -> gl_TRANSFORM_FEEDBACK_VARYINGS TransformFeedbackVaryingMaxLength -> gl_TRANSFORM_FEEDBACK_VARYING_MAX_LENGTH ActiveUniformBlocks -> gl_ACTIVE_UNIFORM_BLOCKS ActiveUniformBlockMaxNameLength -> gl_ACTIVE_UNIFORM_BLOCK_MAX_NAME_LENGTH GeometryVerticesOut -> gl_GEOMETRY_VERTICES_OUT GeometryInputType -> gl_GEOMETRY_INPUT_TYPE GeometryOutputType -> gl_GEOMETRY_OUTPUT_TYPE GeometryShaderInvocations -> gl_GEOMETRY_SHADER_INVOCATIONS TessControlOutputVertices -> gl_TESS_CONTROL_OUTPUT_VERTICES TessGenMode -> gl_TESS_GEN_MODE TessGenSpacing -> gl_TESS_GEN_SPACING TessGenVertexOrder -> gl_TESS_GEN_VERTEX_ORDER TessGenPointMode -> gl_TESS_GEN_POINT_MODE ComputeWorkGroupSize -> gl_COMPUTE_WORK_GROUP_SIZE ProgramSeparable -> gl_PROGRAM_SEPARABLE ProgramBinaryRetrievableHint -> gl_PROGRAM_BINARY_RETRIEVABLE_HINT ActiveAtomicCounterBuffers -> gl_ACTIVE_ATOMIC_COUNTER_BUFFERS ProgramBinaryLength -> gl_PROGRAM_BINARY_LENGTH programVar1 :: (GLint -> a) -> GetProgramPName -> Program -> GettableStateVar a programVar1 = programVarN . peek1 programVar3 :: (GLint -> GLint -> GLint -> a) -> GetProgramPName -> Program -> GettableStateVar a programVar3 = programVarN . peek3 programVarN :: (Ptr GLint -> IO a) -> GetProgramPName -> Program -> GettableStateVar a programVarN f p program = makeGettableStateVar $ with 0 $ \buf -> do glGetProgramiv (programID program) (marshalGetProgramPName p) buf f buf OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Shaders/Shader.hs0000644000000000000000000000230512521420345022270 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Shaders.Shader -- Copyright : (c) Sven Panne 2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for handling shader objects. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Shaders.Shader ( Shader(..) ) where import Control.Monad.IO.Class import Data.ObjectName import Graphics.Rendering.OpenGL.GL.DebugOutput import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- newtype Shader = Shader { shaderID :: GLuint } deriving ( Eq, Ord, Show ) instance ObjectName Shader where isObjectName = liftIO . fmap unmarshalGLboolean . glIsShader . shaderID deleteObjectName = liftIO . glDeleteShader . shaderID instance CanBeLabeled Shader where objectLabel = objectNameLabel gl_SHADER . shaderID OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Shaders/ProgramBinaries.hs0000644000000000000000000000444112521420345024151 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Shaders.ProgramBinaries -- Copyright : (c) Sven Panne 2006-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 7.5 (Program Binaries) of the OpenGL 4.4 -- spec. -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Shaders.ProgramBinaries ( ProgramBinaryFormat(..), programBinaryFormats, ProgramBinary(..), programBinary ) where import Data.StateVar import Foreign.Marshal.Alloc import Graphics.Rendering.OpenGL.GL.ByteString import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.Shaders.Program import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- newtype ProgramBinaryFormat = ProgramBinaryFormat GLenum deriving ( Eq, Ord, Show ) programBinaryFormats :: GettableStateVar [ProgramBinaryFormat] programBinaryFormats = makeGettableStateVar $ do n <- getInteger1 fromIntegral GetNumProgramBinaryFormats getEnumN ProgramBinaryFormat GetProgramBinaryFormats n data ProgramBinary = ProgramBinary ProgramBinaryFormat ByteString deriving ( Eq, Ord, Show ) programBinary :: Program -> StateVar ProgramBinary programBinary program = makeStateVar (getProgramBinary program) (setProgramBinary program) getProgramBinary :: Program -> IO ProgramBinary getProgramBinary program = alloca $ \formatBuf -> do let getBin = bind4th formatBuf (glGetProgramBinary . programID) bs <- stringQuery programBinaryLength getBin program format <- peek1 ProgramBinaryFormat formatBuf return $ ProgramBinary format bs bind4th :: d -> (a -> b -> c -> d -> e) -> (a -> b -> c -> e) bind4th x = ((.) . (.) . (.)) ($ x) setProgramBinary :: Program -> ProgramBinary -> IO () setProgramBinary program (ProgramBinary (ProgramBinaryFormat format) bs) = do withByteString bs $ glProgramBinary (programID program) format programBinaryLength :: Program -> GettableStateVar GLsizei programBinaryLength = programVar1 fromIntegral ProgramBinaryLength OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Shaders/Uniform.hs0000644000000000000000000002173212521420345022506 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Shaders.Uniform -- Copyright : (c) Sven Panne 2006-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module contains functions related to shader uniforms, this corresponds -- to section 2.20.3 of the OpenGL 3.1 spec (Shader Variables). -- ----------------------------------------------------------------------------- {-# LANGUAGE TypeSynonymInstances #-} module Graphics.Rendering.OpenGL.GL.Shaders.Uniform ( -- * Uniform variables UniformLocation(..), uniformLocation, activeUniforms, Uniform(..), UniformComponent, -- TODO: glGetUniformSubroutineuiv ) where import Data.Maybe import Data.StateVar import Foreign.Marshal.Alloc import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.GL.ByteString import Graphics.Rendering.OpenGL.GL.Shaders.Program import Graphics.Rendering.OpenGL.GL.Shaders.ProgramObjects import Graphics.Rendering.OpenGL.GL.Shaders.Variables import Graphics.Rendering.OpenGL.GL.Tensor import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- numActiveUniforms :: Program -> GettableStateVar GLuint numActiveUniforms = programVar1 fromIntegral ActiveUniforms activeUniformMaxLength :: Program -> GettableStateVar GLsizei activeUniformMaxLength = programVar1 fromIntegral ActiveUniformMaxLength -------------------------------------------------------------------------------- newtype UniformLocation = UniformLocation GLint deriving ( Eq, Ord, Show ) uniformLocation :: Program -> String -> GettableStateVar UniformLocation uniformLocation (Program program) name = makeGettableStateVar $ fmap UniformLocation $ withGLstring name $ glGetUniformLocation program -------------------------------------------------------------------------------- activeUniforms :: Program -> GettableStateVar [(GLint,VariableType,String)] activeUniforms = activeVars numActiveUniforms activeUniformMaxLength glGetActiveUniform unmarshalVariableType -------------------------------------------------------------------------------- class Storable a => UniformComponent a where uniform1 :: UniformLocation -> a -> IO () uniform2 :: UniformLocation -> a -> a -> IO () uniform3 :: UniformLocation -> a -> a -> a -> IO () uniform4 :: UniformLocation -> a -> a -> a -> a -> IO () getUniform :: Storable (b a) => Program -> UniformLocation -> Ptr (b a) -> IO () uniform1v :: UniformLocation -> GLsizei -> Ptr a -> IO () uniform2v :: UniformLocation -> GLsizei -> Ptr a -> IO () uniform3v :: UniformLocation -> GLsizei -> Ptr a -> IO () uniform4v :: UniformLocation -> GLsizei -> Ptr a -> IO () instance UniformComponent GLint where uniform1 (UniformLocation ul) = glUniform1i ul uniform2 (UniformLocation ul) = glUniform2i ul uniform3 (UniformLocation ul) = glUniform3i ul uniform4 (UniformLocation ul) = glUniform4i ul getUniform (Program p) (UniformLocation ul) = glGetUniformiv p ul . castPtr uniform1v (UniformLocation ul) = glUniform1iv ul uniform2v (UniformLocation ul) = glUniform2iv ul uniform3v (UniformLocation ul) = glUniform3iv ul uniform4v (UniformLocation ul) = glUniform4iv ul instance UniformComponent GLuint where uniform1 (UniformLocation ul) = glUniform1ui ul uniform2 (UniformLocation ul) = glUniform2ui ul uniform3 (UniformLocation ul) = glUniform3ui ul uniform4 (UniformLocation ul) = glUniform4ui ul getUniform (Program p) (UniformLocation ul) = glGetUniformuiv p ul . castPtr uniform1v (UniformLocation ul) = glUniform1uiv ul uniform2v (UniformLocation ul) = glUniform2uiv ul uniform3v (UniformLocation ul) = glUniform3uiv ul uniform4v (UniformLocation ul) = glUniform4uiv ul instance UniformComponent GLfloat where uniform1 (UniformLocation ul) = glUniform1f ul uniform2 (UniformLocation ul) = glUniform2f ul uniform3 (UniformLocation ul) = glUniform3f ul uniform4 (UniformLocation ul) = glUniform4f ul getUniform (Program p) (UniformLocation ul) = glGetUniformfv p ul . castPtr uniform1v (UniformLocation ul) = glUniform1fv ul uniform2v (UniformLocation ul) = glUniform2fv ul uniform3v (UniformLocation ul) = glUniform3fv ul uniform4v (UniformLocation ul) = glUniform4fv ul -------------------------------------------------------------------------------- class Uniform a where uniform :: UniformLocation -> StateVar a uniformv :: UniformLocation -> GLsizei -> Ptr a -> IO () maxComponentSize :: Int maxComponentSize = sizeOf (undefined :: GLint) `max` sizeOf (undefined :: GLfloat) maxNumComponents :: Int maxNumComponents = 16 maxUniformBufferSize :: Int maxUniformBufferSize = maxComponentSize * maxNumComponents makeUniformVar :: (UniformComponent a, Storable (b a)) => (UniformLocation -> b a -> IO ()) -> UniformLocation -> StateVar (b a) makeUniformVar setter location = makeStateVar getter (setter location) where getter = do program <- fmap fromJust $ get currentProgram allocaBytes maxUniformBufferSize $ \buf -> do getUniform program location buf peek buf instance UniformComponent a => Uniform (Vertex2 a) where uniform = makeUniformVar $ \location (Vertex2 x y) -> uniform2 location x y uniformv location count = uniform2v location count . (castPtr :: Ptr (Vertex2 b) -> Ptr b) instance UniformComponent a => Uniform (Vertex3 a) where uniform = makeUniformVar $ \location (Vertex3 x y z) -> uniform3 location x y z uniformv location count = uniform3v location count . (castPtr :: Ptr (Vertex3 b) -> Ptr b) instance UniformComponent a => Uniform (Vertex4 a) where uniform = makeUniformVar $ \location (Vertex4 x y z w) -> uniform4 location x y z w uniformv location count = uniform4v location count . (castPtr :: Ptr (Vertex4 b) -> Ptr b) instance UniformComponent a => Uniform (TexCoord1 a) where uniform = makeUniformVar $ \location (TexCoord1 s) -> uniform1 location s uniformv location count = uniform1v location count . (castPtr :: Ptr (TexCoord1 b) -> Ptr b) instance UniformComponent a => Uniform (TexCoord2 a) where uniform = makeUniformVar $ \location (TexCoord2 s t) -> uniform2 location s t uniformv location count = uniform2v location count . (castPtr :: Ptr (TexCoord2 b) -> Ptr b) instance UniformComponent a => Uniform (TexCoord3 a) where uniform = makeUniformVar $ \location (TexCoord3 s t r) -> uniform3 location s t r uniformv location count = uniform3v location count . (castPtr :: Ptr (TexCoord3 b) -> Ptr b) instance UniformComponent a => Uniform (TexCoord4 a) where uniform = makeUniformVar $ \location (TexCoord4 s t r q) -> uniform4 location s t r q uniformv location count = uniform4v location count . (castPtr :: Ptr (TexCoord4 b) -> Ptr b) instance UniformComponent a => Uniform (Normal3 a) where uniform = makeUniformVar $ \location (Normal3 x y z) -> uniform3 location x y z uniformv location count = uniform3v location count . (castPtr :: Ptr (Normal3 b) -> Ptr b) instance UniformComponent a => Uniform (FogCoord1 a) where uniform = makeUniformVar $ \location (FogCoord1 c) -> uniform1 location c uniformv location count = uniform1v location count . (castPtr :: Ptr (FogCoord1 b) -> Ptr b) instance UniformComponent a => Uniform (Color3 a) where uniform = makeUniformVar $ \location (Color3 r g b) -> uniform3 location r g b uniformv location count = uniform3v location count . (castPtr :: Ptr (Color3 b) -> Ptr b) instance UniformComponent a => Uniform (Color4 a) where uniform = makeUniformVar $ \location (Color4 r g b a) -> uniform4 location r g b a uniformv location count = uniform4v location count . (castPtr :: Ptr (Color4 b) -> Ptr b) instance UniformComponent a => Uniform (Index1 a) where uniform = makeUniformVar $ \location (Index1 i) -> uniform1 location i uniformv location count = uniform1v location count . (castPtr :: Ptr (Index1 b) -> Ptr b) -- Nasty instance declaration as TextureUnit is not of the form Storable (b a) as required for -- getUniform. Even worse is that it requires the `GLint` uniforms while it is an enum or -- uint. instance Uniform TextureUnit where uniform loc@(UniformLocation ul) = makeStateVar getter setter where setter (TextureUnit tu) = uniform1 loc (fromIntegral tu :: GLint) getter = do program <- fmap fromJust $ get currentProgram allocaBytes (sizeOf (undefined :: GLint)) $ \buf -> do glGetUniformiv (programID program) ul buf tuID <- peek buf return . TextureUnit $ fromIntegral tuID uniformv location count = uniform1v location count . (castPtr :: Ptr TextureUnit -> Ptr GLint) -------------------------------------------------------------------------------- OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Shaders/Limits.hs0000644000000000000000000000655612521420345022337 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Shaders.Limits -- Copyright : (c) Sven Panne 2006-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module contains functions related to shader limits. -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Shaders.Limits ( maxVertexTextureImageUnits, maxTextureImageUnits, maxCombinedTextureImageUnits, maxTextureCoords, maxVertexUniformComponents, maxFragmentUniformComponents, maxVertexAttribs, maxVaryingFloats, maxTessGenLevel ) where import Data.StateVar import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw ----------------------------------------------------------------------------- -- | Contains the number of hardware units that can be used to access texture -- maps from the vertex processor. The minimum legal value is 0. maxVertexTextureImageUnits :: GettableStateVar GLsizei maxVertexTextureImageUnits = getLimit GetMaxVertexTextureImageUnits -- | Contains the total number of hardware units that can be used to access -- texture maps from the fragment processor. The minimum legal value is 2. maxTextureImageUnits :: GettableStateVar GLsizei maxTextureImageUnits = getLimit GetMaxTextureImageUnits -- | Contains the total number of hardware units that can be used to access -- texture maps from the vertex processor and the fragment processor combined. -- Note: If the vertex shader and the fragment processing stage access the same -- texture image unit, then that counts as using two texture image units. The -- minimum legal value is 2. maxCombinedTextureImageUnits :: GettableStateVar GLsizei maxCombinedTextureImageUnits = getLimit GetMaxCombinedTextureImageUnits -- | Contains the number of texture coordinate sets that are available. The -- minimum legal value is 2. maxTextureCoords :: GettableStateVar GLsizei maxTextureCoords = getLimit GetMaxTextureCoords -- | Contains the number of individual components (i.e., floating-point, integer -- or boolean values) that are available for vertex shader uniform variables. -- The minimum legal value is 512. maxVertexUniformComponents :: GettableStateVar GLsizei maxVertexUniformComponents = getLimit GetMaxVertexUniformComponents -- | Contains the number of individual components (i.e., floating-point, integer -- or boolean values) that are available for fragment shader uniform variables. -- The minimum legal value is 64. maxFragmentUniformComponents :: GettableStateVar GLsizei maxFragmentUniformComponents = getLimit GetMaxFragmentUniformComponents -- | Contains the number of active vertex attributes that are available. The -- minimum legal value is 16. maxVertexAttribs :: GettableStateVar GLsizei maxVertexAttribs = getLimit GetMaxVertexAttribs -- | Contains the number of individual floating-point values available for -- varying variables. The minimum legal value is 32. maxVaryingFloats :: GettableStateVar GLsizei maxVaryingFloats = getLimit GetMaxVaryingFloats -- | Contains the maximum allowed tessellation level. maxTessGenLevel :: GettableStateVar GLsizei maxTessGenLevel = getLimit GetMaxTessGenLevel getLimit :: PName1I -> GettableStateVar GLsizei getLimit = makeGettableStateVar . getSizei1 id OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Shaders/Variables.hs0000644000000000000000000001271212521420345022775 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Shaders.Variables -- Copyright : (c) Sven Panne 2006-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This internal module contains the functions and data types used by the -- Uniform and Attribs modules. -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Shaders.Variables ( VariableType(..), unmarshalVariableType, activeVars ) where import Control.Monad import Data.StateVar import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.GL.ByteString import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.Shaders.Program import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- Table 2.9 of the OpenGL 3.1 spec: OpenGL Shading Language type tokens data VariableType = Float' | FloatVec2 | FloatVec3 | FloatVec4 | Int' | IntVec2 | IntVec3 | IntVec4 | UnsignedInt' | UnsignedIntVec2 | UnsignedIntVec3 | UnsignedIntVec4 | Bool | BoolVec2 | BoolVec3 | BoolVec4 | FloatMat2 | FloatMat3 | FloatMat4 | FloatMat2x3 | FloatMat2x4 | FloatMat3x2 | FloatMat3x4 | FloatMat4x2 | FloatMat4x3 | Sampler1D | Sampler2D | Sampler3D | SamplerCube | Sampler1DShadow | Sampler2DShadow | Sampler1DArray | Sampler2DArray | Sampler1DArrayShadow | Sampler2DArrayShadow | SamplerCubeShadow | Sampler2DRect | Sampler2DRectShadow | IntSampler1D | IntSampler2D | IntSampler3D | IntSamplerCube | IntSampler1DArray | IntSampler2DArray | UnsignedIntSampler1D | UnsignedIntSampler2D | UnsignedIntSampler3D | UnsignedIntSamplerCube | UnsignedIntSampler1DArray | UnsignedIntSampler2DArray deriving ( Eq, Ord, Show ) unmarshalVariableType :: GLenum -> VariableType unmarshalVariableType x | x == gl_FLOAT = Float' | x == gl_FLOAT_VEC2 = FloatVec2 | x == gl_FLOAT_VEC3 = FloatVec3 | x == gl_FLOAT_VEC4 = FloatVec4 | x == gl_INT = Int' | x == gl_INT_VEC2 = IntVec2 | x == gl_INT_VEC3 = IntVec3 | x == gl_INT_VEC4 = IntVec4 | x == gl_UNSIGNED_INT = UnsignedInt' | x == gl_UNSIGNED_INT_VEC2 = UnsignedIntVec2 | x == gl_UNSIGNED_INT_VEC3 = UnsignedIntVec3 | x == gl_UNSIGNED_INT_VEC4 = UnsignedIntVec4 | x == gl_BOOL = Bool | x == gl_BOOL_VEC2 = BoolVec2 | x == gl_BOOL_VEC3 = BoolVec3 | x == gl_BOOL_VEC4 = BoolVec4 | x == gl_FLOAT_MAT2 = FloatMat2 | x == gl_FLOAT_MAT3 = FloatMat3 | x == gl_FLOAT_MAT4 = FloatMat4 | x == gl_FLOAT_MAT2x3 = FloatMat2x3 | x == gl_FLOAT_MAT2x4 = FloatMat2x4 | x == gl_FLOAT_MAT3x2 = FloatMat3x2 | x == gl_FLOAT_MAT3x4 = FloatMat3x4 | x == gl_FLOAT_MAT4x2 = FloatMat4x2 | x == gl_FLOAT_MAT4x3 = FloatMat4x3 | x == gl_SAMPLER_1D = Sampler1D | x == gl_SAMPLER_2D = Sampler2D | x == gl_SAMPLER_3D = Sampler3D | x == gl_SAMPLER_CUBE = SamplerCube | x == gl_SAMPLER_1D_SHADOW = Sampler1DShadow | x == gl_SAMPLER_2D_SHADOW = Sampler2DShadow | x == gl_SAMPLER_1D_ARRAY = Sampler1DArray | x == gl_SAMPLER_2D_ARRAY = Sampler2DArray | x == gl_SAMPLER_1D_ARRAY_SHADOW = Sampler1DArrayShadow | x == gl_SAMPLER_2D_ARRAY_SHADOW = Sampler2DArrayShadow | x == gl_SAMPLER_CUBE_SHADOW = SamplerCubeShadow | x == gl_SAMPLER_2D_RECT = Sampler2DRect | x == gl_SAMPLER_2D_RECT_SHADOW = Sampler2DRectShadow | x == gl_INT_SAMPLER_1D = IntSampler1D | x == gl_INT_SAMPLER_2D = IntSampler2D | x == gl_INT_SAMPLER_3D = IntSampler3D | x == gl_INT_SAMPLER_CUBE = IntSamplerCube | x == gl_INT_SAMPLER_1D_ARRAY = IntSampler1DArray | x == gl_INT_SAMPLER_2D_ARRAY = IntSampler2DArray | x == gl_UNSIGNED_INT_SAMPLER_1D = UnsignedIntSampler1D | x == gl_UNSIGNED_INT_SAMPLER_2D = UnsignedIntSampler2D | x == gl_UNSIGNED_INT_SAMPLER_3D = UnsignedIntSampler3D | x == gl_UNSIGNED_INT_SAMPLER_CUBE = UnsignedIntSamplerCube | x == gl_UNSIGNED_INT_SAMPLER_1D_ARRAY = UnsignedIntSampler1DArray | x == gl_UNSIGNED_INT_SAMPLER_2D_ARRAY = UnsignedIntSampler2DArray | otherwise = error ("unmarshalVariableType: illegal value " ++ show x) -------------------------------------------------------------------------------- activeVars :: (Program -> GettableStateVar GLuint) -> (Program -> GettableStateVar GLsizei) -> (GLuint -> GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLint -> Ptr GLenum -> Ptr GLchar -> IO ()) -> (GLenum -> a) -> Program -> GettableStateVar [(GLint,a,String)] activeVars numVars maxLength getter unmarshalType p@(Program program) = makeGettableStateVar $ do numActiveVars <- get (numVars p) maxLen <- get (maxLength p) with 0 $ \nameLengthBuf -> with 0 $ \sizeBuf -> with 0 $ \typeBuf -> let ixs = if numActiveVars > 0 then [0 .. numActiveVars-1] else [] in forM ixs $ \i -> do n <- createAndTrimByteString maxLen $ \nameBuf -> do getter program i maxLen nameLengthBuf sizeBuf typeBuf nameBuf peek nameLengthBuf s <- peek1 fromIntegral sizeBuf t <- peek1 unmarshalType typeBuf return (s, t, unpackUtf8 n) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Shaders/ShaderObjects.hs0000644000000000000000000001511412521420345023604 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Shaders.ShaderObjects -- Copyright : (c) Sven Panne 2006-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 7.1 (Shader Objects) and 7.13 (Shader, -- Program, and Program Pipeline Queries) of the OpenGL 4.4 spec. -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Shaders.ShaderObjects ( -- * Shader Objects shaderCompiler, ShaderType(..), Shader, createShader, shaderSourceBS, shaderSource, compileShader, releaseShaderCompiler, -- * Shader Queries shaderType, shaderDeleteStatus, compileStatus, shaderInfoLog, PrecisionType, shaderPrecisionFormat, -- * Bytestring utilities packUtf8, unpackUtf8 ) where import Control.Monad import Data.StateVar import Foreign.Marshal.Alloc import Foreign.Marshal.Array import Foreign.Marshal.Utils import Foreign.Storable import Graphics.Rendering.OpenGL.GL.ByteString import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.Shaders.Shader import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- shaderCompiler :: GettableStateVar Bool shaderCompiler = makeGettableStateVar (getBoolean1 unmarshalGLboolean GetShaderCompiler) -------------------------------------------------------------------------------- data ShaderType = VertexShader | TessControlShader | TessEvaluationShader | GeometryShader | FragmentShader | ComputeShader deriving ( Eq, Ord, Show ) marshalShaderType :: ShaderType -> GLenum marshalShaderType x = case x of VertexShader -> gl_VERTEX_SHADER TessControlShader -> gl_TESS_CONTROL_SHADER TessEvaluationShader -> gl_TESS_EVALUATION_SHADER GeometryShader -> gl_GEOMETRY_SHADER FragmentShader -> gl_FRAGMENT_SHADER ComputeShader -> gl_COMPUTE_SHADER unmarshalShaderType :: GLenum -> ShaderType unmarshalShaderType x | x == gl_VERTEX_SHADER = VertexShader | x == gl_TESS_CONTROL_SHADER = TessControlShader | x == gl_TESS_EVALUATION_SHADER = TessEvaluationShader | x == gl_GEOMETRY_SHADER = GeometryShader | x == gl_FRAGMENT_SHADER = FragmentShader | x == gl_COMPUTE_SHADER = ComputeShader | otherwise = error ("unmarshalShaderType: illegal value " ++ show x) -------------------------------------------------------------------------------- createShader :: ShaderType -> IO Shader createShader = fmap Shader . glCreateShader . marshalShaderType -------------------------------------------------------------------------------- -- | UTF8 encoded. shaderSourceBS :: Shader -> StateVar ByteString shaderSourceBS shader = makeStateVar (getShaderSource shader) (setShaderSource shader) getShaderSource :: Shader -> IO ByteString getShaderSource = stringQuery shaderSourceLength (glGetShaderSource . shaderID) shaderSourceLength :: Shader -> GettableStateVar GLsizei shaderSourceLength = shaderVar fromIntegral ShaderSourceLength setShaderSource :: Shader -> ByteString -> IO () setShaderSource shader src = withByteString src $ \srcPtr srcLength -> with srcPtr $ \srcPtrBuf -> with srcLength $ \srcLengthBuf -> glShaderSource (shaderID shader) 1 srcPtrBuf srcLengthBuf {-# DEPRECATED shaderSource "Use a combination of 'shaderSourceBS' and 'packUtf8' or 'unpackUtf8' instead." #-} shaderSource :: Shader -> StateVar [String] shaderSource shader = makeStateVar (fmap ((:[]) . unpackUtf8) $ get (shaderSourceBS shader)) ((shaderSourceBS shader $=) . packUtf8 . concat) -------------------------------------------------------------------------------- compileShader :: Shader -> IO () compileShader = glCompileShader . shaderID releaseShaderCompiler :: IO () releaseShaderCompiler = glReleaseShaderCompiler -------------------------------------------------------------------------------- shaderType :: Shader -> GettableStateVar ShaderType shaderType = shaderVar (unmarshalShaderType . fromIntegral) ShaderType shaderDeleteStatus :: Shader -> GettableStateVar Bool shaderDeleteStatus = shaderVar unmarshalGLboolean ShaderDeleteStatus compileStatus :: Shader -> GettableStateVar Bool compileStatus = shaderVar unmarshalGLboolean CompileStatus shaderInfoLog :: Shader -> GettableStateVar String shaderInfoLog = makeGettableStateVar . fmap unpackUtf8 . stringQuery shaderInfoLogLength (glGetShaderInfoLog . shaderID) shaderInfoLogLength :: Shader -> GettableStateVar GLsizei shaderInfoLogLength = shaderVar fromIntegral ShaderInfoLogLength -------------------------------------------------------------------------------- data GetShaderPName = ShaderDeleteStatus | CompileStatus | ShaderInfoLogLength | ShaderSourceLength | ShaderType marshalGetShaderPName :: GetShaderPName -> GLenum marshalGetShaderPName x = case x of ShaderDeleteStatus -> gl_DELETE_STATUS CompileStatus -> gl_COMPILE_STATUS ShaderInfoLogLength -> gl_INFO_LOG_LENGTH ShaderSourceLength -> gl_SHADER_SOURCE_LENGTH ShaderType -> gl_SHADER_TYPE shaderVar :: (GLint -> a) -> GetShaderPName -> Shader -> GettableStateVar a shaderVar f p shader = makeGettableStateVar $ with 0 $ \buf -> do glGetShaderiv (shaderID shader) (marshalGetShaderPName p) buf peek1 f buf -------------------------------------------------------------------------------- data PrecisionType = LowFloat | MediumFloat | HighFloat | LowInt | MediumInt | HighInt deriving ( Eq, Ord, Show ) marshalPrecisionType :: PrecisionType -> GLenum marshalPrecisionType x = case x of LowFloat -> gl_LOW_FLOAT MediumFloat -> gl_MEDIUM_FLOAT HighFloat -> gl_HIGH_FLOAT LowInt -> gl_LOW_INT MediumInt -> gl_MEDIUM_INT HighInt -> gl_HIGH_INT -------------------------------------------------------------------------------- shaderPrecisionFormat :: ShaderType -> PrecisionType -> GettableStateVar ((GLint,GLint),GLint) shaderPrecisionFormat st pt = makeGettableStateVar $ allocaArray 2 $ \rangeBuf -> alloca $ \precisionBuf -> do glGetShaderPrecisionFormat (marshalShaderType st) (marshalPrecisionType pt) rangeBuf precisionBuf liftM2 (,) (peek2 (,) rangeBuf) (peek precisionBuf) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Shaders/ProgramObjects.hs0000644000000000000000000001414312521420345024006 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Shaders.ProgramObjects -- Copyright : (c) Sven Panne 2006-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 7.3 (Program Objects) of the OpenGL 4.4 -- spec. -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Shaders.ProgramObjects ( -- * Program Objects Program, createProgram, programDeleteStatus, attachShader, detachShader, attachedShaders, linkProgram, linkStatus, validateProgram, validateStatus, programInfoLog, currentProgram, programSeparable, programBinaryRetrievableHint, -- TODOs: -- glCreateShaderProgramv -- ProgramInterface type (from 7.3.1) -- glGetProgramInterfaceiv -- glGetProgramResourceIndex -- glGetProgramResourceName -- glGetProgramResourceiv -- glGetProgramResourceLocation -- glGetProgramResourceLocationIndex -- * Fragment Data bindFragDataLocation, getFragDataLocation ) where import Data.List import Data.Maybe import Data.StateVar import Foreign.Marshal.Array import Foreign.Ptr import Graphics.Rendering.OpenGL.GL.ByteString import Graphics.Rendering.OpenGL.GL.Framebuffer import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.Shaders.Program import Graphics.Rendering.OpenGL.GL.Shaders.Shader import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- createProgram :: IO Program createProgram = fmap Program glCreateProgram -------------------------------------------------------------------------------- attachShader :: Program -> Shader -> IO () attachShader p s = glAttachShader (programID p) (shaderID s) detachShader :: Program -> Shader -> IO () detachShader p s = glDetachShader (programID p) (shaderID s) attachedShaders :: Program -> StateVar [Shader] attachedShaders program = makeStateVar (getAttachedShaders program) (setAttachedShaders program) getAttachedShaders :: Program -> IO [Shader] getAttachedShaders program = do numShaders <- get (numAttachedShaders program) ids <- allocaArray (fromIntegral numShaders) $ \buf -> do glGetAttachedShaders (programID program) numShaders nullPtr buf peekArray (fromIntegral numShaders) buf return $ map Shader ids setAttachedShaders :: Program -> [Shader] -> IO () setAttachedShaders program newShaders = do currentShaders <- getAttachedShaders program mapM_ (attachShader program) (newShaders \\ currentShaders) mapM_ (detachShader program) (currentShaders \\ newShaders) -------------------------------------------------------------------------------- linkProgram :: Program -> IO () linkProgram = glLinkProgram . programID currentProgram :: StateVar (Maybe Program) currentProgram = makeStateVar (do p <- fmap Program $ getInteger1 fromIntegral GetCurrentProgram return $ if p == noProgram then Nothing else Just p) (glUseProgram . programID . fromMaybe noProgram) noProgram :: Program noProgram = Program 0 validateProgram :: Program -> IO () validateProgram = glValidateProgram . programID programInfoLog :: Program -> GettableStateVar String programInfoLog = makeGettableStateVar . fmap unpackUtf8 . stringQuery programInfoLogLength (glGetProgramInfoLog . programID) -------------------------------------------------------------------------------- programSeparable :: Program -> StateVar Bool programSeparable = programStateVarBool ProgramSeparable programBinaryRetrievableHint :: Program -> StateVar Bool programBinaryRetrievableHint = programStateVarBool ProgramBinaryRetrievableHint programStateVarBool :: GetProgramPName -> Program -> StateVar Bool programStateVarBool pname program = makeStateVar (get (programVar1 unmarshalGLboolean pname program)) (glProgramParameteri (programID program) (marshalGetProgramPName pname) . marshalGLboolean) -------------------------------------------------------------------------------- programDeleteStatus :: Program -> GettableStateVar Bool programDeleteStatus = programVar1 unmarshalGLboolean ProgramDeleteStatus linkStatus :: Program -> GettableStateVar Bool linkStatus = programVar1 unmarshalGLboolean LinkStatus validateStatus :: Program -> GettableStateVar Bool validateStatus = programVar1 unmarshalGLboolean ValidateStatus programInfoLogLength :: Program -> GettableStateVar GLsizei programInfoLogLength = programVar1 fromIntegral ProgramInfoLogLength numAttachedShaders :: Program -> GettableStateVar GLsizei numAttachedShaders = programVar1 fromIntegral AttachedShaders -------------------------------------------------------------------------------- -- | 'bindFragDataLocation' binds a varying variable, specified by program and name, to a -- drawbuffer. The effects only take place after succesfull linking of the program. -- invalid arguments and conditions are -- - an index larger than maxDrawBufferIndex -- - names starting with 'gl_' -- linking failure will ocure when -- - one of the arguments was invalid -- - more than one varying varuable name is bound to the same index -- It's not an error to specify unused variables, those will be ingored. bindFragDataLocation :: Program -> String -> SettableStateVar DrawBufferIndex bindFragDataLocation (Program program) varName = makeSettableStateVar $ \ind -> withGLstring varName $ glBindFragDataLocation program ind -- | query the binding of a given variable, specified by program and name. The program has to be -- linked. The result is Nothing if an error occures or the name is not a name of a varying -- variable. If the program hasn't been linked an 'InvalidOperation' error is generated. getFragDataLocation :: Program -> String -> IO (Maybe DrawBufferIndex) getFragDataLocation (Program program) varName = do r <- withGLstring varName $ glGetFragDataLocation program if r < 0 then return Nothing else return . Just $ fromIntegral r OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Texturing/0000755000000000000000000000000012521420345021126 5ustar0000000000000000OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Texturing/Parameters.hs0000644000000000000000000002251012521420345023565 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.Parameters -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 3.8.4 (Texture Parameters), section 3.8.7 -- (Texture Wrap Mode), section 3.8.8 (Texture Minification), and section 3.8.9 -- (Texture Magnification) of the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Texturing.Parameters ( TextureFilter(..), MinificationFilter, MagnificationFilter, textureFilter, Repetition(..), Clamping(..), textureWrapMode, textureBorderColor, LOD, textureObjectLODBias, maxTextureLODBias, textureLODRange, textureMaxAnisotropy, maxTextureMaxAnisotropy, textureLevelRange, generateMipmap, depthTextureMode, textureCompareMode, textureCompareFailValue, TextureCompareOperator(..), textureCompareOperator ) where import Control.Monad import Data.StateVar import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.ComparisonFunction import Graphics.Rendering.OpenGL.GL.CoordTrans import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.Texturing.Filter import Graphics.Rendering.OpenGL.GL.Texturing.PixelInternalFormat import Graphics.Rendering.OpenGL.GL.Texturing.Specification import Graphics.Rendering.OpenGL.GL.Texturing.TexParameter import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- textureFilter :: ParameterizedTextureTarget t => t -> StateVar (MinificationFilter, MagnificationFilter) textureFilter = combineTexParams (texParami unmarshalMinificationFilter marshalMinificationFilter TextureMinFilter) (texParami unmarshalMagnificationFilter marshalMagnificationFilter TextureMagFilter) -------------------------------------------------------------------------------- data Repetition = Repeated | Mirrored deriving ( Eq, Ord, Show ) data Clamping = Clamp | Repeat | ClampToEdge | ClampToBorder deriving ( Eq, Ord, Show ) marshalTextureWrapMode :: (Repetition, Clamping) -> GLint marshalTextureWrapMode x = fromIntegral $ case x of (Repeated, Clamp) -> gl_CLAMP (Repeated, Repeat) -> gl_REPEAT (Repeated, ClampToEdge) -> gl_CLAMP_TO_EDGE (Repeated, ClampToBorder) -> gl_CLAMP_TO_BORDER (Mirrored, Clamp) -> gl_MIRROR_CLAMP_EXT (Mirrored, Repeat) -> gl_MIRRORED_REPEAT (Mirrored, ClampToEdge) -> gl_MIRROR_CLAMP_TO_EDGE (Mirrored, ClampToBorder) -> gl_MIRROR_CLAMP_TO_BORDER_EXT unmarshalTextureWrapMode :: GLint -> (Repetition, Clamping) unmarshalTextureWrapMode x | y == gl_CLAMP = (Repeated, Clamp) | y == gl_REPEAT = (Repeated, Repeat) | y == gl_CLAMP_TO_EDGE = (Repeated, ClampToEdge) | y == gl_CLAMP_TO_BORDER = (Repeated, ClampToBorder) | y == gl_MIRROR_CLAMP_EXT = (Mirrored, Clamp) | y == gl_MIRRORED_REPEAT = (Mirrored, Repeat) | y == gl_MIRROR_CLAMP_TO_EDGE = (Mirrored, ClampToEdge) | y == gl_MIRROR_CLAMP_TO_BORDER_EXT = (Mirrored, ClampToBorder) | otherwise = error ("unmarshalTextureWrapMode: illegal value " ++ show x) where y = fromIntegral x -------------------------------------------------------------------------------- textureWrapMode :: ParameterizedTextureTarget t => t -> TextureCoordName -> StateVar (Repetition,Clamping) textureWrapMode t coord = case coord of S -> wrap TextureWrapS T -> wrap TextureWrapT R -> wrap TextureWrapR Q -> invalidTextureCoord where wrap c = texParami unmarshalTextureWrapMode marshalTextureWrapMode c t invalidTextureCoord :: StateVar (Repetition,Clamping) invalidTextureCoord = makeStateVar (do recordInvalidEnum; return (Repeated, Repeat)) (const recordInvalidEnum) -------------------------------------------------------------------------------- textureBorderColor :: ParameterizedTextureTarget t => t -> StateVar (Color4 GLfloat) textureBorderColor = texParamC4f TextureBorderColor -------------------------------------------------------------------------------- type LOD = GLfloat textureObjectLODBias :: ParameterizedTextureTarget t => t -> StateVar LOD textureObjectLODBias = texParamf id id TextureLODBias maxTextureLODBias :: GettableStateVar LOD maxTextureLODBias = makeGettableStateVar (getFloat1 id GetMaxTextureLODBias) textureLODRange :: ParameterizedTextureTarget t => t -> StateVar (LOD,LOD) textureLODRange = combineTexParams (texParamf id id TextureMinLOD) (texParamf id id TextureMaxLOD) -------------------------------------------------------------------------------- textureMaxAnisotropy :: ParameterizedTextureTarget t => t -> StateVar GLfloat textureMaxAnisotropy = texParamf id id TextureMaxAnisotropy maxTextureMaxAnisotropy :: GettableStateVar GLfloat maxTextureMaxAnisotropy = makeGettableStateVar (getFloat1 id GetMaxTextureMaxAnisotropy) -------------------------------------------------------------------------------- textureLevelRange :: ParameterizedTextureTarget t => t -> StateVar (Level,Level) textureLevelRange = combineTexParams (texParami id id TextureBaseLevel) (texParami id id TextureMaxLevel) -------------------------------------------------------------------------------- -- | Note: OpenGL 3.1 deprecated this texture parameter, use -- 'Graphics.Rendering.OpenGL.GL.Texturing.Objects.generateMipmap'' instead. generateMipmap :: ParameterizedTextureTarget t => t -> StateVar Capability generateMipmap = texParami unmarshal marshal GenerateMipmap where unmarshal = unmarshalCapability . fromIntegral marshal = fromIntegral . marshalCapability -------------------------------------------------------------------------------- -- Only Luminance', Intensity, and Alpha' allowed depthTextureMode :: ParameterizedTextureTarget t => t -> StateVar PixelInternalFormat depthTextureMode = texParami unmarshalPixelInternalFormat marshalPixelInternalFormat DepthTextureMode -------------------------------------------------------------------------------- marshalTextureCompareMode :: Capability -> GLint marshalTextureCompareMode x = fromIntegral $ case x of Disabled -> gl_NONE Enabled -> gl_COMPARE_REF_TO_TEXTURE unmarshalTextureCompareMode :: GLint -> Capability unmarshalTextureCompareMode x | y == gl_NONE = Disabled | y == gl_COMPARE_REF_TO_TEXTURE = Enabled | otherwise = error ("unmarshalTextureCompareMode: illegal value " ++ show x) where y = fromIntegral x -------------------------------------------------------------------------------- textureCompareMode :: ParameterizedTextureTarget t => t -> StateVar (Maybe ComparisonFunction) textureCompareMode = combineTexParamsMaybe (texParami unmarshalTextureCompareMode marshalTextureCompareMode TextureCompareMode) (texParami unmarshal marshal TextureCompareFunc) where unmarshal = unmarshalComparisonFunction . fromIntegral marshal = fromIntegral . marshalComparisonFunction -------------------------------------------------------------------------------- textureCompareFailValue :: ParameterizedTextureTarget t => t -> StateVar GLclampf textureCompareFailValue = texParamf realToFrac realToFrac TextureCompareFailValue -------------------------------------------------------------------------------- data TextureCompareOperator = LequalR | GequalR deriving ( Eq, Ord, Show ) marshalTextureCompareOperator :: TextureCompareOperator -> GLenum marshalTextureCompareOperator x = case x of LequalR -> gl_TEXTURE_LEQUAL_R_SGIX GequalR -> gl_TEXTURE_GEQUAL_R_SGIX unmarshalTextureCompareOperator :: GLenum -> TextureCompareOperator unmarshalTextureCompareOperator x | x == gl_TEXTURE_LEQUAL_R_SGIX = LequalR | x == gl_TEXTURE_GEQUAL_R_SGIX = GequalR | otherwise = error ("unmarshalTextureCompareOperator: illegal value " ++ show x) -------------------------------------------------------------------------------- textureCompareOperator :: ParameterizedTextureTarget t => t -> StateVar (Maybe TextureCompareOperator) textureCompareOperator = combineTexParamsMaybe (texParami (unmarshalCapability . fromIntegral) (fromIntegral. marshalCapability) TextureCompare) (texParami (unmarshalTextureCompareOperator . fromIntegral) (fromIntegral . marshalTextureCompareOperator) TextureCompareOperator) -------------------------------------------------------------------------------- combineTexParams :: ParameterizedTextureTarget t => (t -> StateVar a) -> (t -> StateVar b) -> (t -> StateVar (a,b)) combineTexParams v w t = makeStateVar (liftM2 (,) (get (v t)) (get (w t))) (\(x,y) -> do v t $= x; w t $= y) combineTexParamsMaybe :: ParameterizedTextureTarget t => (t -> StateVar Capability) -> (t -> StateVar a) -> (t -> StateVar (Maybe a)) combineTexParamsMaybe enab val t = makeStateVar (do tcm <- get (enab t) case tcm of Disabled -> return Nothing Enabled -> fmap Just $ get (val t)) (maybe (enab t $= Disabled) (\tcf -> do val t $= tcf enab t $= Enabled)) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Texturing/Filter.hs0000644000000000000000000000506412521420345022714 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.Filter -- Copyright : (c) Sven Panne 2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for (un-)marshaling texture filtering modes. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Texturing.Filter ( TextureFilter(..), MinificationFilter, marshalMinificationFilter, unmarshalMinificationFilter, MagnificationFilter, marshalMagnificationFilter, unmarshalMagnificationFilter ) where import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data TextureFilter = Nearest | Linear' deriving ( Eq, Ord, Show ) type MinificationFilter = (TextureFilter, Maybe TextureFilter) type MagnificationFilter = TextureFilter -- We treat MagnificationFilter as a degenerated case of MinificationFilter magToMin :: MagnificationFilter -> MinificationFilter magToMin magFilter = (magFilter, Nothing) minToMag :: MinificationFilter -> MagnificationFilter minToMag (magFilter, Nothing) = magFilter minToMag minFilter = error ("minToMag: illegal value " ++ show minFilter) marshalMinificationFilter :: MinificationFilter -> GLint marshalMinificationFilter x = fromIntegral $ case x of (Nearest, Nothing ) -> gl_NEAREST (Linear', Nothing ) -> gl_LINEAR (Nearest, Just Nearest) -> gl_NEAREST_MIPMAP_NEAREST (Linear', Just Nearest) -> gl_LINEAR_MIPMAP_NEAREST (Nearest, Just Linear') -> gl_NEAREST_MIPMAP_LINEAR (Linear', Just Linear') -> gl_LINEAR_MIPMAP_LINEAR marshalMagnificationFilter :: MagnificationFilter -> GLint marshalMagnificationFilter = marshalMinificationFilter . magToMin unmarshalMinificationFilter :: GLint -> MinificationFilter unmarshalMinificationFilter x | y == gl_NEAREST = (Nearest, Nothing) | y == gl_LINEAR = (Linear', Nothing) | y == gl_NEAREST_MIPMAP_NEAREST = (Nearest, Just Nearest) | y == gl_LINEAR_MIPMAP_NEAREST = (Linear', Just Nearest) | y == gl_NEAREST_MIPMAP_LINEAR = (Nearest, Just Linear') | y == gl_LINEAR_MIPMAP_LINEAR = (Linear', Just Linear') | otherwise = error ("unmarshalMinificationFilter: illegal value " ++ show x) where y = fromIntegral x unmarshalMagnificationFilter :: GLint -> MagnificationFilter unmarshalMagnificationFilter = minToMag . unmarshalMinificationFilter OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Texturing/Objects.hs0000644000000000000000000000672512521420345023065 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.Objects -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 3.8.12 (Texture Objects) of the OpenGL 2.1 -- specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Texturing.Objects ( TextureObject(TextureObject), textureBinding, textureResident, areTexturesResident, TexturePriority, texturePriority, prioritizeTextures, generateMipmap' ) where import Data.List import Data.Maybe (fromMaybe) import Data.StateVar import Foreign.Marshal.Array import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.Texturing.TexParameter import Graphics.Rendering.OpenGL.GL.Texturing.TextureObject import Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- textureBinding :: BindableTextureTarget t => t -> StateVar (Maybe TextureObject) textureBinding t = makeStateVar (do o <- getEnum1 (TextureObject . fromIntegral) (marshalBindableTextureTargetPName1I t) return $ if o == defaultTextureObject then Nothing else Just o) (glBindTexture (marshalBindableTextureTarget t) . textureID . (fromMaybe defaultTextureObject)) defaultTextureObject :: TextureObject defaultTextureObject = TextureObject 0 -------------------------------------------------------------------------------- textureResident :: ParameterizedTextureTarget t => t -> GettableStateVar Bool textureResident t = makeGettableStateVar $ getTexParameteri unmarshalGLboolean t TextureResident areTexturesResident :: [TextureObject] -> IO ([TextureObject],[TextureObject]) areTexturesResident texObjs = do withArrayLen (map textureID texObjs) $ \len texObjsBuf -> allocaArray len $ \residentBuf -> do allResident <- glAreTexturesResident (fromIntegral len) texObjsBuf residentBuf if unmarshalGLboolean allResident then return (texObjs, []) else do tr <- fmap (zip texObjs) $ peekArray len residentBuf let (resident, nonResident) = partition (unmarshalGLboolean . snd) tr return (map fst resident, map fst nonResident) -------------------------------------------------------------------------------- type TexturePriority = GLclampf texturePriority :: ParameterizedTextureTarget t => t -> StateVar TexturePriority texturePriority = texParamf realToFrac realToFrac TexturePriority prioritizeTextures :: [(TextureObject,TexturePriority)] -> IO () prioritizeTextures tps = withArrayLen (map (textureID . fst) tps) $ \len texObjsBuf -> withArray (map snd tps) $ glPrioritizeTextures (fromIntegral len) texObjsBuf -------------------------------------------------------------------------------- -- | Generate mipmaps for the specified texture target. Note that from OpenGL -- 3.1 onwards you should use this function instead of the texture parameter -- 'Graphics.Rendering.OpenGL.GL.Texturing.Parameters.generateMipmap'. generateMipmap' :: ParameterizedTextureTarget t => t -> IO () generateMipmap' = glGenerateMipmap . marshalParameterizedTextureTarget OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Texturing/Application.hs0000644000000000000000000000165412521420345023733 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.Application -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 3.8.15 (Texture Application) of the -- OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Texturing.Application ( texture ) where import Data.StateVar import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget -------------------------------------------------------------------------------- texture :: ParameterizedTextureTarget t => t -> StateVar Capability texture = makeCapability . marshalParameterizedTextureTargetEnableCap OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Texturing/Specification.hs0000644000000000000000000003634312521420345024253 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.Specification -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 3.8.1 (Texture Image Specification), -- section 3.8.2 (Alternate Texture Image Specification Commands), and section -- 3.8.3 (Compressed Texture Images) of the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Texturing.Specification ( -- * Texture Targets -- ** One-Dimensional Texture Targets TextureTarget1D(..), -- ** Two-Dimensional Texture Targets TextureTarget2D(..), TextureTarget2DMultisample(..), TextureTargetCubeMap(..), TextureTargetCubeMapFace(..), -- ** Three-Dimensional Texture Targets TextureTarget3D(..), TextureTarget2DMultisampleArray(..), -- ** Texture Buffer Target TextureTargetBuffer(..), -- ** Texture Target Classification BindableTextureTarget, ParameterizedTextureTarget, OneDimensionalTextureTarget, TwoDimensionalTextureTarget, ThreeDimensionalTextureTarget, QueryableTextureTarget, GettableTextureTarget, -- * Texture-related Data Types Level, Border, TexturePosition1D(..), TexturePosition2D(..), TexturePosition3D(..), TextureSize1D(..), TextureSize2D(..), TextureSize3D(..), -- * Texture Image Specification texImage1D, texImage2D, texImage3D, copyTexImage1D, copyTexImage2D, texSubImage1D, texSubImage2D, texSubImage3D, getTexImage, -- * Alternate Texture Image Specification Commands copyTexSubImage1D, copyTexSubImage2D, copyTexSubImage3D, -- * Compressed Texture Images CompressedTextureFormat(..), compressedTextureFormats, CompressedPixelData(..), compressedTexImage1D, compressedTexImage2D, compressedTexImage3D, compressedTexSubImage1D, compressedTexSubImage2D, compressedTexSubImage3D, getCompressedTexImage, -- * Multisample Texture Images SampleLocations(..), texImage2DMultisample, texImage3DMultisample, -- * Implementation-Dependent Limits maxTextureSize, maxCubeMapTextureSize, maxRectangleTextureSize, max3DTextureSize, maxArrayTextureLayers, maxSampleMaskWords, maxColorTextureSamples, maxDepthTextureSamples, maxIntegerSamples ) where import Foreign.Ptr import Data.StateVar import Graphics.Rendering.OpenGL.GL.CoordTrans import Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferTarget import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.PixelData import Graphics.Rendering.OpenGL.GL.PixelRectangles import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.Texturing.PixelInternalFormat import Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- type Level = GLint type Border = GLint newtype TexturePosition1D = TexturePosition1D GLint deriving ( Eq, Ord, Show ) data TexturePosition2D = TexturePosition2D !GLint !GLint deriving ( Eq, Ord, Show ) data TexturePosition3D = TexturePosition3D !GLint !GLint !GLint deriving ( Eq, Ord, Show ) newtype TextureSize1D = TextureSize1D GLsizei deriving ( Eq, Ord, Show ) data TextureSize2D = TextureSize2D !GLsizei !GLsizei deriving ( Eq, Ord, Show ) data TextureSize3D = TextureSize3D !GLsizei !GLsizei !GLsizei deriving ( Eq, Ord, Show ) -------------------------------------------------------------------------------- texImage1D :: OneDimensionalTextureTarget t => t -> Proxy -> Level -> PixelInternalFormat -> TextureSize1D -> Border -> PixelData a -> IO () texImage1D target proxy level int (TextureSize1D w) border pd = withPixelData pd $ glTexImage1D (marshalOneDimensionalTextureTarget proxy target) level (marshalPixelInternalFormat int) w border -------------------------------------------------------------------------------- texImage2D :: TwoDimensionalTextureTarget t => t -> Proxy -> Level -> PixelInternalFormat -> TextureSize2D -> Border -> PixelData a -> IO () texImage2D target proxy level int (TextureSize2D w h) border pd = withPixelData pd $ glTexImage2D (marshalTwoDimensionalTextureTarget proxy target) level (marshalPixelInternalFormat int) w h border -------------------------------------------------------------------------------- texImage3D :: ThreeDimensionalTextureTarget t => t -> Proxy -> Level -> PixelInternalFormat -> TextureSize3D -> Border -> PixelData a -> IO () texImage3D target proxy level int (TextureSize3D w h d) border pd = withPixelData pd $ glTexImage3D (marshalThreeDimensionalTextureTarget proxy target) level (marshalPixelInternalFormat int) w h d border -------------------------------------------------------------------------------- getTexImage :: GettableTextureTarget t => t -> Level -> PixelData a -> IO () getTexImage target level pd = withPixelData pd $ glGetTexImage (marshalGettableTextureTarget target) level -------------------------------------------------------------------------------- copyTexImage1D :: OneDimensionalTextureTarget t => t -> Level -> PixelInternalFormat -> Position -> TextureSize1D -> Border -> IO () copyTexImage1D target level int (Position x y) (TextureSize1D w) border = glCopyTexImage1D (marshalOneDimensionalTextureTarget NoProxy target) level (marshalPixelInternalFormat' int) x y w border -------------------------------------------------------------------------------- copyTexImage2D :: TwoDimensionalTextureTarget t => t -> Level -> PixelInternalFormat -> Position -> TextureSize2D -> Border -> IO () copyTexImage2D target level int (Position x y) (TextureSize2D w h) border = glCopyTexImage2D (marshalTwoDimensionalTextureTarget NoProxy target) level (marshalPixelInternalFormat' int) x y w h border -------------------------------------------------------------------------------- texSubImage1D :: OneDimensionalTextureTarget t => t -> Level -> TexturePosition1D -> TextureSize1D -> PixelData a -> IO () texSubImage1D target level (TexturePosition1D xOff) (TextureSize1D w) pd = withPixelData pd $ glTexSubImage1D (marshalOneDimensionalTextureTarget NoProxy target) level xOff w -------------------------------------------------------------------------------- texSubImage2D :: TwoDimensionalTextureTarget t => t -> Level -> TexturePosition2D -> TextureSize2D -> PixelData a -> IO () texSubImage2D target level (TexturePosition2D xOff yOff) (TextureSize2D w h) pd = withPixelData pd $ glTexSubImage2D (marshalTwoDimensionalTextureTarget NoProxy target) level xOff yOff w h -------------------------------------------------------------------------------- texSubImage3D :: ThreeDimensionalTextureTarget t => t -> Level -> TexturePosition3D -> TextureSize3D -> PixelData a -> IO () texSubImage3D target level (TexturePosition3D xOff yOff zOff) (TextureSize3D w h d) pd = withPixelData pd $ glTexSubImage3D (marshalThreeDimensionalTextureTarget NoProxy target) level xOff yOff zOff w h d -------------------------------------------------------------------------------- copyTexSubImage1D :: OneDimensionalTextureTarget t => t -> Level -> TexturePosition1D -> Position -> TextureSize1D -> IO () copyTexSubImage1D target level (TexturePosition1D xOff) (Position x y) (TextureSize1D w) = glCopyTexSubImage1D (marshalOneDimensionalTextureTarget NoProxy target) level xOff x y w -------------------------------------------------------------------------------- copyTexSubImage2D :: TwoDimensionalTextureTarget t => t -> Level -> TexturePosition2D -> Position -> TextureSize2D -> IO () copyTexSubImage2D target level (TexturePosition2D xOff yOff) (Position x y) (TextureSize2D w h) = glCopyTexSubImage2D (marshalTwoDimensionalTextureTarget NoProxy target) level xOff yOff x y w h -------------------------------------------------------------------------------- copyTexSubImage3D :: ThreeDimensionalTextureTarget t => t -> Level -> TexturePosition3D -> Position -> TextureSize2D -> IO () copyTexSubImage3D target level (TexturePosition3D xOff yOff zOff) (Position x y) (TextureSize2D w h) = glCopyTexSubImage3D (marshalThreeDimensionalTextureTarget NoProxy target) level xOff yOff zOff x y w h -------------------------------------------------------------------------------- newtype CompressedTextureFormat = CompressedTextureFormat GLenum deriving ( Eq, Ord, Show ) compressedTextureFormats :: GettableStateVar [CompressedTextureFormat] compressedTextureFormats = makeGettableStateVar $ do n <- getInteger1 fromIntegral GetNumCompressedTextureFormats getEnumN CompressedTextureFormat GetCompressedTextureFormats n -------------------------------------------------------------------------------- data CompressedPixelData a = CompressedPixelData !CompressedTextureFormat GLsizei (Ptr a) deriving ( Eq, Ord, Show ) withCompressedPixelData :: CompressedPixelData a -> (GLenum -> GLsizei -> Ptr a -> b) -> b withCompressedPixelData (CompressedPixelData (CompressedTextureFormat fmt) size ptr) f = f fmt size ptr -------------------------------------------------------------------------------- compressedTexImage1D :: OneDimensionalTextureTarget t => t -> Proxy -> Level -> TextureSize1D -> Border -> CompressedPixelData a -> IO () compressedTexImage1D target proxy level (TextureSize1D w) border cpd = withCompressedPixelData cpd $ \fmt -> glCompressedTexImage1D (marshalOneDimensionalTextureTarget proxy target) level fmt w border -------------------------------------------------------------------------------- -- Note that the spec currently disallows TextureRectangle, but then again the -- extension specification explicitly allows a relaxation in the future. compressedTexImage2D :: TwoDimensionalTextureTarget t => t -> Proxy -> Level -> TextureSize2D -> Border -> CompressedPixelData a -> IO () compressedTexImage2D target proxy level (TextureSize2D w h) border cpd = withCompressedPixelData cpd $ \fmt -> glCompressedTexImage2D (marshalTwoDimensionalTextureTarget proxy target) level fmt w h border -------------------------------------------------------------------------------- compressedTexImage3D :: ThreeDimensionalTextureTarget t => t -> Proxy -> Level -> TextureSize3D -> Border -> CompressedPixelData a -> IO () compressedTexImage3D target proxy level (TextureSize3D w h d) border cpd = withCompressedPixelData cpd $ \fmt -> glCompressedTexImage3D (marshalThreeDimensionalTextureTarget proxy target) level fmt w h d border -------------------------------------------------------------------------------- getCompressedTexImage :: GettableTextureTarget t => t -> Level -> Ptr a -> IO () getCompressedTexImage = glGetCompressedTexImage . marshalGettableTextureTarget -------------------------------------------------------------------------------- compressedTexSubImage1D :: OneDimensionalTextureTarget t => t -> Level -> TexturePosition1D -> TextureSize1D -> CompressedPixelData a -> IO () compressedTexSubImage1D target level (TexturePosition1D xOff) (TextureSize1D w) cpd = withCompressedPixelData cpd $ glCompressedTexSubImage1D (marshalOneDimensionalTextureTarget NoProxy target) level xOff w -------------------------------------------------------------------------------- compressedTexSubImage2D :: TwoDimensionalTextureTarget t => t -> Level -> TexturePosition2D -> TextureSize2D -> CompressedPixelData a -> IO () compressedTexSubImage2D target level (TexturePosition2D xOff yOff) (TextureSize2D w h) cpd = withCompressedPixelData cpd $ glCompressedTexSubImage2D (marshalTwoDimensionalTextureTarget NoProxy target) level xOff yOff w h -------------------------------------------------------------------------------- -- see texImage3D, but no proxies compressedTexSubImage3D :: ThreeDimensionalTextureTarget t => t -> Level -> TexturePosition3D -> TextureSize3D -> CompressedPixelData a -> IO () compressedTexSubImage3D target level (TexturePosition3D xOff yOff zOff) (TextureSize3D w h d) cpd = withCompressedPixelData cpd $ glCompressedTexSubImage3D (marshalThreeDimensionalTextureTarget NoProxy target) level xOff yOff zOff w h d -------------------------------------------------------------------------------- data SampleLocations = FlexibleSampleLocations | FixedSampleLocations deriving ( Eq, Ord, Show ) marshalSampleLocations :: SampleLocations -> GLboolean marshalSampleLocations = marshalGLboolean . (FixedSampleLocations ==) {- unmarshalSampleLocations :: GLboolean -> SampleLocations unmarshalSampleLocations x = if unmarshalGLboolean x then FixedSampleLocations else FlexibleSampleLocations -} -------------------------------------------------------------------------------- texImage2DMultisample :: TextureTarget2DMultisample -> Proxy -> Samples -> PixelInternalFormat -> TextureSize2D -> SampleLocations -> IO () texImage2DMultisample target proxy (Samples s) int (TextureSize2D w h) loc = glTexImage2DMultisample (marshalMultisample proxy target) s (fromIntegral (marshalPixelInternalFormat int)) w h (marshalSampleLocations loc) marshalMultisample :: ParameterizedTextureTarget t => Proxy -> t -> GLenum marshalMultisample proxy = case proxy of NoProxy -> marshalParameterizedTextureTarget Proxy -> marshalParameterizedTextureTargetProxy texImage3DMultisample :: TextureTarget2DMultisampleArray -> Proxy -> Samples -> PixelInternalFormat -> TextureSize3D -> SampleLocations -> IO () texImage3DMultisample target proxy (Samples s) int (TextureSize3D w h d) loc = glTexImage3DMultisample (marshalMultisample proxy target) s (fromIntegral (marshalPixelInternalFormat int)) w h d (marshalSampleLocations loc) -------------------------------------------------------------------------------- maxTextureSize :: GettableStateVar GLsizei maxTextureSize = maxTextureSizeWith GetMaxTextureSize maxCubeMapTextureSize :: GettableStateVar GLsizei maxCubeMapTextureSize = maxTextureSizeWith GetMaxCubeMapTextureSize maxRectangleTextureSize :: GettableStateVar GLsizei maxRectangleTextureSize = maxTextureSizeWith GetMaxRectangleTextureSize max3DTextureSize :: GettableStateVar GLsizei max3DTextureSize = maxTextureSizeWith GetMax3DTextureSize maxArrayTextureLayers :: GettableStateVar GLsizei maxArrayTextureLayers = maxTextureSizeWith GetMaxArrayTextureLayers maxSampleMaskWords :: GettableStateVar GLsizei maxSampleMaskWords = maxTextureSizeWith GetMaxSampleMaskWords maxColorTextureSamples :: GettableStateVar GLsizei maxColorTextureSamples = maxTextureSizeWith GetMaxColorTextureSamples maxDepthTextureSamples :: GettableStateVar GLsizei maxDepthTextureSamples = maxTextureSizeWith GetMaxDepthTextureSamples maxIntegerSamples :: GettableStateVar GLsizei maxIntegerSamples = maxTextureSizeWith GetMaxIntegerSamples maxTextureSizeWith :: PName1I -> GettableStateVar GLsizei maxTextureSizeWith = makeGettableStateVar . getInteger1 fromIntegral OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Texturing/TexParameter.hs0000644000000000000000000001143712521420345024071 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.TexParameter -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for getting\/setting texture parameters. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Texturing.TexParameter ( TexParameter(..), texParami, texParamf, texParamC4f, getTexParameteri ) where import Data.StateVar import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data TexParameter = TextureMinFilter | TextureMagFilter | TextureWrapS | TextureWrapT | TextureWrapR | TextureBorderColor | TextureMinLOD | TextureMaxLOD | TextureBaseLevel | TextureMaxLevel | TexturePriority | TextureMaxAnisotropy | TextureCompare | TextureCompareOperator | TextureCompareFailValue | GenerateMipmap | TextureCompareMode | TextureCompareFunc | DepthTextureMode | TextureLODBias | TextureResident marshalTexParameter :: TexParameter -> GLenum marshalTexParameter x = case x of TextureMinFilter -> gl_TEXTURE_MIN_FILTER TextureMagFilter -> gl_TEXTURE_MAG_FILTER TextureWrapS -> gl_TEXTURE_WRAP_S TextureWrapT -> gl_TEXTURE_WRAP_T TextureWrapR -> gl_TEXTURE_WRAP_R TextureBorderColor -> gl_TEXTURE_BORDER_COLOR TextureMinLOD -> gl_TEXTURE_MIN_LOD TextureMaxLOD -> gl_TEXTURE_MAX_LOD TextureBaseLevel -> gl_TEXTURE_BASE_LEVEL TextureMaxLevel -> gl_TEXTURE_MAX_LEVEL TexturePriority -> gl_TEXTURE_PRIORITY TextureMaxAnisotropy -> gl_TEXTURE_MAX_ANISOTROPY_EXT TextureCompare -> gl_TEXTURE_COMPARE_SGIX TextureCompareOperator -> gl_TEXTURE_COMPARE_OPERATOR_SGIX TextureCompareFailValue -> gl_TEXTURE_COMPARE_FAIL_VALUE_ARB GenerateMipmap -> gl_GENERATE_MIPMAP TextureCompareMode -> gl_TEXTURE_COMPARE_MODE TextureCompareFunc -> gl_TEXTURE_COMPARE_FUNC DepthTextureMode -> gl_DEPTH_TEXTURE_MODE TextureLODBias -> gl_TEXTURE_LOD_BIAS TextureResident -> gl_TEXTURE_RESIDENT -------------------------------------------------------------------------------- texParameter :: ParameterizedTextureTarget t => (GLenum -> GLenum -> b -> IO ()) -> (a -> (b -> IO ()) -> IO ()) -> t -> TexParameter -> a -> IO () texParameter glTexParameter marshalAct t p x = marshalAct x $ glTexParameter (marshalParameterizedTextureTarget t) (marshalTexParameter p) -------------------------------------------------------------------------------- getTexParameter :: (Storable b, ParameterizedTextureTarget t) => (GLenum -> GLenum -> Ptr b -> IO ()) -> (b -> a) -> t -> TexParameter -> IO a getTexParameter glGetTexParameter unmarshal t p = alloca $ \buf -> do glGetTexParameter (marshalParameterizedTextureTarget t) (marshalTexParameter p) buf peek1 unmarshal buf -------------------------------------------------------------------------------- m2a :: (a -> b) -> a -> (b -> IO ()) -> IO () m2a marshal x act = act (marshal x) texParami :: ParameterizedTextureTarget t => (GLint -> a) -> (a -> GLint) -> TexParameter -> t -> StateVar a texParami unmarshal marshal p t = makeStateVar (getTexParameter glGetTexParameteriv unmarshal t p) (texParameter glTexParameteri (m2a marshal) t p) texParamf :: ParameterizedTextureTarget t => (GLfloat -> a) -> (a -> GLfloat) -> TexParameter -> t -> StateVar a texParamf unmarshal marshal p t = makeStateVar (getTexParameter glGetTexParameterfv unmarshal t p) (texParameter glTexParameterf (m2a marshal) t p) texParamC4f :: ParameterizedTextureTarget t => TexParameter -> t -> StateVar (Color4 GLfloat) texParamC4f p t = makeStateVar (getTexParameter glGetTexParameterC4f id t p) (texParameter glTexParameterC4f with t p) glTexParameterC4f :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO () glTexParameterC4f target pname ptr = glTexParameterfv target pname (castPtr ptr) glGetTexParameterC4f :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO () glGetTexParameterC4f target pname ptr = glGetTexParameterfv target pname (castPtr ptr) getTexParameteri :: ParameterizedTextureTarget t => (GLint -> a) -> t -> TexParameter -> IO a getTexParameteri = getTexParameter glGetTexParameteriv OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Texturing/Environments.hs0000644000000000000000000002661712521420345024165 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.Environments -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 3.8.13 (Texture Environments and Texture -- Functions) of the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Texturing.Environments ( TextureFunction(..), textureFunction, TextureCombineFunction(..), combineRGB, combineAlpha, ArgNum(..), Arg(..), Src(..), argRGB, argAlpha, rgbScale, alphaScale, constantColor, textureUnitLODBias ) where import Control.Monad import Data.StateVar import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.GL.BlendingFactor import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.Texturing.Parameters import Graphics.Rendering.OpenGL.GL.Texturing.TextureUnit import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data TextureEnvTarget = TextureEnv | TextureFilterControl -- GL_TEXTURE_LOD_BIAS_EXT | PointSprite -- GL_COORD_REPLACE_NV marshalTextureEnvTarget :: TextureEnvTarget -> GLenum marshalTextureEnvTarget x = case x of TextureEnv -> gl_TEXTURE_ENV TextureFilterControl -> gl_TEXTURE_FILTER_CONTROL PointSprite -> gl_POINT_SPRITE -------------------------------------------------------------------------------- data TextureEnvParameter = TexEnvParamTextureEnvMode | TexEnvParamTextureEnvColor | TexEnvParamCombineRGB | TexEnvParamCombineAlpha | TexEnvParamSrc0RGB | TexEnvParamSrc1RGB | TexEnvParamSrc2RGB | TexEnvParamSrc3RGB | TexEnvParamSrc0Alpha | TexEnvParamSrc1Alpha | TexEnvParamSrc2Alpha | TexEnvParamSrc3Alpha | TexEnvParamOperand0RGB | TexEnvParamOperand1RGB | TexEnvParamOperand2RGB | TexEnvParamOperand3RGB | TexEnvParamOperand0Alpha | TexEnvParamOperand1Alpha | TexEnvParamOperand2Alpha | TexEnvParamOperand3Alpha | TexEnvParamRGBScale | TexEnvParamAlphaScale | TexEnvParamLODBias marshalTextureEnvParameter :: TextureEnvParameter -> GLenum marshalTextureEnvParameter x = case x of TexEnvParamTextureEnvMode -> gl_TEXTURE_ENV_MODE TexEnvParamTextureEnvColor -> gl_TEXTURE_ENV_COLOR TexEnvParamCombineRGB -> gl_COMBINE_RGB TexEnvParamCombineAlpha -> gl_COMBINE_ALPHA TexEnvParamSrc0RGB -> gl_SRC0_RGB TexEnvParamSrc1RGB -> gl_SRC1_RGB TexEnvParamSrc2RGB -> gl_SRC2_RGB TexEnvParamSrc3RGB -> gl_SOURCE3_RGB_NV TexEnvParamSrc0Alpha -> gl_SRC0_ALPHA TexEnvParamSrc1Alpha -> gl_SRC1_ALPHA TexEnvParamSrc2Alpha -> gl_SRC2_ALPHA TexEnvParamSrc3Alpha -> gl_SOURCE3_ALPHA_NV TexEnvParamOperand0RGB -> gl_OPERAND0_RGB TexEnvParamOperand1RGB -> gl_OPERAND1_RGB TexEnvParamOperand2RGB -> gl_OPERAND2_RGB TexEnvParamOperand3RGB -> gl_OPERAND3_RGB_NV TexEnvParamOperand0Alpha -> gl_OPERAND0_ALPHA TexEnvParamOperand1Alpha -> gl_OPERAND1_ALPHA TexEnvParamOperand2Alpha -> gl_OPERAND2_ALPHA TexEnvParamOperand3Alpha -> gl_OPERAND3_ALPHA_NV TexEnvParamRGBScale -> gl_RGB_SCALE TexEnvParamAlphaScale -> gl_ALPHA_SCALE TexEnvParamLODBias -> gl_TEXTURE_LOD_BIAS -------------------------------------------------------------------------------- texEnv :: (GLenum -> GLenum -> b -> IO ()) -> (a -> (b -> IO ()) -> IO ()) -> TextureEnvTarget -> TextureEnvParameter -> a -> IO () texEnv glTexEnv marshalAct t p x = marshalAct x $ glTexEnv (marshalTextureEnvTarget t) (marshalTextureEnvParameter p) glTexEnvC4f :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO () glTexEnvC4f t p ptr = glTexEnvfv t p (castPtr ptr) -------------------------------------------------------------------------------- getTexEnv :: Storable b => (GLenum -> GLenum -> Ptr b -> IO ()) -> (b -> a) -> TextureEnvTarget -> TextureEnvParameter -> IO a getTexEnv glGetTexEnv unmarshal t p = alloca $ \buf -> do glGetTexEnv (marshalTextureEnvTarget t) (marshalTextureEnvParameter p) buf peek1 unmarshal buf glGetTexEnvC4f :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO () glGetTexEnvC4f t p ptr = glGetTexEnvfv t p (castPtr ptr) -------------------------------------------------------------------------------- m2a :: (a -> b) -> a -> (b -> IO ()) -> IO () m2a marshal x act = act (marshal x) texEnvi :: (GLint -> a) -> (a -> GLint) -> TextureEnvTarget -> TextureEnvParameter -> StateVar a texEnvi unmarshal marshal t p = makeStateVar (getTexEnv glGetTexEnviv unmarshal t p) (texEnv glTexEnvi (m2a marshal) t p) texEnvf :: (GLfloat -> a) -> (a -> GLfloat) -> TextureEnvTarget -> TextureEnvParameter -> StateVar a texEnvf unmarshal marshal t p = makeStateVar (getTexEnv glGetTexEnvfv unmarshal t p) (texEnv glTexEnvf (m2a marshal) t p) texEnvC4f :: TextureEnvTarget -> TextureEnvParameter -> StateVar (Color4 GLfloat) texEnvC4f t p = makeStateVar (getTexEnv glGetTexEnvC4f id t p) (texEnv glTexEnvC4f with t p) -------------------------------------------------------------------------------- data TextureFunction = Modulate | Decal | Blend | Replace | AddUnsigned | Combine | Combine4 deriving ( Eq, Ord, Show ) marshalTextureFunction :: TextureFunction -> GLint marshalTextureFunction x = fromIntegral $ case x of Modulate -> gl_MODULATE Decal -> gl_DECAL Blend -> gl_BLEND Replace -> gl_REPLACE AddUnsigned -> gl_ADD Combine -> gl_COMBINE Combine4 -> gl_COMBINE4_NV unmarshalTextureFunction :: GLint -> TextureFunction unmarshalTextureFunction x | y == gl_MODULATE = Modulate | y == gl_DECAL = Decal | y == gl_BLEND = Blend | y == gl_REPLACE = Replace | y == gl_ADD = AddUnsigned | y == gl_COMBINE = Combine | y == gl_COMBINE4_NV = Combine4 | otherwise = error ("unmarshalTextureFunction: illegal value " ++ show x) where y = fromIntegral x -------------------------------------------------------------------------------- textureFunction :: StateVar TextureFunction textureFunction = texEnvi unmarshalTextureFunction marshalTextureFunction TextureEnv TexEnvParamTextureEnvMode -------------------------------------------------------------------------------- data TextureCombineFunction = Replace' | Modulate' | AddUnsigned' | AddSigned | Interpolate | Subtract | Dot3RGB | Dot3RGBA deriving ( Eq, Ord, Show ) marshalTextureCombineFunction :: TextureCombineFunction -> GLint marshalTextureCombineFunction x = fromIntegral $ case x of Replace' -> gl_REPLACE Modulate' -> gl_MODULATE AddUnsigned' -> gl_ADD AddSigned -> gl_ADD_SIGNED Interpolate -> gl_INTERPOLATE Subtract -> gl_SUBTRACT Dot3RGB -> gl_DOT3_RGB Dot3RGBA -> gl_DOT3_RGBA unmarshalTextureCombineFunction :: GLint -> TextureCombineFunction unmarshalTextureCombineFunction x | y == gl_REPLACE = Replace' | y == gl_MODULATE = Modulate' | y == gl_ADD = AddUnsigned' | y == gl_ADD_SIGNED = AddSigned | y == gl_INTERPOLATE = Interpolate | y == gl_SUBTRACT = Subtract | y == gl_DOT3_RGB = Dot3RGB | y == gl_DOT3_RGBA = Dot3RGBA | otherwise = error ("unmarshalTextureCombineFunction: illegal value " ++ show x) where y = fromIntegral x -------------------------------------------------------------------------------- combineRGB :: StateVar TextureCombineFunction combineRGB = combine TexEnvParamCombineRGB combineAlpha :: StateVar TextureCombineFunction combineAlpha = combine TexEnvParamCombineAlpha combine :: TextureEnvParameter -> StateVar TextureCombineFunction combine = texEnvi unmarshalTextureCombineFunction marshalTextureCombineFunction TextureEnv -------------------------------------------------------------------------------- data ArgNum = Arg0 | Arg1 | Arg2 | Arg3 deriving ( Eq, Ord, Show ) argNumToOperandRGB :: ArgNum -> TextureEnvParameter argNumToOperandRGB x = case x of Arg0 -> TexEnvParamOperand0RGB Arg1 -> TexEnvParamOperand1RGB Arg2 -> TexEnvParamOperand2RGB Arg3 -> TexEnvParamOperand3RGB argNumToOperandAlpha :: ArgNum -> TextureEnvParameter argNumToOperandAlpha x = case x of Arg0 -> TexEnvParamOperand0Alpha Arg1 -> TexEnvParamOperand1Alpha Arg2 -> TexEnvParamOperand2Alpha Arg3 -> TexEnvParamOperand3Alpha argNumToSrcRGB :: ArgNum -> TextureEnvParameter argNumToSrcRGB x = case x of Arg0 -> TexEnvParamSrc0RGB Arg1 -> TexEnvParamSrc1RGB Arg2 -> TexEnvParamSrc2RGB Arg3 -> TexEnvParamSrc3RGB argNumToSrcAlpha :: ArgNum -> TextureEnvParameter argNumToSrcAlpha x = case x of Arg0 -> TexEnvParamSrc0Alpha Arg1 -> TexEnvParamSrc1Alpha Arg2 -> TexEnvParamSrc2Alpha Arg3 -> TexEnvParamSrc3Alpha -------------------------------------------------------------------------------- data Arg = Arg BlendingFactor Src deriving ( Eq, Ord, Show ) -------------------------------------------------------------------------------- data Src = CurrentUnit | Previous | Crossbar TextureUnit | Constant | PrimaryColor deriving ( Eq, Ord, Show ) marshalSrc :: Src -> GLint marshalSrc x = fromIntegral $ case x of CurrentUnit -> gl_TEXTURE Previous -> gl_PREVIOUS Crossbar u -> fromIntegral (marshalTextureUnit u) Constant -> gl_CONSTANT PrimaryColor -> gl_PRIMARY_COLOR unmarshalSrc :: GLint -> Src unmarshalSrc x | y == gl_TEXTURE = CurrentUnit | y == gl_PREVIOUS = Previous | y == gl_CONSTANT = Constant | y == gl_PRIMARY_COLOR = PrimaryColor | otherwise = Crossbar (unmarshalTextureUnit (fromIntegral x)) where y = fromIntegral x -------------------------------------------------------------------------------- argRGB :: ArgNum -> StateVar Arg argRGB n = arg (argNumToOperandRGB n) (argNumToSrcRGB n) argAlpha :: ArgNum -> StateVar Arg argAlpha n = arg (argNumToOperandAlpha n) (argNumToSrcAlpha n) arg :: TextureEnvParameter -> TextureEnvParameter -> StateVar Arg arg op src = combineArg (textureEnvOperand op) (textureEnvSrc src) where combineArg :: StateVar BlendingFactor -> StateVar Src -> StateVar Arg combineArg v w = makeStateVar (liftM2 Arg (get v) (get w)) (\(Arg x y) -> do v $= x; w $= y) textureEnvOperand :: TextureEnvParameter -> StateVar BlendingFactor textureEnvOperand = texEnvi (unmarshalBlendingFactor . fromIntegral) (fromIntegral . marshalBlendingFactor) TextureEnv textureEnvSrc :: TextureEnvParameter -> StateVar Src textureEnvSrc = texEnvi unmarshalSrc marshalSrc TextureEnv -------------------------------------------------------------------------------- rgbScale :: StateVar GLfloat rgbScale = scale TexEnvParamRGBScale alphaScale :: StateVar GLfloat alphaScale = scale TexEnvParamAlphaScale scale :: TextureEnvParameter -> StateVar GLfloat scale = texEnvf id id TextureEnv -------------------------------------------------------------------------------- constantColor :: StateVar (Color4 GLfloat) constantColor = texEnvC4f TextureEnv TexEnvParamTextureEnvColor -------------------------------------------------------------------------------- textureUnitLODBias :: StateVar LOD textureUnitLODBias = texEnvf id id TextureFilterControl TexEnvParamLODBias OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Texturing/Queries.hs0000644000000000000000000001466312521420345023111 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.Queries -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module offers various texture queries. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Texturing.Queries ( TextureQuery, textureInternalFormat, textureSize1D, textureSize2D, textureSize3D, textureBorder, textureRGBASizes, textureSharedSize, textureIntensitySize, textureLuminanceSize, textureIndexSize, textureDepthBits, textureCompressedImageSize, textureProxyOK ) where import Control.Monad import Data.StateVar import Foreign.Marshal.Utils import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.PixelRectangles import Graphics.Rendering.OpenGL.GL.Texturing.PixelInternalFormat import Graphics.Rendering.OpenGL.GL.Texturing.Specification import Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data TexLevelParameter = TextureInternalFormat | TextureWidth | TextureHeight | TextureDepth | TextureBorder | TextureRedSize | TextureGreenSize | TextureBlueSize | TextureAlphaSize | TextureIntensitySize | TextureLuminanceSize | TextureIndexSize | DepthBits | TextureCompressedImageSize | TextureCompressed | TextureSharedSize marshalTexLevelParameter :: TexLevelParameter -> GLenum marshalTexLevelParameter x = case x of TextureInternalFormat -> gl_TEXTURE_INTERNAL_FORMAT TextureWidth -> gl_TEXTURE_WIDTH TextureHeight -> gl_TEXTURE_HEIGHT TextureDepth -> gl_TEXTURE_DEPTH TextureBorder -> gl_TEXTURE_BORDER TextureRedSize -> gl_TEXTURE_RED_SIZE TextureGreenSize -> gl_TEXTURE_GREEN_SIZE TextureBlueSize -> gl_TEXTURE_BLUE_SIZE TextureAlphaSize -> gl_TEXTURE_ALPHA_SIZE TextureIntensitySize -> gl_TEXTURE_INTENSITY_SIZE TextureLuminanceSize -> gl_TEXTURE_LUMINANCE_SIZE TextureIndexSize -> gl_TEXTURE_INDEX_SIZE_EXT DepthBits -> gl_DEPTH_BITS TextureCompressedImageSize -> gl_TEXTURE_COMPRESSED_IMAGE_SIZE TextureCompressed -> gl_TEXTURE_COMPRESSED TextureSharedSize -> gl_TEXTURE_SHARED_SIZE -------------------------------------------------------------------------------- type TextureQuery t a = t -> Level -> GettableStateVar a textureInternalFormat :: QueryableTextureTarget t => TextureQuery t PixelInternalFormat textureInternalFormat t level = makeGettableStateVar $ getTexLevelParameteriNoProxy unmarshalPixelInternalFormat t level TextureInternalFormat textureSize1D :: TextureQuery TextureTarget1D TextureSize1D textureSize1D t level = makeGettableStateVar $ liftM TextureSize1D (getTexLevelParameteriNoProxy fromIntegral t level TextureWidth) textureSize2D :: TextureQuery TextureTarget2D TextureSize2D textureSize2D t level = makeGettableStateVar $ liftM2 TextureSize2D (getTexLevelParameteriNoProxy fromIntegral t level TextureWidth ) (getTexLevelParameteriNoProxy fromIntegral t level TextureHeight) textureSize3D :: TextureQuery TextureTarget3D TextureSize3D textureSize3D t level = makeGettableStateVar $ liftM3 TextureSize3D (getTexLevelParameteriNoProxy fromIntegral t level TextureWidth ) (getTexLevelParameteriNoProxy fromIntegral t level TextureHeight) (getTexLevelParameteriNoProxy fromIntegral t level TextureDepth ) textureBorder :: QueryableTextureTarget t => TextureQuery t Border textureBorder t level = makeGettableStateVar $ getTexLevelParameteriNoProxy fromIntegral t level TextureBorder textureRGBASizes :: QueryableTextureTarget t => TextureQuery t (Color4 GLsizei) textureRGBASizes t level = makeGettableStateVar $ liftM4 Color4 (getTexLevelParameteriNoProxy fromIntegral t level TextureRedSize ) (getTexLevelParameteriNoProxy fromIntegral t level TextureGreenSize) (getTexLevelParameteriNoProxy fromIntegral t level TextureBlueSize ) (getTexLevelParameteriNoProxy fromIntegral t level TextureAlphaSize) textureSharedSize :: QueryableTextureTarget t => TextureQuery t GLsizei textureSharedSize t level = makeGettableStateVar $ getTexLevelParameteriNoProxy fromIntegral t level TextureSharedSize textureIntensitySize :: QueryableTextureTarget t => TextureQuery t GLsizei textureIntensitySize t level = makeGettableStateVar $ getTexLevelParameteriNoProxy fromIntegral t level TextureIntensitySize textureLuminanceSize :: QueryableTextureTarget t => TextureQuery t GLsizei textureLuminanceSize t level = makeGettableStateVar $ getTexLevelParameteriNoProxy fromIntegral t level TextureLuminanceSize textureIndexSize :: QueryableTextureTarget t => TextureQuery t GLsizei textureIndexSize t level = makeGettableStateVar $ getTexLevelParameteriNoProxy fromIntegral t level TextureIndexSize textureDepthBits :: QueryableTextureTarget t => TextureQuery t GLsizei textureDepthBits t level = makeGettableStateVar $ getTexLevelParameteriNoProxy fromIntegral t level DepthBits textureCompressedImageSize :: QueryableTextureTarget t => TextureQuery t (Maybe GLsizei) textureCompressedImageSize t level = makeGettableStateVar $ do isCompressed <- getTexLevelParameteriNoProxy unmarshalGLboolean t level TextureCompressed if isCompressed then getTexLevelParameteriNoProxy (Just . fromIntegral) t level TextureCompressedImageSize else return Nothing textureProxyOK :: ParameterizedTextureTarget t => TextureQuery t Bool textureProxyOK t level = makeGettableStateVar $ getTexLevelParameteri unmarshalGLboolean (marshalParameterizedTextureTargetProxy t) level TextureWidth getTexLevelParameteriNoProxy :: QueryableTextureTarget t => (GLint -> a) -> t -> Level -> TexLevelParameter -> IO a getTexLevelParameteriNoProxy f = getTexLevelParameteri f . marshalQueryableTextureTarget getTexLevelParameteri :: (GLint -> a) -> GLenum -> Level -> TexLevelParameter -> IO a getTexLevelParameteri f t level p = with 0 $ \buf -> do glGetTexLevelParameteriv t level (marshalTexLevelParameter p) buf peek1 f buf OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Texturing/TextureUnit.hs0000644000000000000000000000335512521420345023770 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.TextureUnit -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for (un-)marshaling TextureUnit. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Texturing.TextureUnit ( TextureUnit(..), marshalTextureUnit, unmarshalTextureUnit ) where import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- -- | Identifies a texture unit via its number, which must be in the range of -- (0 .. 'maxTextureUnit'). newtype TextureUnit = TextureUnit GLuint deriving ( Eq, Ord, Show ) -- Internal note, when setting a sampler (TextureUnit) uniform the GLint -- functions should be used. instance Storable TextureUnit where sizeOf _ = sizeOf (undefined :: GLuint) alignment _ = alignment (undefined :: GLuint) peek pt = peek (castPtr pt) >>= return . TextureUnit poke pt (TextureUnit tu) = poke (castPtr pt) tu peekByteOff pt off = peekByteOff pt off >>= return . TextureUnit pokeByteOff pt off (TextureUnit tu) = pokeByteOff pt off tu marshalTextureUnit :: TextureUnit -> GLenum marshalTextureUnit (TextureUnit x) = gl_TEXTURE0 + fromIntegral x unmarshalTextureUnit :: GLenum -> TextureUnit unmarshalTextureUnit x = TextureUnit (fromIntegral (x - gl_TEXTURE0)) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Texturing/PixelInternalFormat.hs0000644000000000000000000002557312521420345025425 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.PixelInternalFormat -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for (un-)marshaling PixelInternalFormat. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Texturing.PixelInternalFormat ( PixelInternalFormat(..), marshalPixelInternalFormat, marshalPixelInternalFormat', unmarshalPixelInternalFormat, ) where import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data PixelInternalFormat = Alpha' | DepthComponent' | Luminance' | LuminanceAlpha' | Intensity | R8 | R16 | RG8 | RG16 | RGB' | RGBA' | SRGB | SRGBAlpha | SLuminance | SLuminanceAlpha | Alpha4 | Alpha8 | Alpha12 | Alpha16 | DepthComponent16 | DepthComponent24 | DepthComponent32 | Luminance4 | Luminance8 | Luminance12 | Luminance16 | Luminance4Alpha4 | Luminance6Alpha2 | Luminance8Alpha8 | Luminance12Alpha4 | Luminance12Alpha12 | Luminance16Alpha16 | Intensity4 | Intensity8 | Intensity12 | Intensity16 | R3G3B2 | RGB4 | RGB5 | RGB8 | RGB10 | RGB12 | RGB16 | RGBA2 | RGBA4 | RGB5A1 | RGBA8 | RGB10A2 | RGBA12 | RGBA16 | SRGB8 | SRGB8Alpha8 | R16F | RG16F | RGB16F | RGBA16F | R32F | RG32F | RGB32F | RGBA32F | R8I | R8UI | R16I | R16UI | R32I | R32UI | RG8I | RG8UI | RG16I | RG16UI | RG32I | RG32UI | RGB8I | RGB8UI | RGB16I | RGB16UI | RGB32I | RGB32UI | RGBA8I | RGBA8UI | RGBA16I | RGBA16UI | RGBA32I | RGBA32UI | SLuminance8 | SLuminance8Alpha8 | CompressedAlpha | CompressedLuminance | CompressedLuminanceAlpha | CompressedIntensity | CompressedRed | CompressedRG | CompressedRGB | CompressedRGBA | CompressedSRGB | CompressedSRGBAlpha | CompressedSLuminance | CompressedSLuminanceAlpha | CompressedRedRGTC1 | CompressedSignedRedRGTC1 | CompressedRG_RGTC2 | CompressedSignedRG_RGTC2 | DepthComponent32f | Depth32fStencil8 | RGB9E5 | R11fG11fB10f | StencilIndex1 | StencilIndex4 | StencilIndex8 | StencilIndex16 deriving ( Eq, Ord, Show ) marshalPixelInternalFormat :: PixelInternalFormat -> GLint marshalPixelInternalFormat x = fromIntegral $ case x of Alpha' -> gl_ALPHA DepthComponent' -> gl_DEPTH_COMPONENT Luminance' -> gl_LUMINANCE LuminanceAlpha' -> gl_LUMINANCE_ALPHA R8 -> gl_R8 R16 -> gl_R16 RG8 -> gl_RG8 RG16 -> gl_RG16 RGB' -> gl_RGB RGBA' -> gl_RGBA SRGB -> gl_SRGB SRGBAlpha -> gl_SRGB_ALPHA SLuminance -> gl_SLUMINANCE SLuminanceAlpha -> gl_SLUMINANCE_ALPHA Alpha4 -> gl_ALPHA4 Alpha8 -> gl_ALPHA8 Alpha12 -> gl_ALPHA12 Alpha16 -> gl_ALPHA16 DepthComponent16 -> gl_DEPTH_COMPONENT16 DepthComponent24 -> gl_DEPTH_COMPONENT24 DepthComponent32 -> gl_DEPTH_COMPONENT32 Luminance4 -> gl_LUMINANCE4 Luminance8 -> gl_LUMINANCE8 Luminance12 -> gl_LUMINANCE12 Luminance16 -> gl_LUMINANCE16 Luminance4Alpha4 -> gl_LUMINANCE4_ALPHA4 Luminance6Alpha2 -> gl_LUMINANCE6_ALPHA2 Luminance8Alpha8 -> gl_LUMINANCE8_ALPHA8 Luminance12Alpha4 -> gl_LUMINANCE12_ALPHA4 Luminance12Alpha12 -> gl_LUMINANCE12_ALPHA12 Luminance16Alpha16 -> gl_LUMINANCE16_ALPHA16 Intensity -> gl_INTENSITY Intensity4 -> gl_INTENSITY4 Intensity8 -> gl_INTENSITY8 Intensity12 -> gl_INTENSITY12 Intensity16 -> gl_INTENSITY16 R3G3B2 -> gl_R3_G3_B2 RGB4 -> gl_RGB4 RGB5 -> gl_RGB5 RGB8 -> gl_RGB8 RGB10 -> gl_RGB10 RGB12 -> gl_RGB12 RGB16 -> gl_RGB16 RGBA2 -> gl_RGBA2 RGBA4 -> gl_RGBA4 RGB5A1 -> gl_RGB5_A1 RGBA8 -> gl_RGBA8 RGB10A2 -> gl_RGB10_A2 RGBA12 -> gl_RGBA12 RGBA16 -> gl_RGBA16 SRGB8 -> gl_SRGB8 SRGB8Alpha8 -> gl_SRGB8_ALPHA8 R16F -> gl_R16F RG16F -> gl_RG16F RGB16F -> gl_RGB16F RGBA16F -> gl_RGBA16F R32F -> gl_R32F RG32F -> gl_RG32F RGB32F -> gl_RGB32F RGBA32F -> gl_RGBA32F R8I -> gl_R8I R8UI -> gl_R8UI R16I -> gl_R16I R16UI -> gl_R16UI R32I -> gl_R32I R32UI -> gl_R32UI RG8I -> gl_RG8I RG8UI -> gl_RG8UI RG16I -> gl_RG16I RG16UI -> gl_RG16UI RG32I -> gl_R32I RG32UI -> gl_R32UI RGB8I -> gl_RGB8I RGB8UI -> gl_RGB8UI RGB16I -> gl_RGB16I RGB16UI -> gl_RGB16UI RGB32I -> gl_RGB32I RGB32UI -> gl_RGB32UI RGBA8I -> gl_RGBA8I RGBA8UI -> gl_RGBA8UI RGBA16I -> gl_RGBA16I RGBA16UI -> gl_RGBA16UI RGBA32I -> gl_RGBA32I RGBA32UI -> gl_RGBA32UI SLuminance8 -> gl_SLUMINANCE8 SLuminance8Alpha8 -> gl_SLUMINANCE8_ALPHA8 CompressedAlpha -> gl_COMPRESSED_ALPHA CompressedLuminance -> gl_COMPRESSED_LUMINANCE CompressedLuminanceAlpha -> gl_COMPRESSED_LUMINANCE_ALPHA CompressedIntensity -> gl_COMPRESSED_INTENSITY CompressedRed -> gl_COMPRESSED_RED CompressedRG -> gl_COMPRESSED_RG CompressedRGB -> gl_COMPRESSED_RGB CompressedRGBA -> gl_COMPRESSED_RGBA CompressedSRGB -> gl_COMPRESSED_SRGB CompressedSRGBAlpha -> gl_COMPRESSED_SRGB_ALPHA CompressedSLuminance -> gl_COMPRESSED_SLUMINANCE CompressedSLuminanceAlpha -> gl_COMPRESSED_SLUMINANCE_ALPHA CompressedRedRGTC1 -> gl_COMPRESSED_RED_RGTC1 CompressedSignedRedRGTC1 -> gl_COMPRESSED_SIGNED_RED_RGTC1 CompressedRG_RGTC2 -> gl_COMPRESSED_RG_RGTC2 CompressedSignedRG_RGTC2 -> gl_COMPRESSED_SIGNED_RG_RGTC2 DepthComponent32f -> gl_DEPTH_COMPONENT32F Depth32fStencil8 -> gl_DEPTH32F_STENCIL8 RGB9E5 -> gl_RGB9_E5 R11fG11fB10f -> gl_R11F_G11F_B10F StencilIndex1 -> gl_STENCIL_INDEX1 StencilIndex4 -> gl_STENCIL_INDEX4 StencilIndex8 -> gl_STENCIL_INDEX8 StencilIndex16 -> gl_STENCIL_INDEX16 -- *sigh* The OpenGL API is sometimes a bit creative in its usage of types... marshalPixelInternalFormat' :: PixelInternalFormat -> GLenum marshalPixelInternalFormat' = fromIntegral . marshalPixelInternalFormat unmarshalPixelInternalFormat :: GLint -> PixelInternalFormat unmarshalPixelInternalFormat x | y == gl_ALPHA = Alpha' | y == gl_DEPTH_COMPONENT = DepthComponent' | y == gl_LUMINANCE = Luminance' | y == gl_LUMINANCE_ALPHA = LuminanceAlpha' | y == gl_RGB = RGB' | y == gl_RGBA = RGBA' | y == gl_SRGB = SRGB | y == gl_SRGB_ALPHA = SRGBAlpha | y == gl_SLUMINANCE = SLuminance | y == gl_SLUMINANCE_ALPHA = SLuminanceAlpha | y == gl_ALPHA4 = Alpha4 | y == gl_ALPHA8 = Alpha8 | y == gl_ALPHA12 = Alpha12 | y == gl_ALPHA16 = Alpha16 | y == gl_DEPTH_COMPONENT16 = DepthComponent16 | y == gl_DEPTH_COMPONENT24 = DepthComponent24 | y == gl_DEPTH_COMPONENT32 = DepthComponent32 | y == gl_LUMINANCE4 = Luminance4 | y == gl_LUMINANCE8 = Luminance8 | y == gl_LUMINANCE12 = Luminance12 | y == gl_LUMINANCE16 = Luminance16 | y == gl_LUMINANCE4_ALPHA4 = Luminance4Alpha4 | y == gl_LUMINANCE6_ALPHA2 = Luminance6Alpha2 | y == gl_LUMINANCE8_ALPHA8 = Luminance8Alpha8 | y == gl_LUMINANCE12_ALPHA4 = Luminance12Alpha4 | y == gl_LUMINANCE12_ALPHA12 = Luminance12Alpha12 | y == gl_LUMINANCE16_ALPHA16 = Luminance16Alpha16 | y == gl_INTENSITY = Intensity | y == gl_INTENSITY4 = Intensity4 | y == gl_INTENSITY8 = Intensity8 | y == gl_INTENSITY12 = Intensity12 | y == gl_INTENSITY16 = Intensity16 | y == gl_R3_G3_B2 = R3G3B2 | y == gl_RGB4 = RGB4 | y == gl_RGB5 = RGB5 | y == gl_RGB8 = RGB8 | y == gl_RGB10 = RGB10 | y == gl_RGB12 = RGB12 | y == gl_RGB16 = RGB16 | y == gl_RGBA2 = RGBA2 | y == gl_RGBA4 = RGBA4 | y == gl_RGB5_A1 = RGB5A1 | y == gl_RGBA8 = RGBA8 | y == gl_RGB10_A2 = RGB10A2 | y == gl_RGBA12 = RGBA12 | y == gl_RGBA16 = RGBA16 | y == gl_SRGB8 = SRGB8 | y == gl_SRGB8_ALPHA8 = SRGB8Alpha8 | y == gl_R16F = R16F | y == gl_RG16F = RG16F | y == gl_RGB16F = RGB16F | y == gl_RGBA16F = RGBA16F | y == gl_R32F = R32F | y == gl_RG32F = RG32F | y == gl_RGB32F = RGB32F | y == gl_RGBA32F = RGBA32F | y == gl_R8I = R8I | y == gl_R8UI = R8UI | y == gl_R16I = R16I | y == gl_R16UI = R16UI | y == gl_R32I = R32I | y == gl_R32UI = R32UI | y == gl_RG8I = RG8I | y == gl_RG8UI = RG8UI | y == gl_RG16I = RG16I | y == gl_RG16UI = RG16UI | y == gl_R32I = RG32I | y == gl_R32UI = RG32UI | y == gl_RGB8I = RGB8I | y == gl_RGB8UI = RGB8UI | y == gl_RGB16I = RGB16I | y == gl_RGB16UI = RGB16UI | y == gl_RGB32I = RGB32I | y == gl_RGB32UI = RGB32UI | y == gl_RGBA8I = RGBA8I | y == gl_RGBA8UI = RGBA8UI | y == gl_RGBA16I = RGBA16I | y == gl_RGBA16UI = RGBA16UI | y == gl_RGBA32I = RGBA32I | y == gl_RGBA32UI = RGBA32UI | y == gl_SLUMINANCE8 = SLuminance8 | y == gl_SLUMINANCE8_ALPHA8 = SLuminance8Alpha8 | y == gl_COMPRESSED_ALPHA = CompressedAlpha | y == gl_COMPRESSED_LUMINANCE = CompressedLuminance | y == gl_COMPRESSED_LUMINANCE_ALPHA = CompressedLuminanceAlpha | y == gl_COMPRESSED_INTENSITY = CompressedIntensity | y == gl_COMPRESSED_RED = CompressedRed | y == gl_COMPRESSED_RG = CompressedRG | y == gl_COMPRESSED_RGB = CompressedRGB | y == gl_COMPRESSED_RGBA = CompressedRGBA | y == gl_COMPRESSED_SRGB = CompressedSRGB | y == gl_COMPRESSED_SRGB_ALPHA = CompressedSRGBAlpha | y == gl_COMPRESSED_SLUMINANCE = CompressedSLuminance | y == gl_COMPRESSED_SLUMINANCE_ALPHA = CompressedSLuminanceAlpha | y == gl_COMPRESSED_RED_RGTC1 = CompressedRedRGTC1 | y == gl_COMPRESSED_SIGNED_RED_RGTC1 = CompressedSignedRedRGTC1 | y == gl_COMPRESSED_RG_RGTC2 = CompressedRG_RGTC2 | y == gl_COMPRESSED_SIGNED_RG_RGTC2 = CompressedSignedRG_RGTC2 | y == gl_DEPTH_COMPONENT32F = DepthComponent32f | y == gl_DEPTH32F_STENCIL8 = Depth32fStencil8 | y == gl_RGB9_E5 = RGB9E5 | y == gl_STENCIL_INDEX1 = StencilIndex1 | y == gl_STENCIL_INDEX4 = StencilIndex4 | y == gl_STENCIL_INDEX8 = StencilIndex8 | y == gl_STENCIL_INDEX16 = StencilIndex16 -- legacy values | y == 1 = Luminance' | y == 2 = LuminanceAlpha' | y == 3 = RGB' | y == 4 = RGBA' | otherwise = error ("unmarshalPixelInternalFormat: illegal value " ++ show x) where y = fromIntegral x -- Note: The following formats are still missing, it's a bit unclear how to -- handle these nicely. From the EXT_texture_sRGB spec: -- -- Accepted by the parameter of TexImage2D, CopyTexImage2D, -- and CompressedTexImage2DARB and the parameter of -- CompressedTexSubImage2DARB: -- -- COMPRESSED_SRGB_S3TC_DXT1_EXT 0x8C4C -- COMPRESSED_SRGB_ALPHA_S3TC_DXT1_EXT 0x8C4D -- COMPRESSED_SRGB_ALPHA_S3TC_DXT3_EXT 0x8C4E -- COMPRESSED_SRGB_ALPHA_S3TC_DXT5_EXT 0x8C4F OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Texturing/TextureTarget.hs0000644000000000000000000002732012521420345024275 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for marshaling texture targets. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget ( -- * Texture Target Classification BindableTextureTarget(..), ParameterizedTextureTarget(..), OneDimensionalTextureTarget(..), TwoDimensionalTextureTarget(..), ThreeDimensionalTextureTarget(..), QueryableTextureTarget(..), GettableTextureTarget(..), -- * One-Dimensional Texture Targets TextureTarget1D(..), -- * Two-Dimensional Texture Targets TextureTarget2D(..), TextureTarget2DMultisample(..), TextureTargetCubeMap(..), TextureTargetCubeMapFace(..), unmarshalTextureTargetCubeMapFace, -- * Three-Dimensional Texture Targets TextureTarget3D(..), TextureTarget2DMultisampleArray(..), -- * Texture Buffer Target TextureTargetBuffer(..) ) where import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable import Graphics.Rendering.OpenGL.GL.QueryUtils.PName import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- class BindableTextureTarget t where marshalBindableTextureTarget :: t -> GLenum marshalBindableTextureTargetPName1I :: t -> PName1I class ParameterizedTextureTarget t where marshalParameterizedTextureTarget :: t -> GLenum marshalParameterizedTextureTargetProxy :: t -> GLenum marshalParameterizedTextureTargetEnableCap :: t -> EnableCap class OneDimensionalTextureTarget t where marshalOneDimensionalTextureTarget :: Proxy -> t -> GLenum class TwoDimensionalTextureTarget t where marshalTwoDimensionalTextureTarget :: Proxy -> t -> GLenum class ThreeDimensionalTextureTarget t where marshalThreeDimensionalTextureTarget :: Proxy -> t -> GLenum class QueryableTextureTarget t where marshalQueryableTextureTarget :: t -> GLenum class GettableTextureTarget t where marshalGettableTextureTarget :: t -> GLenum -------------------------------------------------------------------------------- data TextureTarget1D = Texture1D deriving ( Eq, Ord, Show ) instance BindableTextureTarget TextureTarget1D where marshalBindableTextureTarget = marshalParameterizedTextureTarget marshalBindableTextureTargetPName1I t = case t of Texture1D -> GetTextureBinding1D instance ParameterizedTextureTarget TextureTarget1D where marshalParameterizedTextureTarget t = case t of Texture1D -> gl_TEXTURE_1D marshalParameterizedTextureTargetProxy t = case t of Texture1D -> gl_PROXY_TEXTURE_1D marshalParameterizedTextureTargetEnableCap t = case t of Texture1D -> CapTexture1D instance OneDimensionalTextureTarget TextureTarget1D where marshalOneDimensionalTextureTarget p = case p of NoProxy -> marshalParameterizedTextureTarget Proxy -> marshalParameterizedTextureTargetProxy instance QueryableTextureTarget TextureTarget1D where marshalQueryableTextureTarget = marshalParameterizedTextureTarget instance GettableTextureTarget TextureTarget1D where marshalGettableTextureTarget = marshalParameterizedTextureTarget -------------------------------------------------------------------------------- data TextureTarget2D = Texture2D | Texture1DArray | TextureRectangle deriving ( Eq, Ord, Show ) instance BindableTextureTarget TextureTarget2D where marshalBindableTextureTarget = marshalParameterizedTextureTarget marshalBindableTextureTargetPName1I t = case t of Texture2D -> GetTextureBinding2D Texture1DArray -> GetTextureBinding1DArray TextureRectangle -> GetTextureBindingRectangle instance ParameterizedTextureTarget TextureTarget2D where marshalParameterizedTextureTarget t = case t of Texture2D -> gl_TEXTURE_2D Texture1DArray -> gl_TEXTURE_1D_ARRAY TextureRectangle -> gl_TEXTURE_RECTANGLE marshalParameterizedTextureTargetProxy t = case t of Texture2D -> gl_PROXY_TEXTURE_2D Texture1DArray -> gl_PROXY_TEXTURE_1D_ARRAY TextureRectangle -> gl_PROXY_TEXTURE_RECTANGLE marshalParameterizedTextureTargetEnableCap t = case t of Texture2D -> CapTexture2D Texture1DArray -> CapTexture1DArray TextureRectangle -> CapTextureRectangle instance TwoDimensionalTextureTarget TextureTarget2D where marshalTwoDimensionalTextureTarget p = case p of NoProxy -> marshalParameterizedTextureTarget Proxy -> marshalParameterizedTextureTargetProxy instance QueryableTextureTarget TextureTarget2D where marshalQueryableTextureTarget = marshalParameterizedTextureTarget instance GettableTextureTarget TextureTarget2D where marshalGettableTextureTarget = marshalParameterizedTextureTarget -------------------------------------------------------------------------------- data TextureTarget2DMultisample = Texture2DMultisample deriving ( Eq, Ord, Show ) instance BindableTextureTarget TextureTarget2DMultisample where marshalBindableTextureTarget = marshalParameterizedTextureTarget marshalBindableTextureTargetPName1I t = case t of Texture2DMultisample -> GetTextureBinding2DMultisample instance ParameterizedTextureTarget TextureTarget2DMultisample where marshalParameterizedTextureTarget t = case t of Texture2DMultisample -> gl_TEXTURE_2D_MULTISAMPLE marshalParameterizedTextureTargetProxy t = case t of Texture2DMultisample -> gl_PROXY_TEXTURE_2D_MULTISAMPLE marshalParameterizedTextureTargetEnableCap t = case t of Texture2DMultisample -> CapTexture2DMultisample instance QueryableTextureTarget TextureTarget2DMultisample where marshalQueryableTextureTarget = marshalParameterizedTextureTarget -------------------------------------------------------------------------------- data TextureTargetCubeMap = TextureCubeMap deriving ( Eq, Ord, Show ) instance BindableTextureTarget TextureTargetCubeMap where marshalBindableTextureTarget = marshalParameterizedTextureTarget marshalBindableTextureTargetPName1I t = case t of TextureCubeMap -> GetTextureBindingCubeMap instance ParameterizedTextureTarget TextureTargetCubeMap where marshalParameterizedTextureTarget t = case t of TextureCubeMap -> gl_TEXTURE_CUBE_MAP marshalParameterizedTextureTargetProxy t = case t of TextureCubeMap -> gl_PROXY_TEXTURE_CUBE_MAP marshalParameterizedTextureTargetEnableCap t = case t of TextureCubeMap -> CapTextureCubeMap instance TwoDimensionalTextureTarget TextureTargetCubeMap where marshalTwoDimensionalTextureTarget p = case p of NoProxy -> \t -> error ("No non-proxy target for " ++ show t) Proxy -> marshalParameterizedTextureTargetProxy -------------------------------------------------------------------------------- data TextureTargetCubeMapFace = TextureCubeMapPositiveX | TextureCubeMapNegativeX | TextureCubeMapPositiveY | TextureCubeMapNegativeY | TextureCubeMapPositiveZ | TextureCubeMapNegativeZ deriving ( Eq, Ord, Show ) instance TwoDimensionalTextureTarget TextureTargetCubeMapFace where marshalTwoDimensionalTextureTarget p = case p of NoProxy -> marshalQueryableTextureTarget -- We could silently map this to TextureCubeMap if we wanted. Proxy -> \t -> error ("No proxy target for " ++ show t) instance QueryableTextureTarget TextureTargetCubeMapFace where marshalQueryableTextureTarget t = case t of TextureCubeMapPositiveX -> gl_TEXTURE_CUBE_MAP_POSITIVE_X TextureCubeMapNegativeX -> gl_TEXTURE_CUBE_MAP_NEGATIVE_X TextureCubeMapPositiveY -> gl_TEXTURE_CUBE_MAP_POSITIVE_Y TextureCubeMapNegativeY -> gl_TEXTURE_CUBE_MAP_NEGATIVE_Y TextureCubeMapPositiveZ -> gl_TEXTURE_CUBE_MAP_POSITIVE_Z TextureCubeMapNegativeZ -> gl_TEXTURE_CUBE_MAP_NEGATIVE_Z instance GettableTextureTarget TextureTargetCubeMapFace where marshalGettableTextureTarget = marshalQueryableTextureTarget unmarshalTextureTargetCubeMapFace :: GLenum -> TextureTargetCubeMapFace unmarshalTextureTargetCubeMapFace x | x == gl_TEXTURE_CUBE_MAP_POSITIVE_X = TextureCubeMapPositiveX | x == gl_TEXTURE_CUBE_MAP_NEGATIVE_X = TextureCubeMapNegativeX | x == gl_TEXTURE_CUBE_MAP_POSITIVE_Y = TextureCubeMapPositiveY | x == gl_TEXTURE_CUBE_MAP_NEGATIVE_Y = TextureCubeMapNegativeY | x == gl_TEXTURE_CUBE_MAP_POSITIVE_Z = TextureCubeMapPositiveZ | x == gl_TEXTURE_CUBE_MAP_NEGATIVE_Z = TextureCubeMapNegativeZ | otherwise = error $ "unmarshalTextureTargetCubeMapFace: unknown enum " ++ show x -------------------------------------------------------------------------------- data TextureTarget3D = Texture3D | Texture2DArray | TextureCubeMapArray deriving ( Eq, Ord, Show ) instance BindableTextureTarget TextureTarget3D where marshalBindableTextureTarget = marshalParameterizedTextureTarget marshalBindableTextureTargetPName1I t = case t of Texture3D -> GetTextureBinding3D Texture2DArray -> GetTextureBinding2DArray TextureCubeMapArray -> GetTextureBindingCubeMapArray instance ParameterizedTextureTarget TextureTarget3D where marshalParameterizedTextureTarget t = case t of Texture3D -> gl_TEXTURE_3D Texture2DArray -> gl_TEXTURE_2D_ARRAY TextureCubeMapArray -> gl_TEXTURE_CUBE_MAP_ARRAY marshalParameterizedTextureTargetProxy t = case t of Texture3D -> gl_PROXY_TEXTURE_3D Texture2DArray -> gl_PROXY_TEXTURE_2D_ARRAY TextureCubeMapArray -> gl_PROXY_TEXTURE_CUBE_MAP_ARRAY marshalParameterizedTextureTargetEnableCap t = case t of Texture3D -> CapTexture3D Texture2DArray -> CapTexture2DArray TextureCubeMapArray -> CapTextureCubeMapArray instance ThreeDimensionalTextureTarget TextureTarget3D where marshalThreeDimensionalTextureTarget p = case p of NoProxy -> marshalParameterizedTextureTarget Proxy -> marshalParameterizedTextureTargetProxy instance QueryableTextureTarget TextureTarget3D where marshalQueryableTextureTarget = marshalParameterizedTextureTarget instance GettableTextureTarget TextureTarget3D where marshalGettableTextureTarget = marshalParameterizedTextureTarget -------------------------------------------------------------------------------- data TextureTarget2DMultisampleArray = Texture2DMultisampleArray deriving ( Eq, Ord, Show ) instance BindableTextureTarget TextureTarget2DMultisampleArray where marshalBindableTextureTarget = marshalParameterizedTextureTarget marshalBindableTextureTargetPName1I t = case t of Texture2DMultisampleArray -> GetTextureBinding2DMultisampleArray instance ParameterizedTextureTarget TextureTarget2DMultisampleArray where marshalParameterizedTextureTarget t = case t of Texture2DMultisampleArray -> gl_TEXTURE_2D_MULTISAMPLE_ARRAY marshalParameterizedTextureTargetProxy t = case t of Texture2DMultisampleArray -> gl_PROXY_TEXTURE_2D_MULTISAMPLE_ARRAY marshalParameterizedTextureTargetEnableCap t = case t of Texture2DMultisampleArray -> CapTexture2DMultisampleArray instance QueryableTextureTarget TextureTarget2DMultisampleArray where marshalQueryableTextureTarget = marshalParameterizedTextureTarget -------------------------------------------------------------------------------- data TextureTargetBuffer = TextureBuffer' deriving ( Eq, Ord, Show ) instance BindableTextureTarget TextureTargetBuffer where marshalBindableTextureTarget t = case t of TextureBuffer' -> gl_TEXTURE_BUFFER marshalBindableTextureTargetPName1I t = case t of TextureBuffer' -> GetTextureBindingBuffer OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/Texturing/TextureObject.hs0000644000000000000000000000330212521420345024247 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.TextureObject -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for handling texture objects. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.Texturing.TextureObject ( TextureObject(..) ) where import Control.Monad.IO.Class import Data.ObjectName import Foreign.Marshal.Array ( allocaArray, peekArray, withArrayLen ) import Graphics.Rendering.OpenGL.GL.DebugOutput import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- newtype TextureObject = TextureObject { textureID :: GLuint } deriving ( Eq, Ord, Show ) -------------------------------------------------------------------------------- instance ObjectName TextureObject where isObjectName = liftIO . fmap unmarshalGLboolean . glIsTexture . textureID deleteObjectNames textureObjects = liftIO . withArrayLen (map textureID textureObjects) $ glDeleteTextures . fromIntegral instance GeneratableObjectName TextureObject where genObjectNames n = liftIO . allocaArray n $ \buf -> do glGenTextures (fromIntegral n) buf fmap (map TextureObject) $ peekArray n buf instance CanBeLabeled TextureObject where objectLabel = objectNameLabel gl_TEXTURE . textureID OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PixelRectangles/0000755000000000000000000000000012521420345022226 5ustar0000000000000000OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PixelRectangles/Histogram.hs0000644000000000000000000001125312521420345024521 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles.Histogram -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to a part of section 3.6.1 (Pixel Storage Modes) of -- the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PixelRectangles.Histogram ( Sink(..), histogram, Reset(..), getHistogram, resetHistogram, histogramRGBASizes, histogramLuminanceSize ) where import Data.StateVar import Foreign.Marshal.Utils import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.PixelData import Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable import Graphics.Rendering.OpenGL.GL.PixelRectangles.Reset import Graphics.Rendering.OpenGL.GL.PixelRectangles.Sink import Graphics.Rendering.OpenGL.GL.Texturing.PixelInternalFormat import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data HistogramTarget = Histogram | ProxyHistogram marshalHistogramTarget :: HistogramTarget -> GLenum marshalHistogramTarget x = case x of Histogram -> gl_HISTOGRAM ProxyHistogram -> gl_PROXY_HISTOGRAM proxyToHistogramTarget :: Proxy -> HistogramTarget proxyToHistogramTarget x = case x of NoProxy -> Histogram Proxy -> ProxyHistogram -------------------------------------------------------------------------------- histogram :: Proxy -> StateVar (Maybe (GLsizei, PixelInternalFormat, Sink)) histogram proxy = makeStateVarMaybe (return CapHistogram) (getHistogram' proxy) (setHistogram proxy) getHistogram' :: Proxy -> IO (GLsizei, PixelInternalFormat, Sink) getHistogram' proxy = do w <- getHistogramParameteri fromIntegral proxy HistogramWidth f <- getHistogramParameteri unmarshalPixelInternalFormat proxy HistogramFormat s <- getHistogramParameteri unmarshalSink proxy HistogramSink return (w, f, s) getHistogramParameteri :: (GLint -> a) -> Proxy -> GetHistogramParameterPName -> IO a getHistogramParameteri f proxy p = with 0 $ \buf -> do glGetHistogramParameteriv (marshalHistogramTarget (proxyToHistogramTarget proxy)) (marshalGetHistogramParameterPName p) buf peek1 f buf setHistogram :: Proxy -> (GLsizei, PixelInternalFormat, Sink) -> IO () setHistogram proxy (w, int, sink) = glHistogram (marshalHistogramTarget (proxyToHistogramTarget proxy)) w (marshalPixelInternalFormat' int) (marshalSink sink) -------------------------------------------------------------------------------- getHistogram :: Reset -> PixelData a -> IO () getHistogram reset pd = withPixelData pd $ glGetHistogram (marshalHistogramTarget Histogram) (marshalReset reset) -------------------------------------------------------------------------------- resetHistogram :: IO () resetHistogram = glResetHistogram (marshalHistogramTarget Histogram) -------------------------------------------------------------------------------- data GetHistogramParameterPName = HistogramWidth | HistogramFormat | HistogramRedSize | HistogramGreenSize | HistogramBlueSize | HistogramAlphaSize | HistogramLuminanceSize | HistogramSink marshalGetHistogramParameterPName :: GetHistogramParameterPName -> GLenum marshalGetHistogramParameterPName x = case x of HistogramWidth -> gl_HISTOGRAM_WIDTH HistogramFormat -> gl_HISTOGRAM_FORMAT HistogramRedSize -> gl_HISTOGRAM_RED_SIZE HistogramGreenSize -> gl_HISTOGRAM_GREEN_SIZE HistogramBlueSize -> gl_HISTOGRAM_BLUE_SIZE HistogramAlphaSize -> gl_HISTOGRAM_ALPHA_SIZE HistogramLuminanceSize -> gl_HISTOGRAM_LUMINANCE_SIZE HistogramSink -> gl_HISTOGRAM_SINK -------------------------------------------------------------------------------- histogramRGBASizes :: Proxy -> GettableStateVar (Color4 GLsizei) histogramRGBASizes proxy = makeGettableStateVar $ do r <- getHistogramParameteri fromIntegral proxy HistogramRedSize g <- getHistogramParameteri fromIntegral proxy HistogramGreenSize b <- getHistogramParameteri fromIntegral proxy HistogramBlueSize a <- getHistogramParameteri fromIntegral proxy HistogramAlphaSize return $ Color4 r g b a histogramLuminanceSize :: Proxy -> GettableStateVar GLsizei histogramLuminanceSize proxy = makeGettableStateVar $ getHistogramParameteri fromIntegral proxy HistogramLuminanceSize OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PixelRectangles/Sink.hs0000644000000000000000000000200512521420345023463 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles.Sink -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for (un-)marshaling Sink. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PixelRectangles.Sink ( Sink(..), marshalSink, unmarshalSink ) where import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data Sink = PassThrough | Sink deriving ( Eq, Ord, Show ) marshalSink :: Sink -> GLboolean marshalSink x = marshalGLboolean (x == Sink) unmarshalSink :: GLint -> Sink unmarshalSink s = if unmarshalGLboolean s then Sink else PassThrough OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PixelRectangles/PixelTransfer.hs0000644000000000000000000002025512521420345025354 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelTransfer -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to a part of section 3.6.1 (Pixel Storage Modes) of -- the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelTransfer ( PixelTransferStage(..), mapColor, mapStencil, indexShift, indexOffset, depthScale, depthBias, rgbaScale, rgbaBias ) where import Data.StateVar import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data PixelTransfer = MapColor | MapStencil | IndexShift | IndexOffset | RedScale | RedBias | GreenScale | GreenBias | BlueScale | BlueBias | AlphaScale | AlphaBias | DepthScale | DepthBias | PostConvolutionRedScale | PostConvolutionGreenScale | PostConvolutionBlueScale | PostConvolutionAlphaScale | PostConvolutionRedBias | PostConvolutionGreenBias | PostConvolutionBlueBias | PostConvolutionAlphaBias | PostColorMatrixRedScale | PostColorMatrixGreenScale | PostColorMatrixBlueScale | PostColorMatrixAlphaScale | PostColorMatrixRedBias | PostColorMatrixGreenBias | PostColorMatrixBlueBias | PostColorMatrixAlphaBias marshalPixelTransfer :: PixelTransfer -> GLenum marshalPixelTransfer x = case x of MapColor -> gl_MAP_COLOR MapStencil -> gl_MAP_STENCIL IndexShift -> gl_INDEX_SHIFT IndexOffset -> gl_INDEX_OFFSET RedScale -> gl_RED_SCALE RedBias -> gl_RED_BIAS GreenScale -> gl_GREEN_SCALE GreenBias -> gl_GREEN_BIAS BlueScale -> gl_BLUE_SCALE BlueBias -> gl_BLUE_BIAS AlphaScale -> gl_ALPHA_SCALE AlphaBias -> gl_ALPHA_BIAS DepthScale -> gl_DEPTH_SCALE DepthBias -> gl_DEPTH_BIAS PostConvolutionRedScale -> gl_POST_CONVOLUTION_RED_SCALE PostConvolutionGreenScale -> gl_POST_CONVOLUTION_GREEN_SCALE PostConvolutionBlueScale -> gl_POST_CONVOLUTION_BLUE_SCALE PostConvolutionAlphaScale -> gl_POST_CONVOLUTION_ALPHA_SCALE PostConvolutionRedBias -> gl_POST_CONVOLUTION_RED_BIAS PostConvolutionGreenBias -> gl_POST_CONVOLUTION_GREEN_BIAS PostConvolutionBlueBias -> gl_POST_CONVOLUTION_BLUE_BIAS PostConvolutionAlphaBias -> gl_POST_CONVOLUTION_ALPHA_BIAS PostColorMatrixRedScale -> gl_POST_COLOR_MATRIX_RED_SCALE PostColorMatrixGreenScale -> gl_POST_COLOR_MATRIX_GREEN_SCALE PostColorMatrixBlueScale -> gl_POST_COLOR_MATRIX_BLUE_SCALE PostColorMatrixAlphaScale -> gl_POST_COLOR_MATRIX_ALPHA_SCALE PostColorMatrixRedBias -> gl_POST_COLOR_MATRIX_RED_BIAS PostColorMatrixGreenBias -> gl_POST_COLOR_MATRIX_GREEN_BIAS PostColorMatrixBlueBias -> gl_POST_COLOR_MATRIX_BLUE_BIAS PostColorMatrixAlphaBias -> gl_POST_COLOR_MATRIX_ALPHA_BIAS -------------------------------------------------------------------------------- data PixelTransferStage = PreConvolution | PostConvolution | PostColorMatrix deriving ( Eq, Ord, Show ) stageToGetScales :: PixelTransferStage -> (PName1F, PName1F, PName1F, PName1F) stageToGetScales s = case s of PreConvolution -> (GetRedScale, GetGreenScale, GetBlueScale, GetAlphaScale) PostConvolution -> (GetPostConvolutionRedScale, GetPostConvolutionGreenScale, GetPostConvolutionBlueScale, GetPostConvolutionAlphaScale) PostColorMatrix -> (GetPostColorMatrixRedScale, GetPostColorMatrixGreenScale, GetPostColorMatrixBlueScale, GetPostColorMatrixAlphaScale) stageToSetScales :: PixelTransferStage -> (PixelTransfer, PixelTransfer, PixelTransfer, PixelTransfer) stageToSetScales s = case s of PreConvolution -> (RedScale, GreenScale, BlueScale, AlphaScale) PostConvolution -> (PostConvolutionRedScale, PostConvolutionGreenScale, PostConvolutionBlueScale, PostConvolutionAlphaScale) PostColorMatrix -> (PostColorMatrixRedScale, PostColorMatrixGreenScale, PostColorMatrixBlueScale, PostColorMatrixAlphaScale) stageToGetBiases :: PixelTransferStage -> (PName1F, PName1F, PName1F, PName1F) stageToGetBiases s = case s of PreConvolution -> (GetRedBias, GetGreenBias, GetBlueBias, GetAlphaBias) PostConvolution -> (GetPostConvolutionRedBias, GetPostConvolutionGreenBias, GetPostConvolutionBlueBias, GetPostConvolutionAlphaBias) PostColorMatrix -> (GetPostColorMatrixRedBias, GetPostColorMatrixGreenBias, GetPostColorMatrixBlueBias, GetPostColorMatrixAlphaBias) stageToSetBiases :: PixelTransferStage -> (PixelTransfer, PixelTransfer, PixelTransfer, PixelTransfer) stageToSetBiases s = case s of PreConvolution -> (RedBias, GreenBias, BlueBias, AlphaBias) PostConvolution -> (PostConvolutionRedBias, PostConvolutionGreenBias, PostConvolutionBlueBias, PostConvolutionAlphaBias) PostColorMatrix -> (PostColorMatrixRedBias, PostColorMatrixGreenBias, PostColorMatrixBlueBias, PostColorMatrixAlphaBias) -------------------------------------------------------------------------------- mapColor :: StateVar Capability mapColor = pixelTransferb GetMapColor MapColor mapStencil :: StateVar Capability mapStencil = pixelTransferb GetMapStencil MapStencil indexShift :: StateVar GLint indexShift = pixelTransferi GetIndexShift IndexShift indexOffset :: StateVar GLint indexOffset = pixelTransferi GetIndexOffset IndexOffset depthScale :: StateVar GLfloat depthScale = pixelTransferf GetDepthScale DepthScale depthBias :: StateVar GLfloat depthBias = pixelTransferf GetDepthBias DepthBias rgbaScale :: PixelTransferStage -> StateVar (Color4 GLfloat) rgbaScale s = pixelTransfer4f (stageToGetScales s) (stageToSetScales s) rgbaBias :: PixelTransferStage -> StateVar (Color4 GLfloat) rgbaBias s = pixelTransfer4f (stageToGetBiases s) (stageToSetBiases s) -------------------------------------------------------------------------------- pixelTransferb :: GetPName1I p => p -> PixelTransfer -> StateVar Capability pixelTransferb pn pt = makeStateVar (getBoolean1 unmarshalCapability pn) (glPixelTransferi (marshalPixelTransfer pt) . fromIntegral . marshalCapability) pixelTransferi :: GetPName1I p => p -> PixelTransfer -> StateVar GLint pixelTransferi pn pt = makeStateVar (getInteger1 id pn) (glPixelTransferi (marshalPixelTransfer pt)) pixelTransferf :: GetPName1F p => p -> PixelTransfer -> StateVar GLfloat pixelTransferf pn pt = makeStateVar (getFloat1 id pn) (glPixelTransferf (marshalPixelTransfer pt)) pixelTransfer4f :: GetPName1F p => (p, p, p, p) -> (PixelTransfer, PixelTransfer, PixelTransfer, PixelTransfer) -> StateVar (Color4 GLfloat) pixelTransfer4f (pr, pg, pb, pa) (tr, tg, tb, ta) = makeStateVar get4f set4f where get4f = do r <- getFloat1 id pr g <- getFloat1 id pg b <- getFloat1 id pb a <- getFloat1 id pa return $ Color4 r g b a set4f (Color4 r g b a) = do glPixelTransferf (marshalPixelTransfer tr) r glPixelTransferf (marshalPixelTransfer tg) g glPixelTransferf (marshalPixelTransfer tb) b glPixelTransferf (marshalPixelTransfer ta) a OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PixelRectangles/ColorTable.hs0000644000000000000000000002230512521420345024612 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to a part of section 3.6.1 (Pixel Storage Modes) of -- the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable ( ColorTableStage(..), colorTableStage, Proxy(..), ColorTable(..), PixelInternalFormat(..), colorTable, getColorTable, copyColorTable, colorSubTable, copyColorSubTable, colorTableScale, colorTableBias, colorTableFormat, colorTableWidth, colorTableRGBASizes, colorTableLuminanceSize, colorTableIntesitySize, ) where import Data.StateVar import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.CoordTrans import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.PixelData import Graphics.Rendering.OpenGL.GL.Texturing.PixelInternalFormat import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data ColorTableStage = ColorTableStage | PostConvolutionColorTableStage | PostColorMatrixColorTableStage | TextureColorTableStage deriving ( Eq, Ord, Show ) colorTableStageToColorTable :: ColorTableStage -> ColorTable colorTableStageToColorTable x = case x of ColorTableStage -> ColorTable PostConvolutionColorTableStage -> PostConvolutionColorTable PostColorMatrixColorTableStage -> PostColorMatrixColorTable TextureColorTableStage -> TextureColorTable colorTableStageToEnableCap :: ColorTableStage -> EnableCap colorTableStageToEnableCap x = case x of ColorTableStage -> CapColorTable PostConvolutionColorTableStage -> CapPostConvolutionColorTable PostColorMatrixColorTableStage -> CapPostColorMatrixColorTable TextureColorTableStage -> CapTextureColorTable -------------------------------------------------------------------------------- colorTableStage :: ColorTableStage -> StateVar Capability colorTableStage = makeCapability . colorTableStageToEnableCap -------------------------------------------------------------------------------- data ColorTable = ColorTable | PostConvolutionColorTable | PostColorMatrixColorTable | Texture1DColorTable | Texture2DColorTable | Texture3DColorTable | TextureCubeMapColorTable | TextureColorTable | SharedTexturePalette deriving ( Eq, Ord, Show ) marshalColorTable :: ColorTable -> GLenum marshalColorTable x = case x of ColorTable -> gl_COLOR_TABLE PostConvolutionColorTable -> gl_POST_CONVOLUTION_COLOR_TABLE PostColorMatrixColorTable -> gl_POST_COLOR_MATRIX_COLOR_TABLE Texture1DColorTable -> gl_TEXTURE_1D Texture2DColorTable -> gl_TEXTURE_2D Texture3DColorTable -> gl_TEXTURE_3D TextureCubeMapColorTable -> gl_TEXTURE_CUBE_MAP TextureColorTable -> gl_TEXTURE_COLOR_TABLE_SGI SharedTexturePalette -> gl_SHARED_TEXTURE_PALETTE_EXT -------------------------------------------------------------------------------- data Proxy = NoProxy | Proxy deriving ( Eq, Ord, Show ) -------------------------------------------------------------------------------- marshalProxyColorTable :: Proxy -> ColorTable -> Maybe GLenum marshalProxyColorTable NoProxy x = Just (marshalColorTable x) marshalProxyColorTable Proxy x = case x of ColorTable -> Just gl_PROXY_COLOR_TABLE PostConvolutionColorTable -> Just gl_PROXY_POST_CONVOLUTION_COLOR_TABLE PostColorMatrixColorTable -> Just gl_PROXY_POST_COLOR_MATRIX_COLOR_TABLE Texture1DColorTable -> Just gl_PROXY_TEXTURE_1D Texture2DColorTable -> Just gl_PROXY_TEXTURE_2D Texture3DColorTable -> Just gl_PROXY_TEXTURE_3D TextureCubeMapColorTable -> Just gl_PROXY_TEXTURE_CUBE_MAP TextureColorTable -> Just gl_TEXTURE_COLOR_TABLE_SGI SharedTexturePalette -> Nothing -------------------------------------------------------------------------------- colorTable :: Proxy -> ColorTable -> PixelInternalFormat -> GLsizei -> PixelData a -> IO () colorTable proxy ct int w pd = maybe recordInvalidEnum (\target -> withPixelData pd $ glColorTable target (marshalPixelInternalFormat' int) w) (marshalProxyColorTable proxy ct) -------------------------------------------------------------------------------- getColorTable :: ColorTable -> PixelData a -> IO () getColorTable ct pd = withPixelData pd $ glGetColorTable (marshalColorTable ct) -------------------------------------------------------------------------------- copyColorTable :: ColorTable -> PixelInternalFormat -> Position -> GLsizei -> IO () copyColorTable ct int (Position x y) = glCopyColorTable (marshalColorTable ct) (marshalPixelInternalFormat' int) x y -------------------------------------------------------------------------------- colorSubTable :: ColorTable -> GLsizei -> GLsizei -> PixelData a -> IO () colorSubTable ct start count pd = withPixelData pd $ glColorSubTable (marshalColorTable ct) start count -------------------------------------------------------------------------------- copyColorSubTable :: ColorTable -> GLsizei -> Position -> GLsizei -> IO () copyColorSubTable ct start (Position x y) = glCopyColorSubTable (marshalColorTable ct) start x y -------------------------------------------------------------------------------- data ColorTablePName = ColorTableScale | ColorTableBias | ColorTableFormat | ColorTableWidth | ColorTableRedSize | ColorTableGreenSize | ColorTableBlueSize | ColorTableAlphaSize | ColorTableLuminanceSize | ColorTableIntensitySize marshalColorTablePName :: ColorTablePName -> GLenum marshalColorTablePName x = case x of ColorTableScale -> gl_COLOR_TABLE_SCALE ColorTableBias -> gl_COLOR_TABLE_BIAS ColorTableFormat -> gl_COLOR_TABLE_FORMAT ColorTableWidth -> gl_COLOR_TABLE_WIDTH ColorTableRedSize -> gl_COLOR_TABLE_RED_SIZE ColorTableGreenSize -> gl_COLOR_TABLE_GREEN_SIZE ColorTableBlueSize -> gl_COLOR_TABLE_BLUE_SIZE ColorTableAlphaSize -> gl_COLOR_TABLE_ALPHA_SIZE ColorTableLuminanceSize -> gl_COLOR_TABLE_LUMINANCE_SIZE ColorTableIntensitySize -> gl_COLOR_TABLE_INTENSITY_SIZE -------------------------------------------------------------------------------- colorTableScale :: ColorTableStage -> StateVar (Color4 GLfloat) colorTableScale = colorTableScaleBias ColorTableScale colorTableBias :: ColorTableStage -> StateVar (Color4 GLfloat) colorTableBias = colorTableScaleBias ColorTableBias colorTableScaleBias :: ColorTablePName -> ColorTableStage -> StateVar (Color4 GLfloat) colorTableScaleBias p s = makeStateVar (getColorTableParameterC4f ct p) (colorTableParameterC4f ct p) where ct = colorTableStageToColorTable s getColorTableParameterC4f :: ColorTable -> ColorTablePName -> IO (Color4 GLfloat) getColorTableParameterC4f ct p = alloca $ \buf -> do glGetColorTableParameterfv (marshalColorTable ct) (marshalColorTablePName p) (castPtr buf) peek buf colorTableParameterC4f :: ColorTable -> ColorTablePName -> Color4 GLfloat -> IO () colorTableParameterC4f ct p c = with c $ \ptr -> glColorTableParameterfv (marshalColorTable ct) (marshalColorTablePName p) (castPtr ptr) -------------------------------------------------------------------------------- colorTableFormat :: ColorTable -> GettableStateVar PixelInternalFormat colorTableFormat ct = makeGettableStateVar $ getColorTableParameteri unmarshalPixelInternalFormat ct ColorTableFormat getColorTableParameteri :: (GLint -> a) -> ColorTable -> ColorTablePName -> IO a getColorTableParameteri f ct p = with 0 $ \buf -> do glGetColorTableParameteriv (marshalColorTable ct) (marshalColorTablePName p) buf peek1 f buf -------------------------------------------------------------------------------- colorTableWidth :: ColorTable -> GettableStateVar GLsizei colorTableWidth ct = makeGettableStateVar $ getColorTableParameteri fromIntegral ct ColorTableWidth -------------------------------------------------------------------------------- colorTableRGBASizes :: ColorTable -> GettableStateVar (Color4 GLsizei) colorTableRGBASizes ct = makeGettableStateVar $ do r <- getColorTableParameteri fromIntegral ct ColorTableRedSize g <- getColorTableParameteri fromIntegral ct ColorTableGreenSize b <- getColorTableParameteri fromIntegral ct ColorTableBlueSize a <- getColorTableParameteri fromIntegral ct ColorTableAlphaSize return $ Color4 r g b a colorTableLuminanceSize :: ColorTable -> GettableStateVar GLsizei colorTableLuminanceSize ct = makeGettableStateVar $ getColorTableParameteri fromIntegral ct ColorTableLuminanceSize colorTableIntesitySize :: ColorTable -> GettableStateVar GLsizei colorTableIntesitySize ct = makeGettableStateVar $ getColorTableParameteri fromIntegral ct ColorTableIntensitySize OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PixelRectangles/Convolution.hs0000644000000000000000000002470212521420345025106 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles.Convolution -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to a part of section 3.6.1 (Pixel Storage Modes) of -- the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PixelRectangles.Convolution ( ConvolutionTarget(..), convolution, convolutionFilter1D, getConvolutionFilter1D, convolutionFilter2D, getConvolutionFilter2D, separableFilter2D, getSeparableFilter2D, copyConvolutionFilter1D, copyConvolutionFilter2D, convolutionWidth, convolutionHeight, maxConvolutionWidth, maxConvolutionHeight, ConvolutionBorderMode(..), convolutionBorderMode, convolutionFilterScale, convolutionFilterBias, ) where import Data.StateVar import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.CoordTrans import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.PixelData import Graphics.Rendering.OpenGL.GL.Texturing.PixelInternalFormat import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data ConvolutionTarget = Convolution1D | Convolution2D | Separable2D deriving ( Eq, Ord, Show ) marshalConvolutionTarget :: ConvolutionTarget -> GLenum marshalConvolutionTarget x = case x of Convolution1D -> gl_CONVOLUTION_1D Convolution2D -> gl_CONVOLUTION_2D Separable2D -> gl_SEPARABLE_2D convolutionTargetToEnableCap :: ConvolutionTarget -> EnableCap convolutionTargetToEnableCap x = case x of Convolution1D -> CapConvolution1D Convolution2D -> CapConvolution2D Separable2D -> CapSeparable2D -------------------------------------------------------------------------------- convolution :: ConvolutionTarget -> StateVar Capability convolution = makeCapability . convolutionTargetToEnableCap -------------------------------------------------------------------------------- convolutionFilter1D :: PixelInternalFormat -> GLsizei -> PixelData a -> IO () convolutionFilter1D int w pd = withPixelData pd $ glConvolutionFilter1D (marshalConvolutionTarget Convolution1D) (marshalPixelInternalFormat' int) w -------------------------------------------------------------------------------- getConvolutionFilter1D :: PixelData a -> IO () getConvolutionFilter1D = getConvolutionFilter Convolution1D getConvolutionFilter :: ConvolutionTarget -> PixelData a -> IO () getConvolutionFilter t pd = withPixelData pd $ glGetConvolutionFilter (marshalConvolutionTarget t) -------------------------------------------------------------------------------- convolutionFilter2D :: PixelInternalFormat -> Size -> PixelData a -> IO () convolutionFilter2D int (Size w h) pd = withPixelData pd $ glConvolutionFilter2D (marshalConvolutionTarget Convolution2D) (marshalPixelInternalFormat' int) w h -------------------------------------------------------------------------------- getConvolutionFilter2D :: PixelData a -> IO () getConvolutionFilter2D = getConvolutionFilter Convolution2D -------------------------------------------------------------------------------- separableFilter2D :: PixelInternalFormat -> Size -> PixelData a -> PixelData a -> IO () separableFilter2D int (Size w h) pdRow pdCol = withPixelData pdRow $ \f1 d1 p1 -> withPixelData pdCol $ \f2 d2 p2 -> if f1 == f2 && d1 == d2 then glSeparableFilter2D (marshalConvolutionTarget Separable2D) (marshalPixelInternalFormat' int) w h f1 d1 p1 p2 else recordInvalidValue -------------------------------------------------------------------------------- getSeparableFilter2D :: PixelData a -> PixelData a -> IO () getSeparableFilter2D pdRow pdCol = withPixelData pdRow $ \f1 d1 p1 -> withPixelData pdCol $ \f2 d2 p2 -> if f1 == f2 && d1 == d2 then glGetSeparableFilter (marshalConvolutionTarget Separable2D) f1 d1 p1 p2 nullPtr else recordInvalidValue -------------------------------------------------------------------------------- copyConvolutionFilter1D :: PixelInternalFormat -> Position -> GLsizei -> IO () copyConvolutionFilter1D int (Position x y) = glCopyConvolutionFilter1D (marshalConvolutionTarget Convolution1D) (marshalPixelInternalFormat' int) x y -------------------------------------------------------------------------------- copyConvolutionFilter2D :: PixelInternalFormat -> Position -> Size -> IO () copyConvolutionFilter2D int (Position x y) (Size w h) = glCopyConvolutionFilter2D (marshalConvolutionTarget Convolution2D) (marshalPixelInternalFormat' int) x y w h -------------------------------------------------------------------------------- data ConvolutionParameter = ConvolutionBorderColor | ConvolutionBorderMode | ConvolutionFilterScale | ConvolutionFilterBias | ConvolutionFormat | ConvolutionWidth | ConvolutionHeight | MaxConvolutionWidth | MaxConvolutionHeight deriving ( Eq, Ord, Show ) marshalConvolutionParameter :: ConvolutionParameter -> GLenum marshalConvolutionParameter x = case x of ConvolutionBorderColor -> gl_CONVOLUTION_BORDER_COLOR ConvolutionBorderMode -> gl_CONVOLUTION_BORDER_MODE ConvolutionFilterScale -> gl_CONVOLUTION_FILTER_SCALE ConvolutionFilterBias -> gl_CONVOLUTION_FILTER_BIAS ConvolutionFormat -> gl_CONVOLUTION_FORMAT ConvolutionWidth -> gl_CONVOLUTION_WIDTH ConvolutionHeight -> gl_CONVOLUTION_HEIGHT MaxConvolutionWidth -> gl_MAX_CONVOLUTION_WIDTH MaxConvolutionHeight -> gl_MAX_CONVOLUTION_HEIGHT -------------------------------------------------------------------------------- convolutionWidth :: ConvolutionTarget -> GettableStateVar GLsizei convolutionWidth t = convolutionParameteri t ConvolutionWidth convolutionHeight :: ConvolutionTarget -> GettableStateVar GLsizei convolutionHeight t = convolutionParameteri t ConvolutionHeight maxConvolutionWidth :: ConvolutionTarget -> GettableStateVar GLsizei maxConvolutionWidth t = convolutionParameteri t MaxConvolutionWidth maxConvolutionHeight :: ConvolutionTarget -> GettableStateVar GLsizei maxConvolutionHeight t = convolutionParameteri t MaxConvolutionHeight convolutionParameteri :: ConvolutionTarget -> ConvolutionParameter -> GettableStateVar GLsizei convolutionParameteri t p = makeGettableStateVar (getConvolutionParameteri fromIntegral t p) getConvolutionParameteri :: (GLint -> a) -> ConvolutionTarget -> ConvolutionParameter -> IO a getConvolutionParameteri f t p = with 0 $ \buf -> do glGetConvolutionParameteriv (marshalConvolutionTarget t) (marshalConvolutionParameter p) buf peek1 f buf -------------------------------------------------------------------------------- data ConvolutionBorderMode' = Reduce' | ConstantBorder' | ReplicateBorder' marshalConvolutionBorderMode' :: ConvolutionBorderMode' -> GLint marshalConvolutionBorderMode' x = fromIntegral $ case x of Reduce' -> gl_REDUCE ConstantBorder' -> gl_CONSTANT_BORDER ReplicateBorder' -> gl_REPLICATE_BORDER unmarshalConvolutionBorderMode' :: GLint -> ConvolutionBorderMode' unmarshalConvolutionBorderMode' x | y == gl_REDUCE = Reduce' | y == gl_CONSTANT_BORDER = ConstantBorder' | y == gl_REPLICATE_BORDER = ReplicateBorder' | otherwise = error ("unmarshalConvolutionBorderMode': illegal value " ++ show x) where y = fromIntegral x -------------------------------------------------------------------------------- data ConvolutionBorderMode = Reduce | ConstantBorder (Color4 GLfloat) | ReplicateBorder deriving ( Eq, Ord, Show ) -------------------------------------------------------------------------------- convolutionBorderMode :: ConvolutionTarget -> StateVar ConvolutionBorderMode convolutionBorderMode t = makeStateVar (getConvolutionBorderMode t) (setConvolutionBorderMode t) getConvolutionBorderMode :: ConvolutionTarget -> IO ConvolutionBorderMode getConvolutionBorderMode t = do mode <- getConvolutionParameteri unmarshalConvolutionBorderMode' t ConvolutionBorderMode case mode of Reduce' -> return Reduce ConstantBorder' -> do c <- getConvolutionParameterC4f t ConvolutionBorderColor return $ ConstantBorder c ReplicateBorder' -> return ReplicateBorder setConvolutionBorderMode :: ConvolutionTarget -> ConvolutionBorderMode -> IO () setConvolutionBorderMode t mode = do let setBM = setConvolutionParameteri marshalConvolutionBorderMode' t ConvolutionBorderMode case mode of Reduce -> setBM Reduce' ConstantBorder c -> do setBM ConstantBorder' convolutionParameterC4f t ConvolutionBorderColor c ReplicateBorder -> setBM ReplicateBorder' setConvolutionParameteri :: (a -> GLint) -> ConvolutionTarget -> ConvolutionParameter -> a -> IO () setConvolutionParameteri f t p x = glConvolutionParameteri (marshalConvolutionTarget t) (marshalConvolutionParameter p) (f x) -------------------------------------------------------------------------------- convolutionFilterScale :: ConvolutionTarget -> StateVar (Color4 GLfloat) convolutionFilterScale = convolutionC4f ConvolutionFilterScale convolutionFilterBias :: ConvolutionTarget -> StateVar (Color4 GLfloat) convolutionFilterBias = convolutionC4f ConvolutionFilterBias convolutionC4f :: ConvolutionParameter -> ConvolutionTarget -> StateVar (Color4 GLfloat) convolutionC4f p t = makeStateVar (getConvolutionParameterC4f t p) (convolutionParameterC4f t p) getConvolutionParameterC4f :: ConvolutionTarget -> ConvolutionParameter -> IO (Color4 GLfloat) getConvolutionParameterC4f t p = alloca $ \buf -> do glGetConvolutionParameterfv (marshalConvolutionTarget t) (marshalConvolutionParameter p) (castPtr buf) peek buf convolutionParameterC4f :: ConvolutionTarget -> ConvolutionParameter -> Color4 GLfloat -> IO () convolutionParameterC4f t p c = with c $ \ptr -> glConvolutionParameterfv (marshalConvolutionTarget t) (marshalConvolutionParameter p) (castPtr ptr) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PixelRectangles/Reset.hs0000644000000000000000000000163012521420345023644 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles.Reset -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for (un-)marshaling Reset. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PixelRectangles.Reset ( Reset(..), marshalReset ) where import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data Reset = NoReset | Reset deriving ( Eq, Ord, Show ) marshalReset :: Reset -> GLboolean marshalReset x = marshalGLboolean (x == Reset) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PixelRectangles/PixelStorage.hs0000644000000000000000000001011712521420345025170 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelStorage -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to section 3.6.1 (Pixel Storage Modes) of the -- OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelStorage ( PixelStoreDirection(..), swapBytes, lsbFirst, rowLength, skipRows, skipPixels, rowAlignment, imageHeight, skipImages ) where import Data.StateVar import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data PixelStoreDirection = Pack | Unpack deriving ( Eq, Ord, Show ) -------------------------------------------------------------------------------- data PixelStore = UnpackSwapBytes | UnpackLSBFirst | UnpackRowLength | UnpackSkipRows | UnpackSkipPixels | UnpackAlignment | PackSwapBytes | PackLSBFirst | PackRowLength | PackSkipRows | PackSkipPixels | PackAlignment | PackSkipImages | PackImageHeight | UnpackSkipImages | UnpackImageHeight marshalPixelStore :: PixelStore -> GLenum marshalPixelStore x = case x of UnpackSwapBytes -> gl_UNPACK_SWAP_BYTES UnpackLSBFirst -> gl_UNPACK_LSB_FIRST UnpackRowLength -> gl_UNPACK_ROW_LENGTH UnpackSkipRows -> gl_UNPACK_SKIP_ROWS UnpackSkipPixels -> gl_UNPACK_SKIP_PIXELS UnpackAlignment -> gl_UNPACK_ALIGNMENT PackSwapBytes -> gl_PACK_SWAP_BYTES PackLSBFirst -> gl_PACK_LSB_FIRST PackRowLength -> gl_PACK_ROW_LENGTH PackSkipRows -> gl_PACK_SKIP_ROWS PackSkipPixels -> gl_PACK_SKIP_PIXELS PackAlignment -> gl_PACK_ALIGNMENT PackSkipImages -> gl_PACK_SKIP_IMAGES PackImageHeight -> gl_PACK_IMAGE_HEIGHT UnpackSkipImages -> gl_UNPACK_SKIP_IMAGES UnpackImageHeight -> gl_UNPACK_IMAGE_HEIGHT -------------------------------------------------------------------------------- swapBytes :: PixelStoreDirection -> StateVar Bool swapBytes Pack = pixelStoreb GetPackSwapBytes PackSwapBytes swapBytes Unpack = pixelStoreb GetUnpackSwapBytes UnpackSwapBytes lsbFirst :: PixelStoreDirection -> StateVar Bool lsbFirst Pack = pixelStoreb GetPackLSBFirst PackLSBFirst lsbFirst Unpack = pixelStoreb GetUnpackLSBFirst UnpackLSBFirst rowLength :: PixelStoreDirection -> StateVar GLint rowLength Pack = pixelStorei GetPackRowLength PackRowLength rowLength Unpack = pixelStorei GetUnpackRowLength UnpackRowLength skipRows :: PixelStoreDirection -> StateVar GLint skipRows Pack = pixelStorei GetPackSkipRows PackSkipRows skipRows Unpack = pixelStorei GetUnpackSkipRows UnpackSkipRows skipPixels :: PixelStoreDirection -> StateVar GLint skipPixels Pack = pixelStorei GetPackSkipPixels PackSkipPixels skipPixels Unpack = pixelStorei GetUnpackSkipPixels UnpackSkipPixels rowAlignment :: PixelStoreDirection -> StateVar GLint rowAlignment Pack = pixelStorei GetPackAlignment PackAlignment rowAlignment Unpack = pixelStorei GetUnpackAlignment UnpackAlignment imageHeight :: PixelStoreDirection -> StateVar GLint imageHeight Pack = pixelStorei GetPackImageHeight PackImageHeight imageHeight Unpack = pixelStorei GetUnpackImageHeight UnpackImageHeight skipImages :: PixelStoreDirection -> StateVar GLint skipImages Pack = pixelStorei GetPackSkipImages PackSkipImages skipImages Unpack = pixelStorei GetUnpackSkipImages UnpackSkipImages -------------------------------------------------------------------------------- pixelStoreb :: PName1I -> PixelStore -> StateVar Bool pixelStoreb pn ps = makeStateVar (getBoolean1 unmarshalGLboolean pn) (glPixelStorei (marshalPixelStore ps) . marshalGLboolean) pixelStorei :: PName1I -> PixelStore -> StateVar GLint pixelStorei pn ps = makeStateVar (getInteger1 id pn) (glPixelStorei (marshalPixelStore ps)) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PixelRectangles/PixelMap.hs0000644000000000000000000001563312521420345024311 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelMap -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to a part of section 3.6.1 (Pixel Storage Modes) of -- the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- {-# LANGUAGE TypeSynonymInstances #-} module Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelMap ( PixelMapTarget(..), PixelMapComponent, PixelMap(..), GLpixelmap, maxPixelMapTable, pixelMap, pixelMapIToRGBA, pixelMapRGBAToRGBA, ) where import Data.List import Data.StateVar import Foreign.ForeignPtr import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data PixelMapTarget = IToI | SToS | IToR | IToG | IToB | IToA | RToR | GToG | BToB | AToA deriving ( Eq, Ord, Show ) marshalPixelMapTarget :: PixelMapTarget -> GLenum marshalPixelMapTarget x = case x of IToI -> gl_PIXEL_MAP_I_TO_I SToS -> gl_PIXEL_MAP_S_TO_S IToR -> gl_PIXEL_MAP_I_TO_R IToG -> gl_PIXEL_MAP_I_TO_G IToB -> gl_PIXEL_MAP_I_TO_B IToA -> gl_PIXEL_MAP_I_TO_A RToR -> gl_PIXEL_MAP_R_TO_R GToG -> gl_PIXEL_MAP_G_TO_G BToB -> gl_PIXEL_MAP_B_TO_B AToA -> gl_PIXEL_MAP_A_TO_A pixelMapTargetToGetPName :: PixelMapTarget -> PName1I pixelMapTargetToGetPName x = case x of IToI -> GetPixelMapIToISize SToS -> GetPixelMapSToSSize IToR -> GetPixelMapIToRSize IToG -> GetPixelMapIToGSize IToB -> GetPixelMapIToBSize IToA -> GetPixelMapIToASize RToR -> GetPixelMapRToRSize GToG -> GetPixelMapGToGSize BToB -> GetPixelMapBToBSize AToA -> GetPixelMapAToASize -------------------------------------------------------------------------------- maxPixelMapTable :: GettableStateVar GLsizei maxPixelMapTable = makeGettableStateVar $ getSizei1 id GetMaxPixelMapTable -------------------------------------------------------------------------------- class Storable c => PixelMapComponent c where getPixelMapv :: GLenum -> Ptr c -> IO () pixelMapv :: GLenum -> GLsizei -> Ptr c -> IO () instance PixelMapComponent GLushort where getPixelMapv = glGetPixelMapusv pixelMapv = glPixelMapusv instance PixelMapComponent GLuint where getPixelMapv = glGetPixelMapuiv pixelMapv = glPixelMapuiv instance PixelMapComponent GLfloat where getPixelMapv = glGetPixelMapfv pixelMapv = glPixelMapfv -------------------------------------------------------------------------------- class PixelMap m where withNewPixelMap :: PixelMapComponent c => Int -> (Ptr c -> IO ()) -> IO (m c) withPixelMap :: PixelMapComponent c => m c -> (Int -> Ptr c -> IO a) -> IO a newPixelMap :: PixelMapComponent c => [c] -> IO (m c) getPixelMapComponents :: PixelMapComponent c => m c -> IO [c] withNewPixelMap size act = allocaArray size $ \p -> do act p components <- peekArray size p newPixelMap components withPixelMap m act = do components <- getPixelMapComponents m withArrayLen components act newPixelMap elements = withNewPixelMap (length elements) $ flip pokeArray elements getPixelMapComponents m = withPixelMap m peekArray -------------------------------------------------------------------------------- data GLpixelmap a = GLpixelmap Int (ForeignPtr a) deriving ( Eq, Ord, Show ) instance PixelMap GLpixelmap where withNewPixelMap size f = do fp <- mallocForeignPtrArray size withForeignPtr fp f return $ GLpixelmap size fp withPixelMap (GLpixelmap size fp) f = withForeignPtr fp (f size) -------------------------------------------------------------------------------- pixelMap :: (PixelMap m, PixelMapComponent c) => PixelMapTarget -> StateVar (m c) pixelMap pm = makeStateVar (do size <- pixelMapSize pm withNewPixelMap size $ getPixelMapv (marshalPixelMapTarget pm)) (\theMap -> withPixelMap theMap $ pixelMapv (marshalPixelMapTarget pm) . fromIntegral) pixelMapSize :: PixelMapTarget -> IO Int pixelMapSize = getInteger1 fromIntegral . pixelMapTargetToGetPName -------------------------------------------------------------------------------- -- | Convenience state variable pixelMapIToRGBA :: PixelMapComponent c => StateVar [Color4 c] pixelMapIToRGBA = pixelMapXToY (IToR, IToG, IToB, IToA) -- | Convenience state variable pixelMapRGBAToRGBA :: PixelMapComponent c => StateVar [Color4 c] pixelMapRGBAToRGBA = pixelMapXToY (RToR, GToG, BToB, AToA) pixelMapXToY :: PixelMapComponent c => (PixelMapTarget, PixelMapTarget, PixelMapTarget, PixelMapTarget) -> StateVar [Color4 c] pixelMapXToY targets = makeStateVar (getPixelMapXToY targets) (setPixelMapXToY targets) getPixelMapXToY :: PixelMapComponent c => (PixelMapTarget, PixelMapTarget, PixelMapTarget, PixelMapTarget) -> IO [Color4 c] getPixelMapXToY (toR, toG, toB, toA) = do withPixelMapFor toR $ \sizeR bufR -> withPixelMapFor toG $ \sizeG bufG -> withPixelMapFor toB $ \sizeB bufB -> withPixelMapFor toA $ \sizeA bufA -> do let maxSize = sizeR `max` sizeG `max` sizeB `max` sizeA r <- sample sizeR bufR maxSize g <- sample sizeR bufG maxSize b <- sample sizeR bufB maxSize a <- sample sizeR bufA maxSize return $ zipWith4 Color4 r g b a withPixelMapFor :: PixelMapComponent c => PixelMapTarget -> (Int -> Ptr c -> IO a) -> IO a withPixelMapFor target f = do theMap <- get (pixelMap target) withGLpixelmap theMap f withGLpixelmap :: PixelMapComponent c => GLpixelmap c -> (Int -> Ptr c -> IO a) -> IO a withGLpixelmap = withPixelMap sample :: Storable a => Int -> Ptr a -> Int -> IO [a] sample len ptr newLen = f (fromIntegral (newLen - 1)) [] where scale :: Float scale = fromIntegral len / fromIntegral newLen f l acc | l < 0 = return acc | otherwise = do e <- peekElemOff ptr (truncate (l * scale)) f (l - 1) (e : acc) setPixelMapXToY :: PixelMapComponent c => (PixelMapTarget, PixelMapTarget, PixelMapTarget, PixelMapTarget) -> [Color4 c] -> IO () setPixelMapXToY (toR, toG, toB, toA) colors = do (pixelMap toR $=) =<< newGLpixelmap [ r | Color4 r _ _ _ <- colors ] (pixelMap toG $=) =<< newGLpixelmap [ g | Color4 _ g _ _ <- colors ] (pixelMap toB $=) =<< newGLpixelmap [ b | Color4 _ _ b _ <- colors ] (pixelMap toA $=) =<< newGLpixelmap [ a | Color4 _ _ _ a <- colors ] newGLpixelmap :: PixelMapComponent c => [c] -> IO (GLpixelmap c) newGLpixelmap = newPixelMap OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PixelRectangles/Rasterization.hs0000644000000000000000000000254312521420345025424 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles.Rasterization -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to a part of section 3.6.4 (Rasterization of Pixel -- Rectangles) of the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PixelRectangles.Rasterization ( PixelData(..), PixelFormat(..), drawPixels, pixelZoom ) where import Control.Monad import Data.StateVar import Graphics.Rendering.OpenGL.GL.CoordTrans import Graphics.Rendering.OpenGL.GL.PixelData import Graphics.Rendering.OpenGL.GL.PixelFormat import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- drawPixels :: Size -> PixelData a -> IO () drawPixels (Size w h) pd = withPixelData pd $ glDrawPixels w h -------------------------------------------------------------------------------- pixelZoom :: StateVar (GLfloat, GLfloat) pixelZoom = makeStateVar (liftM2 (,) (getFloat1 id GetZoomX) (getFloat1 id GetZoomY)) (uncurry glPixelZoom) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/PixelRectangles/Minmax.hs0000644000000000000000000000554412521420345024023 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles.Minmax -- Copyright : (c) Sven Panne 2002-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This module corresponds to a part of section 3.6.1 (Pixel Storage Modes) of -- the OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.PixelRectangles.Minmax ( minmax, getMinmax, resetMinmax ) where import Data.StateVar import Foreign.Marshal.Utils import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GL.PixelData import Graphics.Rendering.OpenGL.GL.PixelRectangles.Reset import Graphics.Rendering.OpenGL.GL.PixelRectangles.Sink import Graphics.Rendering.OpenGL.GL.Texturing.PixelInternalFormat import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data MinmaxTarget = Minmax marshalMinmaxTarget :: MinmaxTarget -> GLenum marshalMinmaxTarget x = case x of Minmax -> gl_MINMAX -------------------------------------------------------------------------------- minmax :: StateVar (Maybe (PixelInternalFormat, Sink)) minmax = makeStateVarMaybe (return CapMinmax) getMinmax' setMinmax getMinmax' :: IO (PixelInternalFormat, Sink) getMinmax' = do f <- getMinmaxParameteri unmarshalPixelInternalFormat MinmaxFormat s <- getMinmaxParameteri unmarshalSink MinmaxSink return (f, s) setMinmax :: (PixelInternalFormat, Sink) -> IO () setMinmax (int, sink) = glMinmax (marshalMinmaxTarget Minmax) (marshalPixelInternalFormat' int) (marshalSink sink) -------------------------------------------------------------------------------- getMinmax :: Reset -> PixelData a -> IO () getMinmax reset pd = withPixelData pd $ glGetMinmax (marshalMinmaxTarget Minmax) (marshalReset reset) -------------------------------------------------------------------------------- resetMinmax :: IO () resetMinmax = glResetMinmax (marshalMinmaxTarget Minmax) -------------------------------------------------------------------------------- data GetMinmaxParameterPName = MinmaxFormat | MinmaxSink marshalGetMinmaxParameterPName :: GetMinmaxParameterPName -> GLenum marshalGetMinmaxParameterPName x = case x of MinmaxFormat -> gl_MINMAX_FORMAT MinmaxSink -> gl_MINMAX_SINK -------------------------------------------------------------------------------- getMinmaxParameteri :: (GLint -> a) -> GetMinmaxParameterPName -> IO a getMinmaxParameteri f p = with 0 $ \buf -> do glGetMinmaxParameteriv (marshalMinmaxTarget Minmax) (marshalGetMinmaxParameterPName p) buf peek1 f buf OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/QueryUtils/0000755000000000000000000000000012521420345021263 5ustar0000000000000000OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/QueryUtils/VertexAttrib.hs0000644000000000000000000001035412521420345024245 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.QueryUtils.VertexAttrib -- Copyright : (c) Sven Panne, Lars Corbijn 2009-2013 -- License : BSD3 -- -- Maintainer : Sven Panne , Jason Dagit -- Stability : stable -- Portability : portable -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.QueryUtils.VertexAttrib ( AttribLocation(..), GetVertexAttribPName(..), getVertexAttribInteger1, getVertexAttribEnum1, getVertexAttribBoolean1, getVertexAttribFloat4, getVertexAttribIInteger4, getVertexAttribIuInteger4, GetVertexAttribPointerPName(..), getVertexAttribPointer ) where import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.Storable import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- newtype AttribLocation = AttribLocation GLuint deriving ( Eq, Ord, Show ) -------------------------------------------------------------------------------- data GetVertexAttribPName = GetVertexAttribArrayEnabled | GetVertexAttribArraySize | GetVertexAttribArrayStride | GetVertexAttribArrayType | GetVertexAttribArrayNormalized | GetCurrentVertexAttrib | GetVertexAttribArrayBufferBinding | GetVertexAttribArrayInteger marshalGetVertexAttribPName :: GetVertexAttribPName -> GLenum marshalGetVertexAttribPName x = case x of GetVertexAttribArrayEnabled -> gl_VERTEX_ATTRIB_ARRAY_ENABLED GetVertexAttribArraySize -> gl_VERTEX_ATTRIB_ARRAY_SIZE GetVertexAttribArrayStride -> gl_VERTEX_ATTRIB_ARRAY_STRIDE GetVertexAttribArrayType -> gl_VERTEX_ATTRIB_ARRAY_TYPE GetVertexAttribArrayNormalized -> gl_VERTEX_ATTRIB_ARRAY_NORMALIZED GetCurrentVertexAttrib -> gl_CURRENT_VERTEX_ATTRIB GetVertexAttribArrayBufferBinding -> gl_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING GetVertexAttribArrayInteger -> gl_VERTEX_ATTRIB_ARRAY_INTEGER -------------------------------------------------------------------------------- getVertexAttribInteger1 :: (GLint -> b) -> AttribLocation -> GetVertexAttribPName -> IO b getVertexAttribInteger1 f (AttribLocation location) n = with 0 $ \buf -> do glGetVertexAttribiv location (marshalGetVertexAttribPName n) buf peek1 f buf getVertexAttribEnum1 :: (GLenum -> b) -> AttribLocation -> GetVertexAttribPName -> IO b getVertexAttribEnum1 f = getVertexAttribInteger1 (f . fromIntegral) getVertexAttribBoolean1 :: (GLboolean -> b) -> AttribLocation -> GetVertexAttribPName -> IO b getVertexAttribBoolean1 f = getVertexAttribInteger1 (f . fromIntegral) getVertexAttribFloat4 :: (GLfloat -> GLfloat -> GLfloat -> GLfloat -> b) -> AttribLocation -> GetVertexAttribPName -> IO b getVertexAttribFloat4 f (AttribLocation location) n = alloca $ \buf -> do glGetVertexAttribfv location (marshalGetVertexAttribPName n) buf peek4 f buf getVertexAttribIInteger4 :: (GLint -> GLint -> GLint -> GLint -> b) -> AttribLocation -> GetVertexAttribPName -> IO b getVertexAttribIInteger4 f (AttribLocation location) n = alloca $ \buf -> do glGetVertexAttribIiv location (marshalGetVertexAttribPName n) buf peek4 f buf getVertexAttribIuInteger4 :: (GLuint -> GLuint -> GLuint -> GLuint -> b) -> AttribLocation -> GetVertexAttribPName -> IO b getVertexAttribIuInteger4 f (AttribLocation location) n = alloca $ \buf -> do glGetVertexAttribIuiv location (marshalGetVertexAttribPName n) buf peek4 f buf -------------------------------------------------------------------------------- data GetVertexAttribPointerPName = VertexAttribArrayPointer marshalGetVertexAttribPointerPName :: GetVertexAttribPointerPName -> GLenum marshalGetVertexAttribPointerPName x = case x of VertexAttribArrayPointer -> gl_VERTEX_ATTRIB_ARRAY_POINTER -------------------------------------------------------------------------------- getVertexAttribPointer :: AttribLocation -> GetVertexAttribPointerPName -> IO (Ptr a) getVertexAttribPointer (AttribLocation location) n = with nullPtr $ \buf -> do glGetVertexAttribPointerv location (marshalGetVertexAttribPointerPName n) buf peek buf OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/QueryUtils/PName.hs0000644000000000000000000014406512521420345022631 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.QueryUtils.PName -- Copyright : (c) Sven Panne 2002-2009, Lars Corbijn 2013 -- License : BSD3 -- -- Maintainer : Sven Panne , Jason Dagit -- Stability : stable -- Portability : portable -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.QueryUtils.PName ( GetPName(..), GetPName1I(..), GetPName1F(..), GetIPName1I(..), GetPName2I(..), GetPName2F(..), GetPName3I(..), GetPName3F(..), GetPName4I(..), GetPName4F(..), GetIPName4I(..), GetPNameNI(..), PName1I(..), PName1F(..), IPName1I(..), PName2I(..), PName2F(..), PName3F(..), PName4I(..), PName4F(..), PName4ISemiIndexed(..), PNameNI(..), GetPNameMatrix(..), PNameMatrix(..), clipPlaneIndexToEnum, GetPointervPName(..), getPointer ) where import Foreign.Marshal.Alloc ( alloca ) import Foreign.Marshal.Array ( allocaArray, peekArray ) import Foreign.Marshal.Utils ( with ) import Foreign.Ptr ( Ptr, nullPtr, castPtr ) import Foreign.Storable ( Storable(peek) ) import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw ----------------------------------------------------------------------------- class GetPName p where marshalGetPName :: p -> Maybe GLenum ----------------------------------------------------------------------------- getBooleanv :: GetPName p => p-> Ptr GLboolean -> IO () getBooleanv = makeGetter glGetBooleanv getIntegerv :: GetPName p => p -> Ptr GLint -> IO () getIntegerv = makeGetter glGetIntegerv getInteger64v :: GetPName p => p -> Ptr GLint64 -> IO () getInteger64v = makeGetter glGetInteger64v getFloatv :: GetPName p => p -> Ptr GLfloat -> IO () getFloatv = makeGetter glGetFloatv getDoublev :: GetPName p => p -> Ptr GLdouble -> IO () getDoublev = makeGetter glGetDoublev ----------------------------------------------------------------------------- getBooleaniv :: GetPName p => p -> GLuint -> Ptr GLboolean -> IO () getBooleaniv p i = makeGetter (\e -> glGetBooleani_v e i) p getIntegeriv :: GetPName p => p -> GLuint -> Ptr GLint -> IO () getIntegeriv p i = makeGetter (\e -> glGetIntegeri_v e i) p getInteger64iv :: GetPName p => p -> GLuint -> Ptr GLint64 -> IO () getInteger64iv p i = makeGetter (\e -> glGetInteger64i_v e i) p ----------------------------------------------------------------------------- {-# INLINE makeGetter #-} makeGetter :: GetPName p => (GLenum -> Ptr a -> IO ()) -> p -> Ptr a -> IO () makeGetter f = maybe (const recordInvalidEnum) f . marshalGetPName ----------------------------------------------------------------------------- class GetPName p => GetPName1I p where getBoolean1 :: (GLboolean -> a) -> p -> IO a getBoolean1 = get1 getBooleanv getInteger1 :: (GLint -> a) -> p -> IO a getInteger1 = get1 getIntegerv getEnum1 :: (GLenum -> a) -> p -> IO a getEnum1 = get1 getIntegerv getSizei1 :: (GLsizei -> a) -> p -> IO a getSizei1 = get1 getIntegerv getInteger64 :: (GLint64 -> a) -> p -> IO a getInteger64 = get1 getInteger64v class GetPName p => GetPName1F p where getFloat1 :: (GLfloat -> a) -> p -> IO a getFloat1 = get1 getFloatv getClampf1 :: (GLclampf -> a) -> p -> IO a getClampf1 = get1 getFloatv getDouble1 :: (GLdouble -> a) -> p -> IO a getDouble1 = get1 getDoublev getClampd1 :: (GLclampd -> a) -> p -> IO a getClampd1 = get1 getDoublev -- | Helper function for the get*1 functions. get1 :: (Storable b, Storable c, GetPName p) => (p -> Ptr c -> IO ()) -> (b -> a) -- ^ Conversion from the casted value to the return value -> p -> IO a get1 g f n = alloca $ \buf -> do g n buf peek1 f (castPtr buf) class GetPName p => GetIPName1I p where getBoolean1i :: (GLboolean -> a) -> p -> GLuint -> IO a getBoolean1i = get1i getBooleaniv getInteger1i :: (GLint -> a) -> p -> GLuint -> IO a getInteger1i = get1i getIntegeriv getEnum1i :: (GLenum -> a) -> p -> GLuint -> IO a getEnum1i = get1i getIntegeriv getSizei1i :: (GLsizei -> a) -> p -> GLuint -> IO a getSizei1i = get1i getIntegeriv getInteger641i :: (GLint64 -> a) -> p -> GLuint -> IO a getInteger641i = get1i getInteger64iv -- Indexed helper get1i :: (Storable b, Storable c, GetPName p) => (p -> GLuint -> Ptr c -> IO ()) -> (b -> a) -- ^ Conversion from the casted value to the return value -> p -> GLuint -> IO a get1i g f n i = alloca $ \buf -> do g n i buf peek1 f (castPtr buf) ----------------------------------------------------------------------------- class GetPName p => GetPName2I p where getBoolean2 :: (GLboolean -> GLboolean -> a) -> p -> IO a getBoolean2 = get2 getBooleanv getInteger2 :: (GLint -> GLint -> a) -> p -> IO a getInteger2 = get2 getIntegerv getEnum2 :: (GLenum -> GLenum -> a) -> p -> IO a getEnum2 = get2 getIntegerv getSizei2 :: (GLsizei -> GLsizei -> a) -> p -> IO a getSizei2 = get2 getIntegerv class GetPName p => GetPName2F p where getFloat2 :: (GLfloat -> GLfloat -> a) -> p -> IO a getFloat2 = get2 getFloatv getClampf2 :: (GLclampf -> GLclampf -> a) -> p -> IO a getClampf2 = get2 getFloatv getDouble2 :: (GLdouble -> GLdouble -> a) -> p -> IO a getDouble2 = get2 getDoublev getClampd2 :: (GLclampd -> GLclampd -> a) -> p -> IO a getClampd2 = get2 getDoublev -- | Helper function for the get*2 functions. get2 :: (Storable b, Storable c, GetPName p) => (p -> Ptr c -> IO ()) -> (b -> b -> a) -- ^ Conversion from the casted value to the return value -> p -> IO a get2 g f n = allocaArray 2 $ \buf -> do g n buf peek2 f (castPtr buf) ----------------------------------------------------------------------------- class GetPName p => GetPName3I p where getBoolean3 :: (GLboolean -> GLboolean -> GLboolean -> a) -> p -> IO a getBoolean3 = get3 getBooleanv getInteger3 :: (GLint -> GLint -> GLint -> a) -> p -> IO a getInteger3 = get3 getIntegerv getEnum3 :: (GLenum -> GLenum -> GLenum -> a) -> p -> IO a getEnum3 = get3 getIntegerv getSizei3 :: (GLsizei -> GLsizei -> GLsizei -> a) -> p -> IO a getSizei3 = get3 getIntegerv class GetPName p => GetPName3F p where getFloat3 :: (GLfloat -> GLfloat -> GLfloat -> a) -> p -> IO a getFloat3 = get3 getFloatv getClampf3 :: (GLclampf -> GLclampf -> GLclampf -> a) -> p -> IO a getClampf3 = get3 getFloatv getDouble3 :: (GLdouble -> GLdouble -> GLdouble -> a) -> p -> IO a getDouble3 = get3 getDoublev getClampd3 :: (GLclampd -> GLclampd -> GLclampd -> a) -> p -> IO a getClampd3 = get3 getDoublev -- | Helper function for the get*3 functions. get3 :: (Storable b, Storable c, GetPName p) => (p -> Ptr c -> IO ()) -> (b -> b -> b -> a) -- ^ Conversion from the casted value to the return value -> p -> IO a get3 g f n = allocaArray 3 $ \buf -> do g n buf peek3 f (castPtr buf) ----------------------------------------------------------------------------- class GetPName p => GetPName4I p where getBoolean4 :: (GLboolean -> GLboolean -> GLboolean -> GLboolean -> a) -> p -> IO a getBoolean4 = get4 getBooleanv getInteger4 :: (GLint -> GLint -> GLint -> GLint -> a) -> p -> IO a getInteger4 = get4 getIntegerv getEnum4 :: (GLenum -> GLenum -> GLenum -> GLenum -> a) -> p -> IO a getEnum4 = get4 getIntegerv getSizei4 :: (GLsizei -> GLsizei -> GLsizei -> GLsizei -> a) -> p -> IO a getSizei4 = get4 getIntegerv class GetPName p => GetPName4F p where getFloat4 :: (GLfloat -> GLfloat -> GLfloat -> GLfloat -> a) -> p -> IO a getFloat4 = get4 getFloatv getClampf4 :: (GLclampf -> GLclampf -> GLclampf -> GLclampf -> a) -> p -> IO a getClampf4 = get4 getFloatv getDouble4 :: (GLdouble -> GLdouble -> GLdouble -> GLdouble -> a) -> p -> IO a getDouble4 = get4 getDoublev getClampd4 :: (GLclampd -> GLclampd -> GLclampd -> GLclampd -> a) -> p -> IO a getClampd4 = get4 getDoublev -- | Helper function for the get*4 functions. get4 :: (Storable b, Storable c, GetPName p) => (p -> Ptr c -> IO ()) -> (b -> b -> b -> b -> a) -- ^ Conversion from the casted value to the return value -> p -> IO a get4 g f n = allocaArray 4 $ \buf -> do g n buf peek4 f (castPtr buf) class GetPName p => GetIPName4I p where getBoolean4i :: (GLboolean -> GLboolean -> GLboolean -> GLboolean -> a) -> p -> GLuint -> IO a getBoolean4i = get4i getBooleaniv getInteger4i :: (GLint -> GLint -> GLint -> GLint -> a) -> p -> GLuint -> IO a getInteger4i = get4i getIntegeriv getEnum4i :: (GLenum -> GLenum -> GLenum -> GLenum -> a) -> p -> GLuint -> IO a getEnum4i = get4i getIntegeriv getSizei4i :: (GLsizei -> GLsizei -> GLsizei -> GLsizei -> a) -> p -> GLuint -> IO a getSizei4i = get4i getIntegeriv -- | Helper function for the get*4 functions. get4i :: (Storable b, Storable c, GetPName p) => (p -> GLuint -> Ptr c -> IO ()) -> (b -> b -> b -> b -> a) -- ^ Conversion from the casted value to the return value -> p -> GLuint -> IO a get4i g f n i = allocaArray 4 $ \buf -> do g n i buf peek4 f (castPtr buf) class GetPName p => GetPNameNI p where getEnumN :: (GLenum -> a) -> p -> Int -> IO [a] getEnumN f p n = allocaArray n $ \buf -> do getIntegerv p buf (map (f . fromIntegral)) `fmap` peekArray n buf ----------------------------------------------------------------------------- class GetPName p => GetPNameMatrix p where getMatrixf :: p -> Ptr GLfloat -> IO () getMatrixf = getFloatv getMatrixd :: p -> Ptr GLdouble -> IO () getMatrixd = getDoublev ----------------------------------------------------------------------------- data PName1I = GetEdgeFlag -- ^ bool | GetRGBAMode -- ^ enum | GetCurrentIndex -- ^ int | GetMaxTextureUnits -- ^ enum -- displaylist | GetListIndex -- ^ enum | GetListMode -- ^ enum | GetMaxListNesting -- ^ sizei | GetListBase -- ^ enum -- rendermode | GetRenderMode -- ^ enum -- framebufferbinding | GetDrawFramebufferBinding -- ^ int | GetReadFramebufferBinding -- ^ int | GetFramebufferBinding -- ^ int -- renderbufferbinding | GetRenderbufferBinding -- ^ int -- hint | GetPerspectiveCorrectionHint -- ^ enum | GetPointSmoothHint -- ^ enum | GetLineSmoothHint -- ^ enum | GetPolygonSmoothHint -- ^ enum | GetFogHint -- ^ enum | GetGenerateMipmapHint -- ^ enum | GetTextureCompressionHint -- ^ enum | GetPackCMYKHint -- ^ enum | GetUnpackCMYKHint -- ^ enum -- vertexarray | GetVertexArrayBinding -- ^ int -- Selction? | GetMaxNameStackDepth -- ^ int | GetNameStackDepth -- ^ int -- ContextProfile | GetContextProfileMask -- ^ enum -- pixelStorage | GetPackSwapBytes -- ^ bool | GetUnpackSwapBytes -- ^ bool | GetPackLSBFirst -- ^ bool | GetUnpackLSBFirst -- ^ bool | GetPackRowLength -- ^ int | GetUnpackRowLength -- ^ int | GetPackSkipRows -- ^ int | GetUnpackSkipRows -- ^ int | GetPackSkipPixels -- ^ int | GetUnpackSkipPixels -- ^ int | GetPackAlignment -- ^ int | GetUnpackAlignment -- ^ int | GetPackImageHeight -- ^ int | GetUnpackImageHeight -- ^ int | GetPackSkipImages -- ^ int | GetUnpackSkipImages -- ^ int -- pixel map | GetPixelMapIToISize -- ^ int | GetPixelMapSToSSize -- ^ int | GetPixelMapIToRSize -- ^ int | GetPixelMapIToGSize -- ^ int | GetPixelMapIToBSize -- ^ int | GetPixelMapIToASize -- ^ int | GetPixelMapRToRSize -- ^ int | GetPixelMapGToGSize -- ^ int | GetPixelMapBToBSize -- ^ int | GetPixelMapAToASize -- ^ int | GetMaxPixelMapTable -- ^ sizei -- shader limits | GetMaxVertexTextureImageUnits -- ^ sizei | GetMaxTextureImageUnits -- ^ sizei | GetMaxCombinedTextureImageUnits -- ^ sizei | GetMaxTextureCoords -- ^ sizei | GetMaxVertexUniformComponents -- ^ sizei | GetMaxFragmentUniformComponents -- ^ sizei | GetMaxVertexAttribs -- ^ sizei | GetMaxVaryingFloats -- ^ sizei -- tessellation | GetPatchVertices -- ^ sizei | GetMaxPatchVertices -- ^ sizei | GetMaxTessGenLevel -- ^ sizei -- coordtrans | GetMatrixMode -- ^ enum | GetModelviewStackDepth -- ^ sizei | GetProjectionStackDepth -- ^ sizei | GetTextureStackDepth -- ^ sizei | GetColorMatrixStackDepth -- ^ sizei | GetMaxModelviewStackDepth -- ^ sizei | GetMaxProjectionStackDepth -- ^ sizei | GetMaxTextureStackDepth -- ^ sizei | GetMaxColorMatrixStackDepth -- ^ sizei | GetMaxMatrixPaletteStackDepth -- ^ sizei | GetCurrentMatrixStackDepth -- ^ sizei | GetActiveTexture -- ^ enum -- VertexArrays | GetVertexArraySize -- ^ int | GetVertexArrayType -- ^ enum | GetVertexArrayStride -- ^ int | GetNormalArrayType -- ^ enum | GetNormalArrayStride -- ^ int | GetColorArraySize -- ^ int | GetColorArrayType -- ^ enum | GetColorArrayStride -- ^ int | GetIndexArrayType -- ^ enum | GetIndexArrayStride -- ^ int | GetTextureCoordArraySize -- ^ int | GetTextureCoordArrayType -- ^ enum | GetTextureCoordArrayStride -- ^ int | GetEdgeFlagArrayStride -- ^ int | GetFogCoordArrayType -- ^ enum | GetFogCoordArrayStride -- ^ int | GetSecondaryColorArraySize -- ^ int | GetSecondaryColorArrayType -- ^ enum | GetSecondaryColorArrayStride -- ^ int | GetArrayElementLockCount -- ^ int | GetArrayElementLockFirst -- ^ int | GetClientActiveTexture -- ^ enum | GetMaxElementsVertices -- ^ sizei | GetMaxElementsIndices -- ^ sizei | GetPrimitiveRestartIndex -- ^ int | GetPrimitiveRestartNV -- ^ bool | GetPrimitiveRestartIndexNV -- ^ int -- bufferObjects | GetArrayBufferBinding -- ^ int | GetAtomicCounterBufferBinding -- ^ int | GetCopyReadBufferBinding -- ^ int | GetCopyWriteBufferBinding -- ^ int | GetDispatchIndirectBufferBinding -- ^ int | GetDrawIndirectBufferBinding -- ^ int | GetElementArrayBufferBinding -- ^ int | GetPixelPackBufferBinding -- ^ int | GetPixelUnpackBufferBinding -- ^ int | GetQueryBufferBinding -- ^ int | GetShaderStorageBufferBinding -- ^ int | GetTransformFeedbackBufferBinding -- ^ int | GetUniformBufferBinding -- ^ int | GetVertexArrayBufferBinding -- ^ int | GetNormalArrayBufferBinding -- ^ int | GetColorArrayBufferBinding -- ^ int | GetIndexArrayBufferBinding -- ^ int | GetTextureCoordArrayBufferBinding -- ^ int | GetEdgeFlagArrayBufferBinding -- ^ int | GetSecondaryColorArrayBufferBinding -- ^ int | GetFogCoordArrayBufferBinding -- ^ int -- clipping | GetMaxClipPlanes -- ^ sizei -- Colors | GetMaxLights -- ^ sizei | GetFrontFace -- ^ enum | GetLightModelLocalViewer -- ^ bool | GetLightModelTwoSide -- ^ bool | GetLightModelColorControl -- ^ enum | GetColorMaterialFace -- ^ enum | GetColorMaterialParameter -- ^ enum | GetShadeModel -- ^ enum | GetFragmentColorClamp -- ^ enum | GetVertexColorClamp -- ^ enum | GetReadColorClamp -- ^ enum -- Evaluators | GetMaxEvalOrder -- ^ int | GetMap1GridSegments -- ^ int -- Fog | GetFogMode -- ^ int => enum | GetFogIndex -- ^ int | GetFogCoordSrc -- ^ int | GetFogDistanceMode -- ^ int => enum -- Framebuffer | GetAuxBuffers -- ^ sizei | GetDoublebuffer -- ^ bool | GetStereo -- ^ bool | GetRedBits -- ^ sizei | GetGreenBits -- ^ sizei | GetBlueBits -- ^ sizei | GetAlphaBits -- ^ sizei | GetStencilBits -- ^ sizei | GetDepthBits -- ^ sizei | GetAccumRedBits -- ^ sizei | GetAccumGreenBits -- ^ sizei | GetAccumBlueBits -- ^ sizei | GetAccumAlphaBits -- ^ sizei | GetDrawBuffer -- ^ enum | GetDrawBufferN GLsizei -- enum | GetMaxDrawBuffers -- ^ sizei | GetIndexWritemask -- ^ int | GetDepthWritemask -- ^ bool | GetStencilWritemask -- ^ bool | GetStencilClearValue -- ^ int -- Program | GetCurrentProgram -- ^ int -- Transformfeedback | GetMaxTransformFeedbackSeparateAttribs -- ^ int | GetMaxTransformFeedbackInterleavedComponents -- ^ int | GetMaxTransformFeedbackSeparateComponents -- ^ int | GetCurrentRasterIndex -- ^ int | GetCurrentRasterPositionValid -- ^ bool -- LineSegment | GetLineStippleRepeat -- ^ int | GetLineStipplePattern -- ^ int -- PerFragment | GetSampleCoverageInvert -- ^ bool | GetAlphaTestFunc -- ^ enum | GetStencilFunc -- ^ enum | GetStencilValueMask -- ^ int | GetStencilRef -- ^ int | GetStencilFail -- ^ enum | GetStencilPassDepthFail -- ^ enum | GetStencilPassDepthPass -- ^ enum | GetActiveStencilFace -- ^ enum | GetLogicOpMode -- ^ enum | GetBlendDst -- ^ enum | GetBlendSrc -- ^ enum | GetBlendSrcRGB -- ^ enum | GetBlendSrcAlpha -- ^ enum | GetBlendDstRGB -- ^ enum | GetBlendDstAlpha -- ^ enum | GetBlendEquation -- ^ enum | GetBlendEquationAlpha -- ^ enum | GetDepthFunc -- ^ enum | GetMapColor -- ^ bool | GetMapStencil -- ^ bool | GetIndexShift -- ^ int | GetIndexOffset -- ^ int -- Polygons -- ^ enum | GetCullFaceMode -- TextureSpecification | GetNumCompressedTextureFormats -- ^ int | GetMaxTextureSize -- ^ int | GetMax3DTextureSize -- ^ int | GetMaxCubeMapTextureSize -- ^ int | GetMaxRectangleTextureSize -- ^ int | GetMaxArrayTextureLayers -- ^ int | GetMaxSampleMaskWords -- ^ int | GetMaxColorTextureSamples -- ^ int | GetMaxDepthTextureSamples -- ^ int | GetMaxIntegerSamples -- ^ int -- ReadCopyPixels | GetReadBuffer -- ^ enum -- Texture Objects | GetTextureBinding1D -- ^ int\/enum | GetTextureBinding2D -- ^ int\/enum | GetTextureBinding3D -- ^ int\/enum | GetTextureBinding1DArray -- ^ int\/enum | GetTextureBinding2DArray -- ^ int\/enum | GetTextureBindingCubeMapArray -- ^ int\/enum | GetTextureBindingRectangle -- ^ int\/enum | GetTextureBindingBuffer -- ^ int\/enum | GetTextureBindingCubeMap -- ^ int\/enum | GetTextureBinding2DMultisample -- ^ int\/enum | GetTextureBinding2DMultisampleArray -- ^ int\/enum -- Antialiasing | GetSubpixelBits -- ^ sizei | GetSamples -- ^ sizei | GetSampleBuffers -- ^ sizei -- Sync Objects | GetMaxServerWaitTimeout -- ^ int -- Query Objects | GetMaxVertexStreams -- ^ int -- GL Time | GetTimestamp -- ^ int -- Shader | GetShaderCompiler -- ^ bool | GetNumShaderBinaryFormats -- ^ int | GetNumProgramBinaryFormats -- ^ int -- Debug Output | GetMaxDebugMessageLength -- ^ int | GetMaxDebugLoggedMessages -- ^ int | GetDebugLoggedMessages -- ^ int | GetDebugNextLoggedMessageLength -- ^ int | GetMaxDebugGroupStackDepth -- ^ int | GetMaxLabelLength -- ^ int instance GetPName1I PName1I where instance GetPName PName1I where marshalGetPName pn = case pn of GetEdgeFlag -> Just gl_EDGE_FLAG GetRGBAMode -> Just gl_RGBA_MODE GetCurrentIndex -> Just gl_CURRENT_INDEX GetMaxTextureUnits -> Just gl_MAX_TEXTURE_UNITS -- displaylist GetListIndex -> Just gl_LIST_INDEX GetListMode -> Just gl_LIST_MODE GetMaxListNesting -> Just gl_MAX_LIST_NESTING GetListBase -> Just gl_LIST_BASE -- rendermode GetRenderMode -> Just gl_RENDER_MODE -- framebufferbinding GetDrawFramebufferBinding -> Just gl_DRAW_FRAMEBUFFER_BINDING GetReadFramebufferBinding -> Just gl_READ_FRAMEBUFFER_BINDING GetFramebufferBinding -> Just gl_FRAMEBUFFER_BINDING -- renderbufferbinding GetRenderbufferBinding -> Just gl_RENDERBUFFER_BINDING -- hint GetPerspectiveCorrectionHint -> Just gl_PERSPECTIVE_CORRECTION_HINT GetPointSmoothHint -> Just gl_POINT_SMOOTH_HINT GetLineSmoothHint -> Just gl_LINE_SMOOTH_HINT GetPolygonSmoothHint -> Just gl_POLYGON_SMOOTH_HINT GetFogHint -> Just gl_FOG_HINT GetGenerateMipmapHint -> Just gl_GENERATE_MIPMAP_HINT GetTextureCompressionHint -> Just gl_TEXTURE_COMPRESSION_HINT GetPackCMYKHint -> Just gl_PACK_CMYK_HINT_EXT GetUnpackCMYKHint -> Just gl_UNPACK_CMYK_HINT_EXT GetVertexArrayBinding -> Just gl_VERTEX_ARRAY_BINDING -- Selection ? GetMaxNameStackDepth -> Just gl_MAX_NAME_STACK_DEPTH GetNameStackDepth -> Just gl_NAME_STACK_DEPTH -- ContextProfile GetContextProfileMask -> Just gl_CONTEXT_PROFILE_MASK --pixel storage GetPackSwapBytes -> Just gl_PACK_SWAP_BYTES GetUnpackSwapBytes -> Just gl_UNPACK_SWAP_BYTES GetPackLSBFirst -> Just gl_PACK_LSB_FIRST GetUnpackLSBFirst -> Just gl_UNPACK_LSB_FIRST GetPackRowLength -> Just gl_PACK_ROW_LENGTH GetUnpackRowLength -> Just gl_UNPACK_ROW_LENGTH GetPackSkipRows -> Just gl_PACK_SKIP_ROWS GetUnpackSkipRows -> Just gl_UNPACK_SKIP_ROWS GetPackSkipPixels -> Just gl_PACK_SKIP_PIXELS GetUnpackSkipPixels -> Just gl_UNPACK_SKIP_PIXELS GetPackAlignment -> Just gl_PACK_ALIGNMENT GetUnpackAlignment -> Just gl_UNPACK_ALIGNMENT GetPackSkipImages -> Just gl_PACK_SKIP_IMAGES GetUnpackSkipImages -> Just gl_UNPACK_SKIP_IMAGES GetPackImageHeight -> Just gl_PACK_IMAGE_HEIGHT GetUnpackImageHeight -> Just gl_UNPACK_IMAGE_HEIGHT -- pixelmap GetPixelMapIToISize -> Just gl_PIXEL_MAP_I_TO_I_SIZE GetPixelMapSToSSize -> Just gl_PIXEL_MAP_S_TO_S_SIZE GetPixelMapIToRSize -> Just gl_PIXEL_MAP_I_TO_R_SIZE GetPixelMapIToGSize -> Just gl_PIXEL_MAP_I_TO_G_SIZE GetPixelMapIToBSize -> Just gl_PIXEL_MAP_I_TO_B_SIZE GetPixelMapIToASize -> Just gl_PIXEL_MAP_I_TO_A_SIZE GetPixelMapRToRSize -> Just gl_PIXEL_MAP_R_TO_R_SIZE GetPixelMapGToGSize -> Just gl_PIXEL_MAP_G_TO_G_SIZE GetPixelMapBToBSize -> Just gl_PIXEL_MAP_B_TO_B_SIZE GetPixelMapAToASize -> Just gl_PIXEL_MAP_A_TO_A_SIZE GetMaxPixelMapTable -> Just gl_MAX_PIXEL_MAP_TABLE -- shader limits GetMaxVertexTextureImageUnits -> Just gl_MAX_VERTEX_TEXTURE_IMAGE_UNITS GetMaxTextureImageUnits -> Just gl_MAX_TEXTURE_IMAGE_UNITS GetMaxCombinedTextureImageUnits -> Just gl_MAX_COMBINED_TEXTURE_IMAGE_UNITS GetMaxTextureCoords -> Just gl_MAX_TEXTURE_COORDS GetMaxVertexUniformComponents -> Just gl_MAX_VERTEX_UNIFORM_COMPONENTS GetMaxFragmentUniformComponents -> Just gl_MAX_FRAGMENT_UNIFORM_COMPONENTS GetMaxVaryingFloats -> Just gl_MAX_VARYING_COMPONENTS GetMaxVertexAttribs -> Just gl_MAX_VERTEX_ATTRIBS -- tessellation GetPatchVertices -> Just gl_PATCH_VERTICES GetMaxPatchVertices -> Just gl_MAX_PATCH_VERTICES GetMaxTessGenLevel -> Just gl_MAX_TESS_GEN_LEVEL -- coordtrans GetMatrixMode -> Just gl_MATRIX_MODE GetModelviewStackDepth -> Just gl_MODELVIEW_STACK_DEPTH GetProjectionStackDepth -> Just gl_PROJECTION_STACK_DEPTH GetTextureStackDepth -> Just gl_TEXTURE_STACK_DEPTH GetColorMatrixStackDepth -> Just gl_COLOR_MATRIX_STACK_DEPTH GetMaxModelviewStackDepth -> Just gl_MAX_MODELVIEW_STACK_DEPTH GetMaxProjectionStackDepth -> Just gl_MAX_PROJECTION_STACK_DEPTH GetMaxTextureStackDepth -> Just gl_MAX_TEXTURE_STACK_DEPTH GetMaxColorMatrixStackDepth -> Just gl_MAX_COLOR_MATRIX_STACK_DEPTH GetMaxMatrixPaletteStackDepth -> Just gl_MAX_MATRIX_PALETTE_STACK_DEPTH_ARB GetCurrentMatrixStackDepth -> Just gl_CURRENT_MATRIX_STACK_DEPTH_ARB GetActiveTexture -> Just gl_ACTIVE_TEXTURE -- vertexarrays GetVertexArraySize -> Just gl_VERTEX_ARRAY_SIZE GetVertexArrayType -> Just gl_VERTEX_ARRAY_TYPE GetVertexArrayStride -> Just gl_VERTEX_ARRAY_STRIDE GetNormalArrayType -> Just gl_NORMAL_ARRAY_TYPE GetNormalArrayStride -> Just gl_NORMAL_ARRAY_STRIDE GetColorArraySize -> Just gl_COLOR_ARRAY_SIZE GetColorArrayType -> Just gl_COLOR_ARRAY_TYPE GetColorArrayStride -> Just gl_COLOR_ARRAY_STRIDE GetIndexArrayType -> Just gl_INDEX_ARRAY_TYPE GetIndexArrayStride -> Just gl_INDEX_ARRAY_STRIDE GetTextureCoordArraySize -> Just gl_TEXTURE_COORD_ARRAY_SIZE GetTextureCoordArrayType -> Just gl_TEXTURE_COORD_ARRAY_TYPE GetTextureCoordArrayStride -> Just gl_TEXTURE_COORD_ARRAY_STRIDE GetEdgeFlagArrayStride -> Just gl_EDGE_FLAG_ARRAY_STRIDE GetFogCoordArrayType -> Just gl_FOG_COORD_ARRAY_TYPE GetFogCoordArrayStride -> Just gl_FOG_COORD_ARRAY_STRIDE GetSecondaryColorArraySize -> Just gl_SECONDARY_COLOR_ARRAY_SIZE GetSecondaryColorArrayType -> Just gl_SECONDARY_COLOR_ARRAY_TYPE GetSecondaryColorArrayStride -> Just gl_SECONDARY_COLOR_ARRAY_STRIDE GetArrayElementLockCount -> Just gl_ARRAY_ELEMENT_LOCK_COUNT_EXT GetArrayElementLockFirst -> Just gl_ARRAY_ELEMENT_LOCK_FIRST_EXT GetClientActiveTexture -> Just gl_CLIENT_ACTIVE_TEXTURE GetMaxElementsVertices -> Just gl_MAX_ELEMENTS_VERTICES GetMaxElementsIndices -> Just gl_MAX_ELEMENTS_INDICES GetPrimitiveRestartIndex -> Just gl_PRIMITIVE_RESTART_INDEX GetPrimitiveRestartNV -> Just gl_PRIMITIVE_RESTART_NV GetPrimitiveRestartIndexNV -> Just gl_PRIMITIVE_RESTART_INDEX_NV -- bufferobjects GetArrayBufferBinding -> Just gl_ARRAY_BUFFER_BINDING GetAtomicCounterBufferBinding -> Just gl_ATOMIC_COUNTER_BUFFER_BINDING GetCopyReadBufferBinding -> Just gl_COPY_READ_BUFFER_BINDING GetCopyWriteBufferBinding -> Just gl_COPY_WRITE_BUFFER_BINDING GetDispatchIndirectBufferBinding -> Just gl_DISPATCH_INDIRECT_BUFFER_BINDING GetDrawIndirectBufferBinding -> Just gl_DRAW_INDIRECT_BUFFER_BINDING GetElementArrayBufferBinding -> Just gl_ELEMENT_ARRAY_BUFFER_BINDING GetPixelPackBufferBinding -> Just gl_PIXEL_PACK_BUFFER_BINDING GetPixelUnpackBufferBinding -> Just gl_PIXEL_UNPACK_BUFFER_BINDING GetQueryBufferBinding -> Just gl_QUERY_BUFFER_BINDING GetShaderStorageBufferBinding -> Just gl_SHADER_STORAGE_BUFFER_BINDING GetTransformFeedbackBufferBinding -> Just gl_TRANSFORM_FEEDBACK_BUFFER_BINDING GetUniformBufferBinding -> Just gl_UNIFORM_BUFFER_BINDING GetVertexArrayBufferBinding -> Just gl_VERTEX_ARRAY_BUFFER_BINDING GetNormalArrayBufferBinding -> Just gl_NORMAL_ARRAY_BUFFER_BINDING GetColorArrayBufferBinding -> Just gl_COLOR_ARRAY_BUFFER_BINDING GetIndexArrayBufferBinding -> Just gl_INDEX_ARRAY_BUFFER_BINDING GetTextureCoordArrayBufferBinding -> Just gl_TEXTURE_COORD_ARRAY_BUFFER_BINDING GetEdgeFlagArrayBufferBinding -> Just gl_EDGE_FLAG_ARRAY_BUFFER_BINDING GetSecondaryColorArrayBufferBinding -> Just gl_SECONDARY_COLOR_ARRAY_BUFFER_BINDING GetFogCoordArrayBufferBinding -> Just gl_FOG_COORD_ARRAY_BUFFER_BINDING -- clipping GetMaxClipPlanes -> Just gl_MAX_CLIP_DISTANCES -- Colors GetMaxLights -> Just gl_MAX_LIGHTS GetFrontFace -> Just gl_FRONT_FACE GetLightModelLocalViewer -> Just gl_LIGHT_MODEL_LOCAL_VIEWER GetLightModelTwoSide -> Just gl_LIGHT_MODEL_TWO_SIDE GetLightModelColorControl -> Just gl_LIGHT_MODEL_COLOR_CONTROL GetColorMaterialFace -> Just gl_COLOR_MATERIAL_FACE GetColorMaterialParameter -> Just gl_COLOR_MATERIAL_PARAMETER GetShadeModel -> Just gl_SHADE_MODEL GetVertexColorClamp -> Just gl_CLAMP_VERTEX_COLOR GetFragmentColorClamp -> Just gl_CLAMP_FRAGMENT_COLOR GetReadColorClamp -> Just gl_CLAMP_READ_COLOR -- Evaluators GetMaxEvalOrder -> Just gl_MAX_EVAL_ORDER GetMap1GridSegments -> Just gl_MAP1_GRID_SEGMENTS -- Fog GetFogMode -> Just gl_FOG_MODE GetFogIndex -> Just gl_FOG_INDEX GetFogCoordSrc -> Just gl_FOG_COORD_SRC GetFogDistanceMode -> Just gl_FOG_DISTANCE_MODE_NV -- Framebuffer GetAuxBuffers -> Just gl_AUX_BUFFERS GetDoublebuffer -> Just gl_DOUBLEBUFFER GetStereo -> Just gl_STEREO GetRedBits -> Just gl_RED_BITS GetGreenBits -> Just gl_GREEN_BITS GetBlueBits -> Just gl_BLUE_BITS GetAlphaBits -> Just gl_ALPHA_BITS GetDepthBits -> Just gl_DEPTH_BITS GetStencilBits -> Just gl_STENCIL_BITS GetAccumRedBits -> Just gl_ACCUM_RED_BITS GetAccumGreenBits -> Just gl_ACCUM_GREEN_BITS GetAccumBlueBits -> Just gl_ACCUM_BLUE_BITS GetAccumAlphaBits -> Just gl_ACCUM_ALPHA_BITS GetDrawBuffer -> Just gl_DRAW_BUFFER GetDrawBufferN i -> drawBufferIndexToEnum i GetMaxDrawBuffers -> Just gl_MAX_DRAW_BUFFERS GetIndexWritemask -> Just gl_INDEX_WRITEMASK GetDepthWritemask -> Just gl_DEPTH_WRITEMASK GetStencilWritemask -> Just gl_STENCIL_WRITEMASK GetStencilClearValue -> Just gl_STENCIL_CLEAR_VALUE -- Program GetCurrentProgram -> Just gl_CURRENT_PROGRAM -- Transformfeedback GetMaxTransformFeedbackSeparateAttribs -> Just gl_MAX_TRANSFORM_FEEDBACK_SEPARATE_ATTRIBS GetMaxTransformFeedbackSeparateComponents -> Just gl_MAX_TRANSFORM_FEEDBACK_SEPARATE_COMPONENTS GetMaxTransformFeedbackInterleavedComponents -> Just gl_MAX_TRANSFORM_FEEDBACK_INTERLEAVED_COMPONENTS -- RasterPos GetCurrentRasterIndex -> Just gl_CURRENT_RASTER_INDEX GetCurrentRasterPositionValid -> Just gl_CURRENT_RASTER_POSITION_VALID -- LineSegment GetLineStipplePattern -> Just gl_LINE_STIPPLE_PATTERN GetLineStippleRepeat -> Just gl_LINE_STIPPLE_REPEAT -- PerFragment GetSampleCoverageInvert -> Just gl_SAMPLE_COVERAGE_INVERT GetAlphaTestFunc -> Just gl_ALPHA_TEST_FUNC GetStencilFunc -> Just gl_STENCIL_FUNC GetStencilValueMask -> Just gl_STENCIL_VALUE_MASK GetStencilRef -> Just gl_STENCIL_REF GetStencilFail -> Just gl_STENCIL_FAIL GetStencilPassDepthFail -> Just gl_STENCIL_PASS_DEPTH_FAIL GetStencilPassDepthPass -> Just gl_STENCIL_PASS_DEPTH_PASS GetActiveStencilFace -> Just gl_ACTIVE_STENCIL_FACE_EXT GetLogicOpMode -> Just gl_LOGIC_OP_MODE GetBlendDst -> Just gl_BLEND_DST GetBlendSrc -> Just gl_BLEND_SRC GetBlendDstRGB -> Just gl_BLEND_DST_RGB GetBlendSrcRGB -> Just gl_BLEND_SRC_RGB GetBlendDstAlpha -> Just gl_BLEND_DST_ALPHA GetBlendSrcAlpha -> Just gl_BLEND_SRC_ALPHA GetBlendEquation -> Just gl_BLEND_EQUATION_RGB GetBlendEquationAlpha -> Just gl_BLEND_EQUATION_ALPHA GetDepthFunc -> Just gl_DEPTH_FUNC GetMapColor -> Just gl_MAP_COLOR GetMapStencil -> Just gl_MAP_STENCIL GetIndexShift -> Just gl_INDEX_SHIFT GetIndexOffset -> Just gl_INDEX_OFFSET -- Polygons GetCullFaceMode -> Just gl_CULL_FACE_MODE -- Texture specification GetNumCompressedTextureFormats -> Just gl_NUM_COMPRESSED_TEXTURE_FORMATS GetMaxTextureSize -> Just gl_MAX_TEXTURE_SIZE GetMax3DTextureSize -> Just gl_MAX_3D_TEXTURE_SIZE GetMaxCubeMapTextureSize -> Just gl_MAX_CUBE_MAP_TEXTURE_SIZE GetMaxRectangleTextureSize -> Just gl_MAX_RECTANGLE_TEXTURE_SIZE GetMaxArrayTextureLayers -> Just gl_MAX_ARRAY_TEXTURE_LAYERS GetMaxSampleMaskWords -> Just gl_MAX_SAMPLE_MASK_WORDS GetMaxColorTextureSamples -> Just gl_MAX_COLOR_TEXTURE_SAMPLES GetMaxDepthTextureSamples -> Just gl_MAX_DEPTH_TEXTURE_SAMPLES GetMaxIntegerSamples -> Just gl_MAX_INTEGER_SAMPLES -- ReadCopyPixels GetReadBuffer -> Just gl_READ_BUFFER -- Texture Objects GetTextureBinding1D -> Just gl_TEXTURE_BINDING_1D GetTextureBinding2D -> Just gl_TEXTURE_BINDING_2D GetTextureBinding3D -> Just gl_TEXTURE_BINDING_3D GetTextureBinding1DArray -> Just gl_TEXTURE_BINDING_1D_ARRAY GetTextureBinding2DArray -> Just gl_TEXTURE_BINDING_2D_ARRAY GetTextureBindingCubeMapArray -> Just gl_TEXTURE_BINDING_CUBE_MAP_ARRAY GetTextureBindingRectangle -> Just gl_TEXTURE_BINDING_RECTANGLE GetTextureBindingBuffer -> Just gl_TEXTURE_BINDING_BUFFER GetTextureBindingCubeMap -> Just gl_TEXTURE_BINDING_CUBE_MAP GetTextureBinding2DMultisample -> Just gl_TEXTURE_BINDING_2D_MULTISAMPLE GetTextureBinding2DMultisampleArray -> Just gl_TEXTURE_BINDING_2D_MULTISAMPLE_ARRAY -- Antialiasing GetSubpixelBits -> Just gl_SUBPIXEL_BITS GetSampleBuffers -> Just gl_SAMPLE_BUFFERS GetSamples -> Just gl_SAMPLES -- Sync Objects GetMaxServerWaitTimeout -> Just gl_MAX_SERVER_WAIT_TIMEOUT -- Query Objects GetMaxVertexStreams -> Just gl_MAX_VERTEX_STREAMS -- GL Time GetTimestamp -> Just gl_TIMESTAMP -- Shader GetShaderCompiler -> Just gl_SHADER_COMPILER GetNumShaderBinaryFormats -> Just gl_NUM_SHADER_BINARY_FORMATS GetNumProgramBinaryFormats -> Just gl_NUM_PROGRAM_BINARY_FORMATS -- Debug Output GetMaxDebugMessageLength -> Just gl_MAX_DEBUG_MESSAGE_LENGTH GetMaxDebugLoggedMessages -> Just gl_MAX_DEBUG_LOGGED_MESSAGES GetDebugLoggedMessages -> Just gl_DEBUG_LOGGED_MESSAGES GetDebugNextLoggedMessageLength -> Just gl_DEBUG_NEXT_LOGGED_MESSAGE_LENGTH GetMaxDebugGroupStackDepth -> Just gl_MAX_DEBUG_GROUP_STACK_DEPTH GetMaxLabelLength -> Just gl_MAX_LABEL_LENGTH -- 0x8825 through 0x8834 are reserved for draw buffers drawBufferIndexToEnum :: GLsizei -> Maybe GLenum drawBufferIndexToEnum i | 0 <= i && i <= maxDrawBufferIndex = Just (gl_DRAW_BUFFER0 + fromIntegral i) | otherwise = Nothing maxDrawBufferIndex :: GLsizei maxDrawBufferIndex = fromIntegral (gl_DRAW_BUFFER15 - gl_DRAW_BUFFER0) ----------------------------------------------------------------------------- data PName1F = GetCurrentFogCoord -- ^ Float1 -- Rasterization | GetZoomX -- ^ Float | GetZoomY -- ^ Float -- Colors | GetMaxShininess -- ^ Float | GetMaxSpotExponent -- ^ Float -- Fog | GetFogStart -- ^ float | GetFogEnd -- ^ float | GetFogDensity -- ^ float -- Framebuffer | GetDepthClearValue -- ^ clampf | GetIndexClearValue -- ^ float -- RasterPos | GetCurrentRasterDistance -- ^ float -- Point | GetPointSizeMin -- ^ float | GetPointSizeMax -- ^ float | GetPointFadeThresholdSize -- ^ float | GetSmoothPointSizeGranularity -- ^ float | GetPointSize -- ^ float -- LineSegment | GetLineWidth -- ^ float | GetSmoothLineWidthGranularity -- ^ float -- PerFragment | GetSampleCoverageValue -- ^ clampf | GetAlphaTestRef -- ^ clampf -- PixelTransfer | GetRedScale -- ^ float | GetGreenScale -- ^ float | GetBlueScale -- ^ float | GetAlphaScale -- ^ float | GetPostConvolutionRedScale -- ^ float | GetPostConvolutionGreenScale -- ^ float | GetPostConvolutionBlueScale -- ^ float | GetPostConvolutionAlphaScale -- ^ float | GetPostColorMatrixRedScale -- ^ float | GetPostColorMatrixGreenScale -- ^ float | GetPostColorMatrixBlueScale -- ^ float | GetPostColorMatrixAlphaScale -- ^ float | GetRedBias -- ^ float | GetGreenBias -- ^ float | GetBlueBias -- ^ float | GetAlphaBias -- ^ float | GetPostConvolutionRedBias -- ^ float | GetPostConvolutionGreenBias -- ^ float | GetPostConvolutionBlueBias -- ^ float | GetPostConvolutionAlphaBias -- ^ float | GetPostColorMatrixRedBias -- ^ float | GetPostColorMatrixGreenBias -- ^ float | GetPostColorMatrixBlueBias -- ^ float | GetPostColorMatrixAlphaBias -- ^ float | GetDepthScale -- ^ float | GetDepthBias -- ^ float -- Polygons | GetPolygonOffsetFactor -- ^ float | GetPolygonOffsetUnits -- ^ float -- Texture parameters | GetMaxTextureMaxAnisotropy -- ^ float | GetMaxTextureLODBias -- ^ float instance GetPName1F PName1F where instance GetPName PName1F where marshalGetPName pn = case pn of GetCurrentFogCoord -> Just gl_CURRENT_FOG_COORD -- Rasterization GetZoomX -> Just gl_ZOOM_X GetZoomY -> Just gl_ZOOM_Y -- Colors GetMaxShininess -> Just gl_MAX_SHININESS_NV GetMaxSpotExponent -> Just gl_MAX_SPOT_EXPONENT_NV -- Fog GetFogStart -> Just gl_FOG_START GetFogEnd -> Just gl_FOG_END GetFogDensity -> Just gl_FOG_DENSITY -- Framebuffer GetDepthClearValue -> Just gl_DEPTH_CLEAR_VALUE GetIndexClearValue -> Just gl_INDEX_CLEAR_VALUE -- RasterPos GetCurrentRasterDistance -> Just gl_CURRENT_RASTER_DISTANCE -- Point GetPointSizeMin -> Just gl_POINT_SIZE_MIN GetPointSizeMax -> Just gl_POINT_SIZE_MAX GetPointFadeThresholdSize -> Just gl_POINT_FADE_THRESHOLD_SIZE GetSmoothPointSizeGranularity -> Just gl_POINT_SIZE_GRANULARITY GetPointSize -> Just gl_POINT_SIZE -- LineSegment GetSmoothLineWidthGranularity -> Just gl_SMOOTH_LINE_WIDTH_GRANULARITY GetLineWidth -> Just gl_LINE_WIDTH -- PerFragment GetSampleCoverageValue -> Just gl_SAMPLE_COVERAGE_VALUE GetAlphaTestRef -> Just gl_ALPHA_TEST_REF -- PixelTransfer GetRedScale -> Just gl_RED_SCALE GetRedBias -> Just gl_RED_BIAS GetGreenScale -> Just gl_GREEN_SCALE GetGreenBias -> Just gl_GREEN_BIAS GetBlueScale -> Just gl_BLUE_SCALE GetBlueBias -> Just gl_BLUE_BIAS GetAlphaScale -> Just gl_ALPHA_SCALE GetAlphaBias -> Just gl_ALPHA_BIAS GetPostConvolutionRedScale -> Just gl_POST_CONVOLUTION_RED_SCALE GetPostConvolutionGreenScale -> Just gl_POST_CONVOLUTION_GREEN_SCALE GetPostConvolutionBlueScale -> Just gl_POST_CONVOLUTION_BLUE_SCALE GetPostConvolutionAlphaScale -> Just gl_POST_CONVOLUTION_ALPHA_SCALE GetPostConvolutionRedBias -> Just gl_POST_CONVOLUTION_RED_BIAS GetPostConvolutionGreenBias -> Just gl_POST_CONVOLUTION_GREEN_BIAS GetPostConvolutionBlueBias -> Just gl_POST_CONVOLUTION_BLUE_BIAS GetPostConvolutionAlphaBias -> Just gl_POST_CONVOLUTION_ALPHA_BIAS GetPostColorMatrixRedScale -> Just gl_POST_COLOR_MATRIX_RED_SCALE GetPostColorMatrixGreenScale -> Just gl_POST_COLOR_MATRIX_GREEN_SCALE GetPostColorMatrixBlueScale -> Just gl_POST_COLOR_MATRIX_BLUE_SCALE GetPostColorMatrixAlphaScale -> Just gl_POST_COLOR_MATRIX_ALPHA_SCALE GetPostColorMatrixRedBias -> Just gl_POST_COLOR_MATRIX_RED_BIAS GetPostColorMatrixGreenBias -> Just gl_POST_COLOR_MATRIX_GREEN_BIAS GetPostColorMatrixBlueBias -> Just gl_POST_COLOR_MATRIX_BLUE_BIAS GetPostColorMatrixAlphaBias -> Just gl_POST_COLOR_MATRIX_ALPHA_BIAS GetDepthScale -> Just gl_DEPTH_SCALE GetDepthBias -> Just gl_DEPTH_BIAS -- Polygons GetPolygonOffsetFactor -> Just gl_POLYGON_OFFSET_FACTOR GetPolygonOffsetUnits -> Just gl_POLYGON_OFFSET_UNITS -- Texture parameters GetMaxTextureMaxAnisotropy -> Just gl_MAX_TEXTURE_MAX_ANISOTROPY_EXT GetMaxTextureLODBias -> Just gl_MAX_TEXTURE_LOD_BIAS ----------------------------------------------------------------------------- data IPName1I = GetAtomicCounterBuffer | GetAtomicCounterBufferStart | GetAtomicCounterBufferSize | GetShaderStorageBuffer | GetShaderStorageBufferStart | GetShaderStorageBufferSize | GetTransformFeedbackBuffer | GetTransformFeedbackBufferStart | GetTransformFeedbackBufferSize | GetUniformBuffer | GetUniformBufferStart | GetUniformBufferSize instance GetIPName1I IPName1I where instance GetPName IPName1I where marshalGetPName pn = case pn of GetAtomicCounterBuffer -> Just gl_ATOMIC_COUNTER_BUFFER GetAtomicCounterBufferStart -> Just gl_ATOMIC_COUNTER_BUFFER_START GetAtomicCounterBufferSize -> Just gl_ATOMIC_COUNTER_BUFFER_SIZE GetShaderStorageBuffer -> Just gl_SHADER_STORAGE_BUFFER GetShaderStorageBufferStart -> Just gl_SHADER_STORAGE_BUFFER_START GetShaderStorageBufferSize -> Just gl_SHADER_STORAGE_BUFFER_SIZE GetTransformFeedbackBuffer -> Just gl_TRANSFORM_FEEDBACK_BUFFER GetTransformFeedbackBufferStart -> Just gl_TRANSFORM_FEEDBACK_BUFFER_START GetTransformFeedbackBufferSize -> Just gl_TRANSFORM_FEEDBACK_BUFFER_SIZE GetUniformBuffer -> Just gl_UNIFORM_BUFFER GetUniformBufferStart -> Just gl_UNIFORM_BUFFER_START GetUniformBufferSize -> Just gl_UNIFORM_BUFFER_SIZE ----------------------------------------------------------------------------- data PName2I -- coordtrans = GetMaxViewportDims -- ^ sizei -- Evaluators | GetMap2GridSegments -- Polygons | GetPolygonMode instance GetPName2I PName2I where instance GetPName PName2I where marshalGetPName pn = case pn of -- coordtrans GetMaxViewportDims -> Just gl_MAX_VIEWPORT_DIMS -- Evaluators GetMap2GridSegments -> Just gl_MAP2_GRID_SEGMENTS -- Polygons GetPolygonMode -> Just gl_POLYGON_MODE ----------------------------------------------------------------------------- data PName2F -- coordtrans = GetDepthRange -- ^ clamp -- Evaluators | GetMap1GridDomain -- ^ float2? -- Point | GetAliasedPointSizeRange -- ^ float | GetSmoothPointSizeRange -- ^ float -- LineSegments | GetAliasedLineWidthRange -- ^ float | GetSmoothLineWidthRange -- ^ float -- PerFragment | GetDepthBounds -- ^ clampd instance GetPName2F PName2F where instance GetPName PName2F where marshalGetPName pn = case pn of -- coord trans GetDepthRange -> Just gl_DEPTH_RANGE -- Evaluators GetMap1GridDomain -> Just gl_MAP1_GRID_DOMAIN -- Point GetAliasedPointSizeRange -> Just gl_ALIASED_POINT_SIZE_RANGE GetSmoothPointSizeRange -> Just gl_POINT_SIZE_RANGE -- LineSegments GetAliasedLineWidthRange -> Just gl_ALIASED_LINE_WIDTH_RANGE GetSmoothLineWidthRange -> Just gl_SMOOTH_LINE_WIDTH_RANGE -- PerFragment GetDepthBounds -> Just gl_DEPTH_BOUNDS_EXT ----------------------------------------------------------------------------- data PName3F = GetCurrentNormal -- ^ Float3 -- Point | GetPointDistanceAttenuation -- ^ float instance GetPName3F PName3F where instance GetPName PName3F where marshalGetPName pn = case pn of GetCurrentNormal -> Just gl_CURRENT_NORMAL -- Point GetPointDistanceAttenuation -> Just gl_POINT_DISTANCE_ATTENUATION ----------------------------------------------------------------------------- data PName4I -- coordtrans = GetViewport -- ^ int -- Framebuffer | GetRGBASignedComponents -- ^ int -- PerFragment | GetScissorBox -- ^ int instance GetPName4I PName4I where instance GetPName PName4I where marshalGetPName pn = case pn of -- coordtrans GetViewport -> Just gl_VIEWPORT -- Framebuffer GetRGBASignedComponents -> Just gl_RGBA_SIGNED_COMPONENTS_EXT -- PerFragement GetScissorBox -> Just gl_SCISSOR_BOX -- | Both indexed and unindexed data PName4ISemiIndexed = GetColorWritemask -- ^ bool instance GetPName4I PName4ISemiIndexed where instance GetIPName4I PName4ISemiIndexed where instance GetPName PName4ISemiIndexed where marshalGetPName pn = case pn of GetColorWritemask -> Just gl_COLOR_WRITEMASK ----------------------------------------------------------------------------- data PName4F = GetCurrentColor -- ^ ? | GetCurrentTextureCoords -- ^ Float | GetCurrentSecondaryColor -- ^ Float -- Colors | GetLightModelAmbient -- ^ float -- Evaluators | GetMap2GridDomain -- ^ float? -- Fog | GetFogColor -- ^ clampf -- Framebuffer | GetColorClearValue -- ^ clampf | GetAccumClearValue -- ^ float -- RasterPos | GetCurrentRasterColor -- ^ float | GetCurrentRasterSecondaryColor -- ^ float | GetCurrentRasterTextureCoords -- ^ float | GetCurrentRasterPosition -- ^ float | GetBlendColor -- ^ clampf instance GetPName4F PName4F where instance GetPName PName4F where marshalGetPName pn = case pn of GetCurrentColor -> Just gl_CURRENT_COLOR GetCurrentTextureCoords -> Just gl_CURRENT_TEXTURE_COORDS GetCurrentSecondaryColor -> Just gl_CURRENT_SECONDARY_COLOR -- Colors GetLightModelAmbient -> Just gl_LIGHT_MODEL_AMBIENT -- Evaluators GetMap2GridDomain -> Just gl_MAP2_GRID_DOMAIN -- Fog GetFogColor -> Just gl_FOG_COLOR -- Framebuffer GetColorClearValue -> Just gl_COLOR_CLEAR_VALUE GetAccumClearValue -> Just gl_ACCUM_CLEAR_VALUE -- Rasterpos GetCurrentRasterColor -> Just gl_CURRENT_RASTER_COLOR GetCurrentRasterSecondaryColor -> Just gl_CURRENT_RASTER_SECONDARY_COLOR GetCurrentRasterTextureCoords -> Just gl_CURRENT_RASTER_TEXTURE_COORDS GetCurrentRasterPosition -> Just gl_CURRENT_RASTER_POSITION -- PerFragment GetBlendColor -> Just gl_BLEND_COLOR -- 0x3000 through 0x3FFF are reserved for clip planes clipPlaneIndexToEnum :: GLsizei -> Maybe GLenum clipPlaneIndexToEnum i | 0 <= i && i <= maxClipPlaneIndex = Just (gl_CLIP_DISTANCE0 + fromIntegral i) | otherwise = Nothing maxClipPlaneIndex :: GLsizei maxClipPlaneIndex = 0xFFF ----------------------------------------------------------------------------- data PNameNI = GetCompressedTextureFormats | GetShaderBinaryFormats | GetProgramBinaryFormats instance GetPNameNI PNameNI where instance GetPName PNameNI where marshalGetPName pn = case pn of GetCompressedTextureFormats -> Just gl_COMPRESSED_TEXTURE_FORMATS GetShaderBinaryFormats -> Just gl_SHADER_BINARY_FORMATS GetProgramBinaryFormats -> Just gl_PROGRAM_BINARY_FORMATS ----------------------------------------------------------------------------- data PNameMatrix -- coordtrans = GetModelviewMatrix | GetProjectionMatrix | GetTextureMatrix | GetColorMatrix | GetMatrixPalette instance GetPNameMatrix PNameMatrix where instance GetPName PNameMatrix where marshalGetPName pn = case pn of -- coordtrans GetModelviewMatrix -> Just gl_MODELVIEW_MATRIX GetProjectionMatrix -> Just gl_PROJECTION_MATRIX GetTextureMatrix -> Just gl_TEXTURE_MATRIX GetColorMatrix -> Just gl_COLOR_MATRIX GetMatrixPalette -> Just gl_MATRIX_PALETTE_ARB -------------------------------------------------------------------------------- data GetPointervPName = -- core profile DebugCallbackFunction | DebugCallbackUserParam -- compatibility profile | SelectionBufferPointer | FeedbackBufferPointer | VertexArrayPointer | NormalArrayPointer | ColorArrayPointer | SecondaryColorArrayPointer | IndexArrayPointer | TextureCoordArrayPointer | FogCoordArrayPointer | EdgeFlagArrayPointer -- GL_ARB_vertex_blend | WeightArrayPointer -- GL_ARB_matrix_palette | MatrixIndexArrayPointer marshalGetPointervPName :: GetPointervPName -> GLenum marshalGetPointervPName x = case x of DebugCallbackFunction -> gl_DEBUG_CALLBACK_FUNCTION DebugCallbackUserParam -> gl_DEBUG_CALLBACK_USER_PARAM SelectionBufferPointer -> gl_SELECTION_BUFFER_POINTER FeedbackBufferPointer -> gl_FEEDBACK_BUFFER_POINTER VertexArrayPointer -> gl_VERTEX_ARRAY_POINTER NormalArrayPointer -> gl_NORMAL_ARRAY_POINTER ColorArrayPointer -> gl_COLOR_ARRAY_POINTER SecondaryColorArrayPointer -> gl_SECONDARY_COLOR_ARRAY_POINTER IndexArrayPointer -> gl_INDEX_ARRAY_POINTER TextureCoordArrayPointer -> gl_TEXTURE_COORD_ARRAY_POINTER FogCoordArrayPointer -> gl_FOG_COORD_ARRAY_POINTER EdgeFlagArrayPointer -> gl_EDGE_FLAG_ARRAY_POINTER WeightArrayPointer -> gl_WEIGHT_ARRAY_POINTER_ARB MatrixIndexArrayPointer -> gl_MATRIX_INDEX_ARRAY_POINTER_ARB -------------------------------------------------------------------------------- getPointer :: GetPointervPName -> IO (Ptr a) getPointer n = with nullPtr $ \buf -> do glGetPointerv (marshalGetPointervPName n) buf peek buf OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/0000755000000000000000000000000012521420345022673 5ustar0000000000000000OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/Attachments.hs0000644000000000000000000000655112521420345025511 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.FramebufferObjects.Attachments -- Copyright : (c) Sven Panne, Lars Corbijn 2011-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.FramebufferObjects.Attachments ( FramebufferObjectAttachment(..), fboaToBufferMode, fboaFromBufferMode, FramebufferAttachment(..), framebufferRenderbuffer, framebufferTexture1D, framebufferTexture2D, framebufferTexture3D, framebufferTextureLayer ) where import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjectAttachment import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferTarget import Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObject import Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferTarget import Graphics.Rendering.OpenGL.GL.Texturing.Specification import Graphics.Rendering.OpenGL.GL.Texturing.TextureObject import Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw ----------------------------------------------------------------------------- framebufferRenderbuffer :: FramebufferTarget -> FramebufferObjectAttachment -> RenderbufferTarget -> RenderbufferObject -> IO () framebufferRenderbuffer fbt fba rbt (RenderbufferObject rboi) = maybe recordInvalidValue (\mfba -> glFramebufferRenderbuffer (marshalFramebufferTarget fbt) mfba (marshalRenderbufferTarget rbt) rboi) $ marshalFramebufferObjectAttachment fba framebufferTexture1D :: FramebufferTarget -> FramebufferObjectAttachment -> TextureTarget1D -> TextureObject -> Level -> IO () framebufferTexture1D fbt fba tt (TextureObject t) l = maybe recordInvalidValue (\mfba -> glFramebufferTexture1D (marshalFramebufferTarget fbt) mfba (marshalQueryableTextureTarget tt) t l) $ marshalFramebufferObjectAttachment fba -- Note: Typing is too permissive, no TEXTURE_1D_ARRAY allowed per 4.4. spec. framebufferTexture2D :: FramebufferTarget -> FramebufferObjectAttachment -> TextureTarget2D -> TextureObject -> Level -> IO () framebufferTexture2D fbt fba tt (TextureObject t) l = maybe recordInvalidValue (\mfba -> glFramebufferTexture2D (marshalFramebufferTarget fbt) mfba (marshalQueryableTextureTarget tt) t l) $ marshalFramebufferObjectAttachment fba -- Note: Typing is too permissive, no TEXTURE_2D_ARRAY or TEXTURE_2D_MULTISAMPLE_ARRAY allowed per 4.4. spec. framebufferTexture3D :: FramebufferTarget -> FramebufferObjectAttachment -> TextureTarget3D -> TextureObject -> Level -> GLint -> IO () framebufferTexture3D fbt fba tt (TextureObject t) le la = maybe recordInvalidValue (\mfba -> glFramebufferTexture3D (marshalFramebufferTarget fbt) mfba (marshalQueryableTextureTarget tt) t le la) $ marshalFramebufferObjectAttachment fba framebufferTextureLayer :: FramebufferTarget -> FramebufferObjectAttachment -> TextureObject -> Level -> GLint -> IO() framebufferTextureLayer fbt fba (TextureObject t) le la = maybe recordInvalidValue (\mfba -> glFramebufferTextureLayer (marshalFramebufferTarget fbt) mfba t le la) $ marshalFramebufferObjectAttachment fba OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/FramebufferObjects.hs0000644000000000000000000000615312521420345026772 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjects -- Copyright : (c) Sven Panne, Lars Corbijn 2011-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjects ( FramebufferObject, defaultFramebufferObject, FramebufferTarget(..), bindFramebuffer, FramebufferStatus(..), framebufferStatus, ) where import Data.StateVar import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObject import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferTarget import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw ----------------------------------------------------------------------------- defaultFramebufferObject :: FramebufferObject defaultFramebufferObject = FramebufferObject 0 ----------------------------------------------------------------------------- bindFramebuffer :: FramebufferTarget -> StateVar FramebufferObject bindFramebuffer fbt = makeStateVar (getBoundFramebuffer fbt) (setFramebuffer fbt) marshalFramebufferTargetBinding :: FramebufferTarget -> PName1I marshalFramebufferTargetBinding x = case x of DrawFramebuffer -> GetDrawFramebufferBinding ReadFramebuffer -> GetReadFramebufferBinding Framebuffer -> GetFramebufferBinding getBoundFramebuffer :: FramebufferTarget -> IO FramebufferObject getBoundFramebuffer = getInteger1 (FramebufferObject . fromIntegral) . marshalFramebufferTargetBinding setFramebuffer :: FramebufferTarget -> FramebufferObject -> IO () setFramebuffer fbt = glBindFramebuffer (marshalFramebufferTarget fbt) . framebufferID ----------------------------------------------------------------------------- data FramebufferStatus = Complete | Undefined | IncompleteMissingAttachment | IncompleteDrawBuffer | IncompleteReadBuffer | IncompleteMultiSample | Unsupported deriving ( Eq, Ord, Show ) unmarshalFramebufferStatus :: GLenum -> FramebufferStatus unmarshalFramebufferStatus x | x == gl_FRAMEBUFFER_COMPLETE = Complete | x == gl_FRAMEBUFFER_UNDEFINED = Undefined | x == gl_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT = IncompleteMissingAttachment | x == gl_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER = IncompleteDrawBuffer | x == gl_FRAMEBUFFER_INCOMPLETE_READ_BUFFER = IncompleteReadBuffer | x == gl_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE = IncompleteMultiSample | x == gl_FRAMEBUFFER_UNSUPPORTED = Unsupported | otherwise = error $ "unmarshalFramebufferStatus: unknown value: " ++ show x ----------------------------------------------------------------------------- framebufferStatus :: FramebufferTarget -> GettableStateVar FramebufferStatus framebufferStatus t = makeGettableStateVar $ fmap unmarshalFramebufferStatus . glCheckFramebufferStatus . marshalFramebufferTarget $ t ----------------------------------------------------------------------------- OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/Queries.hs0000644000000000000000000002421412521420345024647 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.FramebufferObjects.Queries -- Copyright : (c) Sven Panne, Lars Corbijn 2011-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.FramebufferObjects.Queries ( AttachmentObjectType(..), attachmentObjectType, attachmentObject, attachmentTextureLayer, attachmentTextureLevel, attachmentTextureTextureTargetCubeMapFace, attachmentRedSize, attachmentBlueSize, attachmentGreenSize, attachmentAlphaSize, attachmentDepthSize, attachmentStencilSize, renderbufferWidth, renderbufferHeight, renderbufferInternalFormat, renderbufferSamples, renderbufferRedSize, renderbufferBlueSize, renderbufferGreenSize, renderbufferAlphaSize, renderbufferDepthSize, renderbufferStencilSize, ) where import Data.StateVar import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjectAttachment import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferTarget import Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObject import Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferTarget import Graphics.Rendering.OpenGL.GL.Texturing.PixelInternalFormat import Graphics.Rendering.OpenGL.GL.Texturing.Specification(Level) import Graphics.Rendering.OpenGL.GL.Texturing.TextureObject import Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget import Graphics.Rendering.OpenGL.Raw ----------------------------------------------------------------------------- data GetFramebufferAttachmentPName = AttachmentObjectType | AttachmentObjectName | AttachmentTextureLevel | AttachmentTextureCubeMapFace | AttachmentTextureLayer | AttachmentComponentType | AttachmentColorEncoding | AttachmentRedSize | AttachmentBlueSize | AttachmentGreenSize | AttachmentAlphaSize | AttachmentDepthSize | AttachmentStencilSize marshalGetFBAPName :: GetFramebufferAttachmentPName -> GLenum marshalGetFBAPName x = case x of AttachmentObjectType -> gl_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE AttachmentObjectName -> gl_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME AttachmentTextureLevel -> gl_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL AttachmentTextureCubeMapFace -> gl_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE AttachmentTextureLayer -> gl_FRAMEBUFFER_ATTACHMENT_TEXTURE_LAYER AttachmentComponentType -> gl_FRAMEBUFFER_ATTACHMENT_COMPONENT_TYPE -- TODO impement usefull function AttachmentColorEncoding -> gl_FRAMEBUFFER_ATTACHMENT_COLOR_ENCODING -- TODO impement usefull function AttachmentRedSize -> gl_FRAMEBUFFER_ATTACHMENT_RED_SIZE AttachmentBlueSize -> gl_FRAMEBUFFER_ATTACHMENT_BLUE_SIZE AttachmentGreenSize -> gl_FRAMEBUFFER_ATTACHMENT_GREEN_SIZE AttachmentAlphaSize -> gl_FRAMEBUFFER_ATTACHMENT_ALPHA_SIZE AttachmentDepthSize -> gl_FRAMEBUFFER_ATTACHMENT_DEPTH_SIZE AttachmentStencilSize -> gl_FRAMEBUFFER_ATTACHMENT_STENCIL_SIZE getFBAPName :: FramebufferAttachment fba => FramebufferTarget -> fba -> (GLint -> a) -> GetFramebufferAttachmentPName -> IO a getFBAPName fbt fba f p = getFBAParameteriv fbt fba f (marshalGetFBAPName p) ----------------------------------------------------------------------------- data AttachmentObjectType = DefaultFramebufferAttachment | TextureAttachment | RenderbufferAttachment deriving ( Eq, Ord, Show ) unmarshalAttachmentObjectType :: GLenum -> Maybe AttachmentObjectType unmarshalAttachmentObjectType x | x == gl_FRAMEBUFFER_DEFAULT = Just DefaultFramebufferAttachment | x == gl_TEXTURE = Just TextureAttachment | x == gl_RENDERBUFFER = Just RenderbufferAttachment | x == gl_NONE = Nothing | otherwise = error $ "unmarshalAttachmentObject: unknown value " ++ show x attachmentObjectType :: FramebufferAttachment fba => FramebufferTarget -> fba -> GettableStateVar (Maybe AttachmentObjectType) attachmentObjectType fbt fba = makeGettableStateVar $ getFBAPName fbt fba (unmarshalAttachmentObjectType . fromIntegral) AttachmentObjectType -- | tries to retrieve the object that is bound to the attachment point of the -- given framebuffertarget. If the object type of it is None or the default, then -- `Nothing` is returned, otherwise the bound `RenderbufferObject` or `TextureObject` attachmentObject :: FramebufferAttachment fba => FramebufferTarget -> fba -> GettableStateVar (Maybe (Either RenderbufferObject TextureObject)) attachmentObject fbt fba = makeGettableStateVar getter where getter = do objT <- get $ attachmentObjectType fbt fba case objT of Nothing -> return $ Nothing (Just DefaultFramebufferAttachment) -> return $ Nothing (Just TextureAttachment) -> getObjectName (Right . TextureObject) (Just RenderbufferAttachment) -> getObjectName (Left . RenderbufferObject) getObjectName :: Num n => (n -> Either RenderbufferObject TextureObject) -> IO (Maybe (Either RenderbufferObject TextureObject)) getObjectName con = getFBAPName fbt fba (Just . con . fromIntegral) AttachmentObjectName attachmentTextureLayer :: FramebufferAttachment fba => FramebufferTarget -> fba -> GettableStateVar GLint attachmentTextureLayer fbt fba = makeGettableStateVar $ getFBAPName fbt fba id AttachmentTextureLayer attachmentTextureLevel :: FramebufferAttachment fba => FramebufferTarget -> fba -> GettableStateVar Level attachmentTextureLevel fbt fba = makeGettableStateVar $ getFBAPName fbt fba id AttachmentTextureLevel attachmentTextureTextureTargetCubeMapFace :: FramebufferAttachment fba => FramebufferTarget -> fba -> GettableStateVar TextureTargetCubeMapFace attachmentTextureTextureTargetCubeMapFace fbt fba = makeGettableStateVar $ getFBAPName fbt fba (unmarshalTextureTargetCubeMapFace . fromIntegral) AttachmentTextureLevel ----------------------------------------------------------------------------- attachmentRedSize :: FramebufferAttachment fba => FramebufferTarget -> fba -> GettableStateVar GLint attachmentRedSize fbt fba = makeGettableStateVar $ getFBAPName fbt fba id AttachmentRedSize attachmentGreenSize :: FramebufferAttachment fba => FramebufferTarget -> fba -> GettableStateVar GLint attachmentGreenSize fbt fba = makeGettableStateVar $ getFBAPName fbt fba id AttachmentGreenSize attachmentBlueSize :: FramebufferAttachment fba => FramebufferTarget -> fba -> GettableStateVar GLint attachmentBlueSize fbt fba = makeGettableStateVar $ getFBAPName fbt fba id AttachmentBlueSize attachmentAlphaSize :: FramebufferAttachment fba => FramebufferTarget -> fba -> GettableStateVar GLint attachmentAlphaSize fbt fba = makeGettableStateVar $ getFBAPName fbt fba id AttachmentAlphaSize attachmentDepthSize :: FramebufferAttachment fba => FramebufferTarget -> fba -> GettableStateVar GLint attachmentDepthSize fbt fba = makeGettableStateVar $ getFBAPName fbt fba id AttachmentDepthSize attachmentStencilSize :: FramebufferAttachment fba => FramebufferTarget -> fba -> GettableStateVar GLint attachmentStencilSize fbt fba = makeGettableStateVar $ getFBAPName fbt fba id AttachmentStencilSize ----------------------------------------------------------------------------- data GetRenderbufferPName = RenderbufferWidth | RenderbufferHeight | RenderbufferInternalFormat | RenderbufferSamples | RenderbufferRedSize | RenderbufferBlueSize | RenderbufferGreenSize | RenderbufferAlphaSize | RenderbufferDepthSize | RenderbufferStencilSize marshalGetRBPname :: GetRenderbufferPName -> GLenum marshalGetRBPname x = case x of RenderbufferWidth -> gl_RENDERBUFFER_WIDTH RenderbufferHeight -> gl_RENDERBUFFER_HEIGHT RenderbufferInternalFormat -> gl_RENDERBUFFER_INTERNAL_FORMAT RenderbufferSamples -> gl_RENDERBUFFER_SAMPLES RenderbufferRedSize -> gl_RENDERBUFFER_RED_SIZE RenderbufferBlueSize -> gl_RENDERBUFFER_BLUE_SIZE RenderbufferGreenSize -> gl_RENDERBUFFER_GREEN_SIZE RenderbufferAlphaSize -> gl_RENDERBUFFER_ALPHA_SIZE RenderbufferDepthSize -> gl_RENDERBUFFER_DEPTH_SIZE RenderbufferStencilSize -> gl_RENDERBUFFER_STENCIL_SIZE getRBPName :: RenderbufferTarget -> (GLint -> a) -> GetRenderbufferPName -> IO a getRBPName rbt f = getRBParameteriv rbt f . marshalGetRBPname ----------------------------------------------------------------------------- renderbufferWidth :: RenderbufferTarget -> GettableStateVar GLsizei renderbufferWidth rbt = makeGettableStateVar $ getRBPName rbt fromIntegral RenderbufferWidth renderbufferHeight :: RenderbufferTarget -> GettableStateVar GLsizei renderbufferHeight rbt = makeGettableStateVar $ getRBPName rbt fromIntegral RenderbufferHeight renderbufferInternalFormat :: RenderbufferTarget -> GettableStateVar PixelInternalFormat renderbufferInternalFormat rbt = makeGettableStateVar $ getRBPName rbt unmarshalPixelInternalFormat RenderbufferInternalFormat renderbufferSamples :: RenderbufferTarget -> GettableStateVar Samples renderbufferSamples rbt = makeGettableStateVar $ getRBPName rbt (Samples . fromIntegral) RenderbufferSamples renderbufferRedSize :: RenderbufferTarget -> GettableStateVar GLint renderbufferRedSize rbt = makeGettableStateVar $ getRBPName rbt id RenderbufferRedSize renderbufferGreenSize :: RenderbufferTarget -> GettableStateVar GLint renderbufferGreenSize rbt = makeGettableStateVar $ getRBPName rbt id RenderbufferGreenSize renderbufferBlueSize :: RenderbufferTarget -> GettableStateVar GLint renderbufferBlueSize rbt = makeGettableStateVar $ getRBPName rbt id RenderbufferBlueSize renderbufferAlphaSize :: RenderbufferTarget -> GettableStateVar GLint renderbufferAlphaSize rbt = makeGettableStateVar $ getRBPName rbt id RenderbufferAlphaSize renderbufferDepthSize :: RenderbufferTarget -> GettableStateVar GLint renderbufferDepthSize rbt = makeGettableStateVar $ getRBPName rbt id RenderbufferDepthSize renderbufferStencilSize :: RenderbufferTarget -> GettableStateVar GLint renderbufferStencilSize rbt = makeGettableStateVar $ getRBPName rbt id RenderbufferStencilSize OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/RenderbufferObject.hs0000644000000000000000000000332212521420345026767 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObject -- Copyright : (c) Sven Panne 2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for (un-)marshaling RenderBufferObjects. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObject ( RenderbufferObject(..) ) where import Control.Monad.IO.Class import Data.ObjectName import Foreign.Marshal ( allocaArray, peekArray, withArrayLen ) import Graphics.Rendering.OpenGL.GL.DebugOutput import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- newtype RenderbufferObject = RenderbufferObject { renderbufferID :: GLuint} deriving ( Eq, Ord, Show ) instance ObjectName RenderbufferObject where isObjectName = liftIO . fmap unmarshalGLboolean . glIsRenderbuffer . renderbufferID deleteObjectNames objs = liftIO . withArrayLen (map renderbufferID objs) $ glDeleteRenderbuffers . fromIntegral instance GeneratableObjectName RenderbufferObject where genObjectNames n = liftIO . allocaArray n $ \buf -> do glGenRenderbuffers (fromIntegral n) buf fmap (map RenderbufferObject) $ peekArray n buf instance CanBeLabeled RenderbufferObject where objectLabel = objectNameLabel gl_RENDERBUFFER . renderbufferID OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/RenderbufferObjects.hs0000644000000000000000000000533512521420345027160 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObjects -- Copyright : (c) Sven Panne, Lars Corbijn 2011-2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- ----------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObjects ( RenderbufferObject, noRenderbufferObject, RenderbufferTarget(..), RenderbufferSize(..), Samples(..), bindRenderbuffer, renderbufferStorage, renderbufferStorageMultiSample, ) where import Data.StateVar import Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObject import Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferTarget import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.GL.Texturing.PixelInternalFormat import Graphics.Rendering.OpenGL.Raw ----------------------------------------------------------------------------- noRenderbufferObject :: RenderbufferObject noRenderbufferObject = RenderbufferObject 0 ----------------------------------------------------------------------------- data RenderbufferSize = RenderbufferSize !GLsizei !GLsizei deriving ( Eq, Ord, Show ) ----------------------------------------------------------------------------- bindRenderbuffer :: RenderbufferTarget -> StateVar RenderbufferObject bindRenderbuffer rbt = makeStateVar (getBoundRenderbuffer rbt) (setRenderbuffer rbt) marshalRenderbufferTargetBinding :: RenderbufferTarget -> PName1I marshalRenderbufferTargetBinding x = case x of Renderbuffer -> GetRenderbufferBinding getBoundRenderbuffer :: RenderbufferTarget -> IO RenderbufferObject getBoundRenderbuffer = getInteger1 (RenderbufferObject . fromIntegral) . marshalRenderbufferTargetBinding setRenderbuffer :: RenderbufferTarget -> RenderbufferObject -> IO () setRenderbuffer rbt = glBindRenderbuffer (marshalRenderbufferTarget rbt) . renderbufferID ----------------------------------------------------------------------------- renderbufferStorageMultiSample :: RenderbufferTarget -> Samples -> PixelInternalFormat -> RenderbufferSize -> IO () renderbufferStorageMultiSample rbt (Samples s) pif (RenderbufferSize w h) = glRenderbufferStorageMultisample (marshalRenderbufferTarget rbt) s (marshalPixelInternalFormat' pif) w h renderbufferStorage :: RenderbufferTarget -> PixelInternalFormat -> RenderbufferSize -> IO () renderbufferStorage rbt pif (RenderbufferSize w h) = glRenderbufferStorage (marshalRenderbufferTarget rbt) (marshalPixelInternalFormat' pif) w h OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/FramebufferObjectAttachment.hs0000644000000000000000000001070712521420345030620 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjectAttachment -- Copyright : (c) Sven Panne 2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for marshaling FrameBufferObjectAttachments. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjectAttachment ( FramebufferObjectAttachment(..), marshalFramebufferObjectAttachment, unmarshalFramebufferObjectAttachment, unmarshalFramebufferObjectAttachmentSafe, fboaToBufferMode, fboaFromBufferMode, FramebufferAttachment(..), getFBAParameteriv ) where import Data.Maybe import Foreign.Marshal import Graphics.Rendering.OpenGL.GL.BufferMode import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferTarget import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data FramebufferObjectAttachment = ColorAttachment !GLuint | DepthAttachment | StencilAttachment | DepthStencilAttachment deriving ( Eq, Ord, Show ) marshalFramebufferObjectAttachment :: FramebufferObjectAttachment -> Maybe GLenum marshalFramebufferObjectAttachment x = case x of ColorAttachment c -> let ec = fromIntegral c in if ec >= maxColorAttachments then Nothing else Just $ gl_COLOR_ATTACHMENT0 + ec DepthAttachment -> Just gl_DEPTH_ATTACHMENT StencilAttachment -> Just gl_STENCIL_ATTACHMENT DepthStencilAttachment -> Just gl_DEPTH_STENCIL_ATTACHMENT unmarshalFramebufferObjectAttachment :: GLenum -> FramebufferObjectAttachment unmarshalFramebufferObjectAttachment x = maybe (error $ "unmarshalFramebufferObjectAttachment: unknown enum value " ++ show x) id $ unmarshalFramebufferObjectAttachmentSafe x --unmarshalFramebufferObjectAttachment x -- | x == gl_DEPTH_ATTACHMENT = DepthAttachment -- | x == gl_STENCIL_ATTACHMENT = StencilAttachment -- | x == gl_DEPTH_STENCIL_ATTACHMENT = DepthStencilAttachment -- | x >= gl_COLOR_ATTACHMENT0 && x <= gl_COLOR_ATTACHMENT15 -- = ColorAttachment . fromIntegral $ x - gl_COLOR_ATTACHMENT0 -- | otherwise = error $ "unmarshalFramebufferObjectAttachment: unknown enum value " ++ show x unmarshalFramebufferObjectAttachmentSafe :: GLenum -> Maybe FramebufferObjectAttachment unmarshalFramebufferObjectAttachmentSafe x | x == gl_DEPTH_ATTACHMENT = Just DepthAttachment | x == gl_STENCIL_ATTACHMENT = Just StencilAttachment | x == gl_DEPTH_STENCIL_ATTACHMENT = Just DepthStencilAttachment | x >= gl_COLOR_ATTACHMENT0 && x <= gl_COLOR_ATTACHMENT0 + maxColorAttachments = Just . ColorAttachment . fromIntegral $ x - gl_COLOR_ATTACHMENT0 | otherwise = Nothing fboaToBufferMode :: FramebufferObjectAttachment -> Maybe BufferMode fboaToBufferMode (ColorAttachment i) = Just . FBOColorAttachment $ fromIntegral i fboaToBufferMode _ = Nothing fboaFromBufferMode :: BufferMode -> Maybe FramebufferObjectAttachment fboaFromBufferMode (FBOColorAttachment i) = Just . ColorAttachment $ fromIntegral i fboaFromBufferMode _ = Nothing ----------------------------------------------------------------------------- class Show a => FramebufferAttachment a where marshalAttachment :: a -> Maybe GLenum unmarshalAttachment :: GLenum -> a unmarshalAttachmentSafe :: GLenum -> Maybe a instance FramebufferAttachment FramebufferObjectAttachment where marshalAttachment = marshalFramebufferObjectAttachment unmarshalAttachment = unmarshalFramebufferObjectAttachment unmarshalAttachmentSafe = unmarshalFramebufferObjectAttachmentSafe instance FramebufferAttachment BufferMode where marshalAttachment = marshalBufferMode unmarshalAttachment = unmarshalBufferMode unmarshalAttachmentSafe = unmarshalBufferModeSafe ----------------------------------------------------------------------------- getFBAParameteriv :: FramebufferAttachment fba => FramebufferTarget -> fba -> (GLint -> a) -> GLenum -> IO a getFBAParameteriv fbt fba f p = with 0 $ \buf -> do glGetFramebufferAttachmentParameteriv (marshalFramebufferTarget fbt) mfba p buf peek1 f buf where mfba = fromMaybe (error $ "invalid value" ++ show fba) (marshalAttachment fba) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/FramebufferTarget.hs0000644000000000000000000000212512521420345026622 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferTarget -- Copyright : (c) Sven Panne 2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for marshaling FrameBufferTargets. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferTarget ( FramebufferTarget(..), marshalFramebufferTarget ) where import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data FramebufferTarget = DrawFramebuffer | ReadFramebuffer | Framebuffer deriving ( Eq, Ord, Show ) marshalFramebufferTarget :: FramebufferTarget -> GLenum marshalFramebufferTarget xs = case xs of DrawFramebuffer -> gl_DRAW_FRAMEBUFFER ReadFramebuffer -> gl_READ_FRAMEBUFFER Framebuffer -> gl_FRAMEBUFFER OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/RenderbufferTarget.hs0000644000000000000000000000273112521420345027012 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferTarget -- Copyright : (c) Sven Panne 2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for handling RenderbufferTargets. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferTarget ( RenderbufferTarget(..), marshalRenderbufferTarget, getRBParameteriv, Samples(..) ) where import Foreign.Marshal import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- data RenderbufferTarget = Renderbuffer deriving ( Eq, Ord, Show ) marshalRenderbufferTarget :: RenderbufferTarget -> GLenum marshalRenderbufferTarget x = case x of Renderbuffer -> gl_RENDERBUFFER ----------------------------------------------------------------------------- getRBParameteriv :: RenderbufferTarget -> (GLint -> a) -> GLenum -> IO a getRBParameteriv rbt f p = with 0 $ \buf -> do glGetRenderbufferParameteriv (marshalRenderbufferTarget rbt) p buf peek1 f buf ----------------------------------------------------------------------------- newtype Samples = Samples GLsizei deriving ( Eq, Ord, Show ) OpenGL-2.12.0.1/src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/FramebufferObject.hs0000644000000000000000000000331012521420345026577 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObject -- Copyright : (c) Sven Panne 2013 -- License : BSD3 -- -- Maintainer : Sven Panne -- Stability : stable -- Portability : portable -- -- This is a purely internal module for handling FrameBufferObjects. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObject ( FramebufferObject(..) ) where import Control.Monad.IO.Class import Data.ObjectName import Foreign.Marshal.Array ( allocaArray, peekArray, withArrayLen ) import Graphics.Rendering.OpenGL.GL.DebugOutput import Graphics.Rendering.OpenGL.GL.GLboolean import Graphics.Rendering.OpenGL.GL.QueryUtils import Graphics.Rendering.OpenGL.Raw -------------------------------------------------------------------------------- newtype FramebufferObject = FramebufferObject { framebufferID :: GLuint } deriving ( Eq, Ord, Show ) instance ObjectName FramebufferObject where isObjectName = liftIO . fmap unmarshalGLboolean . glIsFramebuffer . framebufferID deleteObjectNames objs = liftIO . withArrayLen (map framebufferID objs) $ glDeleteFramebuffers . fromIntegral instance GeneratableObjectName FramebufferObject where genObjectNames n = liftIO . allocaArray n $ \buf -> do glGenFramebuffers (fromIntegral n) buf fmap (map FramebufferObject) $ peekArray n buf instance CanBeLabeled FramebufferObject where objectLabel = objectNameLabel gl_FRAMEBUFFER . framebufferID