RenderTargetIterator;
-
- {-| Returns a specialised MapIterator over all render targets attached to the RenderSystem. -}
- -- TODO: virtual RenderTargetIterator getRenderTargetIterator(void) {
- -- TODO: return RenderTargetIterator( mRenderTargets.begin(), mRenderTargets.end() );
- -- TODO: }
-
- {-| Returns a description of an error code.
- -}
- -- TODO: virtual String getErrorDescription(long errorNumber) const = 0;
-
- {-| Defines whether or now fullscreen render windows wait for the vertical blank before flipping buffers.
- @remarks
- By default, all rendering windows wait for a vertical blank (when the CRT beam turns off briefly to move
- from the bottom right of the screen back to the top left) before flipping the screen buffers. This ensures
- that the image you see on the screen is steady. However it restricts the frame rate to the refresh rate of
- the monitor, and can slow the frame rate down. You can speed this up by not waiting for the blank, but
- this has the downside of introducing 'tearing' artefacts where part of the previous frame is still displayed
- as the buffers are switched. Speed vs quality, you choose.
- @note
- Has NO effect on windowed mode render targets. Only affects fullscreen mode.
- @param
- enabled If true, the system waits for vertical blanks - quality over speed. If false it doesn't - speed over quality.
- -}
- setWaitForVerticalBlank :: a -> Bool -> IO ()
--- getWaitForVerticalBlank :: a -> IO Bool -- ^ Returns true if the system is synchronising frames with the monitor vertical blank.
-
- -- ------------------------------------------------------------------------
- -- Internal Rendering Access
- -- All methods below here are normally only called by other OGRE classes
- -- They can be called by library user if required
- -- ------------------------------------------------------------------------
-
-
- {-| Tells the rendersystem to use the attached set of lights (and no others)
- up to the number specified (this allows the same list to be used with different
- count limits) -}
- useLights :: a -> [(Matrix4,Light)] -> IO ()
--- useLights :: a -> [Light] -> Int -> IO ()
- {-| Are fixed-function lights provided in view space? Affects optimisation.
- -}
- -- TODO: virtual bool areFixedFunctionLightsInViewSpace() const { return false; }
- setWorldMatrix :: a -> Matrix4 -> IO () -- ^ Sets the world transform matrix.
- --_setWorldMatrices :: a -> [Matrix4] -> Int -> IO () -- ^ Sets multiple world matrices (vertex blending).
- setViewMatrix :: a -> Matrix4 -> IO () -- ^ Sets the view transform matrix
- setProjectionMatrix :: a -> Matrix4 -> IO () -- ^ Sets the projection transform matrix
-
- {-| Sets the surface properties to be used for future rendering.
-
- This method sets the the properties of the surfaces of objects
- to be rendered after it. In this context these surface properties
- are the amount of each type of light the object reflects (determining
- it's colour under different types of light), whether it emits light
- itself, and how shiny it is. Textures are not dealt with here,
- see the _setTetxure method for details.
- This method is used by _setMaterial so does not need to be called
- direct if that method is being used.
-
- @param ambient The amount of ambient (sourceless and directionless)
- light an object reflects. Affected by the colour/amount of ambient light in the scene.
- @param diffuse The amount of light from directed sources that is
- reflected (affected by colour/amount of point, directed and spot light sources)
- @param specular The amount of specular light reflected. This is also
- affected by directed light sources but represents the colour at the
- highlights of the object.
- @param emissive The colour of light emitted from the object. Note that
- this will make an object seem brighter and not dependent on lights in
- the scene, but it will not act as a light, so will not illuminate other
- objects. Use a light attached to the same SceneNode as the object for this purpose.
- @param shininess A value which only has an effect on specular highlights (so
- specular must be non-black). The higher this value, the smaller and crisper the
- specular highlights will be, imitating a more highly polished surface.
- This value is not constrained to 0.0-1.0, in fact it is likely to
- be more (10.0 gives a modest sheen to an object).
- @param tracking A bit field that describes which of the ambient, diffuse, specular
- and emissive colours follow the vertex colour of the primitive. When a bit in this field is set
- its ColourValue is ignored. This is a combination of TVC_AMBIENT, TVC_DIFFUSE, TVC_SPECULAR(note that the shininess value is still
- taken from shininess) and TVC_EMISSIVE. TVC_NONE means that there will be no material property
- tracking the vertex colours.
- -}
- setSurfaceParams :: a -> ColourValue -> ColourValue -> ColourValue -> ColourValue -> FloatType -> TrackVertexColourType -> IO ()
-
- {-| Sets whether or not rendering points using OT_POINT_LIST will
- render point sprites (textured quads) or plain points.
- @param enabled True enables point sprites, false returns to normal
- point rendering.
- -}
- setPointSpritesEnabled :: a -> Bool -> IO ()
-
- {-| Sets the size of points and how they are attenuated with distance.
- @remarks
- When performing point rendering or point sprite rendering,
- point size can be attenuated with distance. The equation for
- doing this is attenuation = 1 / (constant + linear * dist + quadratic * d^2) .
- @par
- For example, to disable distance attenuation (constant screensize)
- you would set constant to 1, and linear and quadratic to 0. A
- standard perspective attenuation would be 0, 1, 0 respectively.
- -}
- setPointParameters :: a -> FloatType -> Bool -> FloatType -> FloatType -> FloatType -> FloatType -> FloatType -> IO ()
-
-
- setActiveTextureUnit :: a -> Int -> IO ()
- {-|
- Sets the texture to bind to a given texture unit.
-
- User processes would not normally call this direct unless rendering
- primitives themselves.
-
- @param unit The index of the texture unit to modify. Multitexturing
- hardware can support multiple units (see
- RenderSystemCapabilites::getNumTextureUnits)
- @param enabled Boolean to turn the unit on/off
- @param texPtr Pointer to the texture to use.
- -}
--- setTexture :: a -> Int -> Bool -> Maybe t -> IO ()
- setTexture :: a -> Maybe t -> IO ()
- {-|
- Sets the texture to bind to a given texture unit.
-
- User processes would not normally call this direct unless rendering
- primitives themselves.
-
- @param unit The index of the texture unit to modify. Multitexturing
- hardware can support multiple units (see
- RenderSystemCapabilites::getNumTextureUnits)
- @param enabled Boolean to turn the unit on/off
- @param texname The name of the texture to use - this should have
- already been loaded with TextureManager::load.
- -}
- --virtual void _setTexture(size_t unit, bool enabled, const String &texname);
-
- {-| Binds a texture to a vertex sampler.
- @remarks
- Not all rendersystems support separate vertex samplers. For those that
- do, you can set a texture for them, separate to the regular texture
- samplers, using this method. For those that don't, you should use the
- regular texture samplers which are shared between the vertex and
- fragment units; calling this method will throw an exception.
- @see RenderSystemCapabilites::getVertexTextureUnitsShared
- -}
- setVertexTexture :: a -> Maybe t -> IO ()
-
- {-|
- Sets the texture coordinate set to use for a texture unit.
-
- Meant for use internally - not generally used directly by apps - the Material and TextureUnitState
- classes let you manage textures far more easily.
-
- @param unit Texture unit as above
- @param index The index of the texture coordinate set to use.
- -}
--- setTextureCoordSet :: a -> Int -> Int -> IO ()
-
- {-|
- Sets a method for automatically calculating texture coordinates for a stage.
- Should not be used by apps - for use by Ogre only.
- @param unit Texture unit as above
- @param m Calculation method to use
- @param frustum Optional Frustum param, only used for projective effects
- -}
- setTextureCoordCalculation :: a -> TexCoordCalcMethod{- -> Frustum-} -> IO ()
-
- {-| Sets the texture blend modes from a TextureUnitState record.
- Meant for use internally only - apps should use the Material
- and TextureUnitState classes.
- @param unit Texture unit as above
- @param bm Details of the blending mode
- -}
- setTextureBlendMode :: a -> LayerBlendModeEx -> LayerBlendModeEx -> IO ()
-
- {-| Sets the filtering options for a given texture unit.
- @param unit The texture unit to set the filtering options for
- @param minFilter The filter used when a texture is reduced in size
- @param magFilter The filter used when a texture is magnified
- @param mipFilter The filter used between mipmap levels, FO_NONE disables mipmapping
- -}
- setTextureUnitFiltering :: a -> TextureType -> FilterOptions -> FilterOptions -> FilterOptions -> IO ()
-
- {-| Sets a single filter for a given texture unit.
- @param unit The texture unit to set the filtering options for
- @param ftype The filter type
- @param filter The filter to be used
- -}
--- setTextureUnitFiltering :: a -> Int -> FilterType -> FilterOptions -> IO ()
-
- {-| Sets the maximal anisotropy for the specified texture unit.-}
- setTextureLayerAnisotropy :: a -> TextureType -> Int -> IO ()
-
- {-| Sets the texture addressing mode for a texture unit.-}
- setTextureAddressingMode :: a -> TextureType -> UVWAddressingMode -> IO ()
-
- {-| Sets the texture border colour for a texture unit.-}
- setTextureBorderColour :: a -> TextureType -> ColourValue -> IO ()
-
- {-| Sets the mipmap bias value for a given texture unit.
- @remarks
- This allows you to adjust the mipmap calculation up or down for a
- given texture unit. Negative values force a larger mipmap to be used,
- positive values force a smaller mipmap to be used. Units are in numbers
- of levels, so +1 forces the mipmaps to one smaller level.
- @note Only does something if render system has capability RSC_MIPMAP_LOD_BIAS.
- -}
- setTextureMipmapBias :: a -> FloatType -> IO ()
-
- {-| Sets the texture coordinate transformation matrix for a texture unit.
- @param unit Texture unit to affect
- @param xform The 4x4 matrix
- -}
- setTextureMatrix :: a -> Matrix4 -> IO ()
-
- {-| Sets the global blending factors for combining subsequent renders with the existing frame contents.
- The result of the blending operation is:
- final = (texture * sourceFactor) + (pixel * destFactor)
- Each of the factors is specified as one of a number of options, as specified in the SceneBlendFactor
- enumerated type.
- By changing the operation you can change addition between the source and destination pixels to a different operator.
- @param sourceFactor The source factor in the above calculation, i.e. multiplied by the texture colour components.
- @param destFactor The destination factor in the above calculation, i.e. multiplied by the pixel colour components.
- @param op The blend operation mode for combining pixels
- -}
- setSceneBlending :: a -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendOperation -> IO ()
-
- {-| Sets the global blending factors for combining subsequent renders with the existing frame contents.
- The result of the blending operation is:
- final = (texture * sourceFactor) + (pixel * destFactor)
- Each of the factors is specified as one of a number of options, as specified in the SceneBlendFactor
- enumerated type.
- @param sourceFactor The source factor in the above calculation, i.e. multiplied by the texture colour components.
- @param destFactor The destination factor in the above calculation, i.e. multiplied by the pixel colour components.
- @param sourceFactorAlpha The source factor in the above calculation for the alpha channel, i.e. multiplied by the texture alpha components.
- @param destFactorAlpha The destination factor in the above calculation for the alpha channel, i.e. multiplied by the pixel alpha components.
- @param op The blend operation mode for combining pixels
- @param alphaOp The blend operation mode for combining pixel alpha values
- -}
- setSeparateSceneBlending :: a -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendOperation -> SceneBlendOperation -> IO ()
-
- {-| Sets the global alpha rejection approach for future renders.
- By default images are rendered regardless of texture alpha. This method lets you change that.
- @param func The comparison function which must pass for a pixel to be written.
- @param val The value to compare each pixels alpha value to (0-255)
- @param alphaToCoverage Whether to enable alpha to coverage, if supported
- -}
- setAlphaRejectSettings :: a -> CompareFunction -> Int -> Bool -> IO ()
-
- {-| Notify the rendersystem that it should adjust texture projection to be
- relative to a different origin.
- -}
- -- TODO: virtual void _setTextureProjectionRelativeTo(bool enabled, const Vector3& pos);
- {-|
- * Signifies the beginning of a frame, i.e. the start of rendering on a single viewport. Will occur
- * several times per complete frame if multiple viewports exist.
- -}
- -- TODO: virtual void _beginFrame(void) = 0;
-
-
- {-|
- * Ends rendering of a frame to the current viewport.
- -}
- -- TODO: virtual void _endFrame(void) = 0;
- {-|
- Sets the provided viewport as the active one for future
- rendering operations. This viewport is aware of it's own
- camera and render target. Must be implemented by subclass.
-
- @param target Pointer to the appropriate viewport.
- -}
- setViewport :: a -> Int -> Int -> Int -> Int -> IO ()
- {-| Get the current active viewport for rendering. -}
- -- TODO: virtual Viewport* _getViewport(void);
-
- {-| Sets the culling mode for the render system based on the 'vertex winding'.
- A typical way for the rendering engine to cull triangles is based on the
- 'vertex winding' of triangles. Vertex winding refers to the direction in
- which the vertices are passed or indexed to in the rendering operation as viewed
- from the camera, and will wither be clockwise or anticlockwise (that's 'counterclockwise' for
- you Americans out there ;) The default is CULL_CLOCKWISE i.e. that only triangles whose vertices
- are passed/indexed in anticlockwise order are rendered - this is a common approach and is used in 3D studio models
- for example. You can alter this culling mode if you wish but it is not advised unless you know what you are doing.
- You may wish to use the CULL_NONE option for mesh data that you cull yourself where the vertex
- winding is uncertain.
- -}
- setCullingMode :: a -> CullingMode -> IO ()
--- getCullingMode :: a -> IO CullingMode
-
- {-| Sets the mode of operation for depth buffer tests from this point onwards.
- Sometimes you may wish to alter the behaviour of the depth buffer to achieve
- special effects. Because it's unlikely that you'll set these options for an entire frame,
- but rather use them to tweak settings between rendering objects, this is an internal
- method (indicated by the '_' prefix) which will be used by a SceneManager implementation
- rather than directly from the client application.
- If this method is never called the settings are automatically the same as the default parameters.
- @param depthTest If true, the depth buffer is tested for each pixel and the frame buffer is only updated
- if the depth function test succeeds. If false, no test is performed and pixels are always written.
- @param depthWrite If true, the depth buffer is updated with the depth of the new pixel if the depth test succeeds.
- If false, the depth buffer is left unchanged even if a new pixel is written.
- @param depthFunction Sets the function required for the depth test.
- -}
- setDepthBufferParams :: a -> Bool -> Bool -> CompareFunction -> IO ()
-
- {-| Sets whether or not the depth buffer check is performed before a pixel write.
- @param enabled If true, the depth buffer is tested for each pixel and the frame buffer is only updated
- if the depth function test succeeds. If false, no test is performed and pixels are always written.
- -}
- setDepthBufferCheckEnabled :: a -> Bool -> IO ()
- {-| Sets whether or not the depth buffer is updated after a pixel write.
- @param enabled If true, the depth buffer is updated with the depth of the new pixel if the depth test succeeds.
- If false, the depth buffer is left unchanged even if a new pixel is written.
- -}
- setDepthBufferWriteEnabled :: a -> Bool -> IO ()
- {-| Sets the comparison function for the depth buffer check.
- Advanced use only - allows you to choose the function applied to compare the depth values of
- new and existing pixels in the depth buffer. Only an issue if the deoth buffer check is enabled
- (see _setDepthBufferCheckEnabled)
- @param func The comparison between the new depth and the existing depth which must return true
- for the new pixel to be written.
- -}
- --setDepthBufferFunction :: a -> CompareFunction -> IO ()
- setDepthBufferFunction :: a -> Bool -> CompareFunction -> IO ()
- {-| Sets whether or not colour buffer writing is enabled, and for which channels.
- @remarks
- For some advanced effects, you may wish to turn off the writing of certain colour
- channels, or even all of the colour channels so that only the depth buffer is updated
- in a rendering pass. However, the chances are that you really want to use this option
- through the Material class.
- @param red, green, blue, alpha Whether writing is enabled for each of the 4 colour channels. -}
- setColourBufferWriteEnabled :: a -> Bool -> Bool -> Bool -> Bool -> IO ()
- {-| Sets the depth bias, NB you should use the Material version of this.
- @remarks
- When polygons are coplanar, you can get problems with 'depth fighting' where
- the pixels from the two polys compete for the same screen pixel. This is particularly
- a problem for decals (polys attached to another surface to represent details such as
- bulletholes etc.).
- @par
- A way to combat this problem is to use a depth bias to adjust the depth buffer value
- used for the decal such that it is slightly higher than the true value, ensuring that
- the decal appears on top.
- @note
- The final bias value is a combination of a constant bias and a bias proportional
- to the maximum depth slope of the polygon being rendered. The final bias
- is constantBias + slopeScaleBias * maxslope. Slope scale biasing is
- generally preferable but is not available on older hardware.
- @param constantBias The constant bias value, expressed as a value in
- homogeneous depth coordinates.
- @param slopeScaleBias The bias value which is factored by the maximum slope
- of the polygon, see the description above. This is not supported by all
- cards.
-
- -}
- setDepthBias :: a -> FloatType -> FloatType -> IO ()
- {-| Sets the fogging mode for future geometry.
- @param mode Set up the mode of fog as described in the FogMode enum, or set to FOG_NONE to turn off.
- @param colour The colour of the fog. Either set this to the same as your viewport background colour,
- or to blend in with a skydome or skybox.
- @param expDensity The density of the fog in FOG_EXP or FOG_EXP2 mode, as a value between 0 and 1. The default is 1. i.e. completely opaque, lower values can mean
- that fog never completely obscures the scene.
- @param linearStart Distance at which linear fog starts to encroach. The distance must be passed
- as a parametric value between 0 and 1, with 0 being the near clipping plane, and 1 being the far clipping plane. Only applicable if mode is FOG_LINEAR.
- @param linearEnd Distance at which linear fog becomes completely opaque.The distance must be passed
- as a parametric value between 0 and 1, with 0 being the near clipping plane, and 1 being the far clipping plane. Only applicable if mode is FOG_LINEAR.
- -}
- setFog :: a -> FogMode -> ColourValue -> FloatType -> FloatType -> FloatType -> IO ()
-
- {-| The RenderSystem will keep a count of tris rendered, this resets the count. -}
- -- TODO: virtual void _beginGeometryCount(void);
- {-| Reports the number of tris rendered since the last _beginGeometryCount call. -}
- -- TODO: virtual unsigned int _getFaceCount(void) const;
- {-| Reports the number of batches rendered since the last _beginGeometryCount call. -}
- -- TODO: virtual unsigned int _getBatchCount(void) const;
- {-| Reports the number of vertices passed to the renderer since the last _beginGeometryCount call. -}
- -- TODO: virtual unsigned int _getVertexCount(void) const;
-
- {-| Generates a packed data version of the passed in ColourValue suitable for
- use as with this RenderSystem.
- @remarks
- Since different render systems have different colour data formats (eg
- RGBA for GL, ARGB for D3D) this method allows you to use 1 method for all.
- @param colour The colour to convert
- @param pDest Pointer to location to put the result.
- -}
- -- TODO: virtual void convertColourValue(const ColourValue& colour, uint32* pDest);
- {-| Get the native VertexElementType for a compact 32-bit colour value
- for this rendersystem.
- -}
- -- TODO: virtual VertexElementType getColourVertexElementType(void) const = 0;
-
- {-| Converts a uniform projection matrix to suitable for this render system.
- @remarks
- Because different APIs have different requirements (some incompatible) for the
- projection matrix, this method allows each to implement their own correctly and pass
- back a generic OGRE matrix for storage in the engine.
- -}
- -- TODO: virtual void _convertProjectionMatrix(const Matrix4& matrix,
- -- TODO: Matrix4& dest, bool forGpuProgram = false) = 0;
-
- {-| Builds a perspective projection matrix suitable for this render system.
- @remarks
- Because different APIs have different requirements (some incompatible) for the
- projection matrix, this method allows each to implement their own correctly and pass
- back a generic OGRE matrix for storage in the engine.
- -}
- -- TODO: virtual void _makeProjectionMatrix(const Radian& fovy, Real aspect, Real nearPlane, Real farPlane,
- -- TODO: Matrix4& dest, bool forGpuProgram = false) = 0;
-
- {-| Builds a perspective projection matrix for the case when frustum is
- not centered around camera.
- @remarks
- Viewport coordinates are in camera coordinate frame, i.e. camera is
- at the origin.
- -}
- -- TODO: virtual void _makeProjectionMatrix(Real left, Real right, Real bottom, Real top,
- -- TODO: Real nearPlane, Real farPlane, Matrix4& dest, bool forGpuProgram = false) = 0;
- {-| Builds an orthographic projection matrix suitable for this render system.
- @remarks
- Because different APIs have different requirements (some incompatible) for the
- projection matrix, this method allows each to implement their own correctly and pass
- back a generic OGRE matrix for storage in the engine.
- -}
- -- TODO: virtual void _makeOrthoMatrix(const Radian& fovy, Real aspect, Real nearPlane, Real farPlane,
- -- TODO: Matrix4& dest, bool forGpuProgram = false) = 0;
-
- {-| Update a perspective projection matrix to use 'oblique depth projection'.
- @remarks
- This method can be used to change the nature of a perspective
- transform in order to make the near plane not perpendicular to the
- camera view direction, but to be at some different orientation.
- This can be useful for performing arbitrary clipping (e.g. to a
- reflection plane) which could otherwise only be done using user
- clip planes, which are more expensive, and not necessarily supported
- on all cards.
- @param matrix The existing projection matrix. Note that this must be a
- perspective transform (not orthographic), and must not have already
- been altered by this method. The matrix will be altered in-place.
- @param plane The plane which is to be used as the clipping plane. This
- plane must be in CAMERA (view) space.
- @param forGpuProgram Is this for use with a Gpu program or fixed-function
- -}
- -- TODO: virtual void _applyObliqueDepthProjection(Matrix4& matrix, const Plane& plane,
- -- TODO: bool forGpuProgram) = 0;
-
- {-| Sets how to rasterise triangles, as points, wireframe or solid polys. -}
- setPolygonMode :: a -> PolygonMode -> IO ()
-
- {-| Turns stencil buffer checking on or off.
- @remarks
- Stencilling (masking off areas of the rendering target based on the stencil
- buffer) can be turned on or off using this method. By default, stencilling is
- disabled.
- -}
- setStencilCheckEnabled :: a -> Bool -> IO ()
- {-| Determines if this system supports hardware accelerated stencil buffer.
- @remarks
- Note that the lack of this function doesn't mean you can't do stencilling, but
- the stencilling operations will be provided in software, which will NOT be
- fast.
- @par
- Generally hardware stencils are only supported in 32-bit colour modes, because
- the stencil buffer shares the memory of the z-buffer, and in most cards the
- z-buffer has to be the same depth as the colour buffer. This means that in 32-bit
- mode, 24 bits of the z-buffer are depth and 8 bits are stencil. In 16-bit mode there
- is no room for a stencil (although some cards support a 15:1 depth:stencil option,
- this isn't useful for very much) so 8 bits of stencil are provided in software.
- This can mean that if you use stencilling, your applications may be faster in
- 32-but colour than in 16-bit, which may seem odd to some people.
- -}
- {-virtual bool hasHardwareStencil(void) = 0;-}
-
- {-| This method allows you to set all the stencil buffer parameters in one call.
- @remarks
- The stencil buffer is used to mask out pixels in the render target, allowing
- you to do effects like mirrors, cut-outs, stencil shadows and more. Each of
- your batches of rendering is likely to ignore the stencil buffer,
- update it with new values, or apply it to mask the output of the render.
- The stencil test is:
- (Reference Value & Mask) CompareFunction (Stencil Buffer Value & Mask)
- The result of this will cause one of 3 actions depending on whether the test fails,
- succeeds but with the depth buffer check still failing, or succeeds with the
- depth buffer check passing too.
- @par
- Unlike other render states, stencilling is left for the application to turn
- on and off when it requires. This is because you are likely to want to change
- parameters between batches of arbitrary objects and control the ordering yourself.
- In order to batch things this way, you'll want to use OGRE's separate render queue
- groups (see RenderQueue) and register a RenderQueueListener to get notifications
- between batches.
- @par
- There are individual state change methods for each of the parameters set using
- this method.
- Note that the default values in this method represent the defaults at system
- start up too.
- @param func The comparison function applied.
- @param refValue The reference value used in the comparison
- @param mask The bitmask applied to both the stencil value and the reference value
- before comparison
- @param stencilFailOp The action to perform when the stencil check fails
- @param depthFailOp The action to perform when the stencil check passes, but the
- depth buffer check still fails
- @param passOp The action to take when both the stencil and depth check pass.
- @param twoSidedOperation If set to true, then if you render both back and front faces
- (you'll have to turn off culling) then these parameters will apply for front faces,
- and the inverse of them will happen for back faces (keep remains the same).
- -}
- setStencilBufferParams :: a -> CompareFunction -> Word32 -> Word32 -> StencilOperation -> StencilOperation -> StencilOperation -> Bool -> IO ()
-
-
-
- {-| Sets the current vertex declaration, ie the source of vertex data. -}
--- setVertexDeclaration :: a -> VertexDeclaration -> IO ()
- {-| Sets the current vertex buffer binding state. -}
--- setVertexBufferBinding :: a -> VertexBufferBinding vb -> IO ()
-
- {-| Sets whether or not normals are to be automatically normalised.
- @remarks
- This is useful when, for example, you are scaling SceneNodes such that
- normals may not be unit-length anymore. Note though that this has an
- overhead so should not be turn on unless you really need it.
- @par
- You should not normally call this direct unless you are rendering
- world geometry; set it on the Renderable because otherwise it will be
- overridden by material settings.
- -}
- setNormaliseNormals :: a -> Bool -> IO ()
-
- {-|
- Render something to the active viewport.
-
- Low-level rendering interface to perform rendering
- operations. Unlikely to be used directly by client
- applications, since the SceneManager and various support
- classes will be responsible for calling this method.
- Can only be called between _beginScene and _endScene
-
- @param Iteration count
- @param op A rendering operation instance, which contains
- details of the operation to be performed.
- -}
- render :: a -> RenderOperation vb ib -> IO ()
- bindGeometry :: a -> RenderOperation vb ib -> [TextureUnitState t] -> IO ()
- unbindGeometry :: a -> RenderOperation vb ib -> IO ()
-
- {-| Gets the capabilities of the render system. -}
- getCapabilities :: a -> RenderSystemCapabilities
-
- {-| Binds a given GpuProgram (but not the parameters).
- @remarks Only one GpuProgram of each type can be bound at once, binding another
- one will simply replace the existing one.
- -}
- bindLinkedGpuProgram :: a -> lp -> IO ()
--- bindGpuProgram :: a -> GpuProgram -> IO ()
-
- {-| Bind Gpu program parameters.
- @param gptype The type of program to bind the parameters to
- @param params The parameters to bind
- @param variabilityMask A mask of GpuParamVariability identifying which params need binding
- -}
--- bindGpuProgramParameters :: a -> GpuProgramType -> GpuProgramParameters -> Word16 -> IO ()
-
- {-| Only binds Gpu program parameters used for passes that have more than one iteration rendering
- -}
--- bindGpuProgramPassIterationParameters :: a -> GpuProgramType -> IO ()
- {-| Unbinds GpuPrograms of a given GpuProgramType.
- @remarks
- This returns the pipeline to fixed-function processing for this type.
- -}
- unbindLinkedGpuProgram :: a -> IO ()
--- unbindGpuProgram :: a -> GpuProgramType -> IO ()
-
- {-| Returns whether or not a Gpu program of the given type is currently bound. -}
--- isGpuProgramBound :: a -> GpuProgramType -> IO Bool
-
- {-| Sets the user clipping region.
- -}
- -- TODO: virtual void setClipPlanes(const PlaneList& clipPlanes);
-
- {-| Add a user clipping plane. -}
- -- TODO: virtual void addClipPlane (const Plane &p);
- {-| Add a user clipping plane. -}
- -- TODO: virtual void addClipPlane (Real A, Real B, Real C, Real D);
-
- {-| Clears the user clipping region.
- -}
- -- TODO: virtual void resetClipPlanes();
-
- {-| Utility method for initialising all render targets attached to this rendering system. -}
- -- TODO: virtual void _initRenderTargets(void);
-
- {-| Utility method to notify all render targets that a camera has been removed,
- in case they were referring to it as their viewer.
- -}
- -- TODO: virtual void _notifyCameraRemoved(const Camera* cam);
-
- {-| Internal method for updating all render targets attached to this rendering system. -}
- -- TODO: virtual void _updateAllRenderTargets(bool swapBuffers = true);
- {-| Internal method for swapping all the buffers on all render targets,
- if _updateAllRenderTargets was called with a 'false' parameter. -}
- -- TODO: virtual void _swapAllRenderTargetBuffers(bool waitForVsync = true);
-
- {-| Gets whether or not vertex windings set should be inverted; this can be important
- for rendering reflections. -}
- -- TODO: virtual bool getInvertVertexWinding(void);
-
- {-| Sets whether or not vertex windings set should be inverted; this can be important
- for rendering reflections. -}
- -- TODO: virtual void setInvertVertexWinding(bool invert);
- {-| Sets the 'scissor region' ie the region of the target in which rendering can take place.
- @remarks
- This method allows you to 'mask off' rendering in all but a given rectangular area
- as identified by the parameters to this method.
- @note
- Not all systems support this method. Check the RenderSystemCapabilities for the
- RSC_SCISSOR_TEST capability to see if it is supported.
- @param enabled True to enable the scissor test, false to disable it.
- @param left, top, right, bottom The location of the corners of the rectangle, expressed in
- pixels.
- -}
- setScissorTest :: a -> Bool -> Int -> Int -> Int -> Int -> IO ()
-
- {-| Clears one or more frame buffers on the active render target.
- @param buffers Combination of one or more elements of FrameBufferType
- denoting which buffers are to be cleared
- @param colour The colour to clear the colour buffer with, if enabled
- @param depth The value to initialise the depth buffer with, if enabled
- @param stencil The value to initialise the stencil buffer with, if enabled.
- -}
- clearFrameBuffer :: a -> FrameBufferType -> ColourValue -> FloatType -> Word16 -> IO ()
- {-| Returns the horizontal texel offset value required for mapping
- texel origins to pixel origins in this rendersystem.
- @remarks
- Since rendersystems sometimes disagree on the origin of a texel,
- mapping from texels to pixels can sometimes be problematic to
- implement generically. This method allows you to retrieve the offset
- required to map the origin of a texel to the origin of a pixel in
- the horizontal direction.
- -}
- getHorizontalTexelOffset :: a -> IO FloatType
- {-| Returns the vertical texel offset value required for mapping
- texel origins to pixel origins in this rendersystem.
- @remarks
- Since rendersystems sometimes disagree on the origin of a texel,
- mapping from texels to pixels can sometimes be problematic to
- implement generically. This method allows you to retrieve the offset
- required to map the origin of a texel to the origin of a pixel in
- the vertical direction.
- -}
- getVerticalTexelOffset :: a -> IO FloatType
-
- {-| Gets the minimum (closest) depth value to be used when rendering
- using identity transforms.
- @remarks
- When using identity transforms you can manually set the depth
- of a vertex; however the input values required differ per
- rendersystem. This method lets you retrieve the correct value.
- @see Renderable::getUseIdentityView, Renderable::getUseIdentityProjection
- -}
- getMinimumDepthInputValue :: a -> FloatType
- {-| Gets the maximum (farthest) depth value to be used when rendering
- using identity transforms.
- @remarks
- When using identity transforms you can manually set the depth
- of a vertex; however the input values required differ per
- rendersystem. This method lets you retrieve the correct value.
- @see Renderable::getUseIdentityView, Renderable::getUseIdentityProjection
- -}
- getMaximumDepthInputValue :: a -> FloatType
- {-| set the current multi pass count value. This must be set prior to
- calling _render() if multiple renderings of the same pass state are
- required.
- @param count Number of times to render the current state.
- -}
- -- TODO: virtual void setCurrentPassIterationCount(const size_t count) { mCurrentPassIterationCount = count; }
-
- {-| Tell the render system whether to derive a depth bias on its own based on
- the values passed to it in setCurrentPassIterationCount.
- The depth bias set will be baseValue + iteration * multiplier
- @param derive True to tell the RS to derive this automatically
- @param baseValue The base value to which the multiplier should be
- added
- @param multiplier The amount of depth bias to apply per iteration
- @param slopeScale The constant slope scale bias for completeness
- -}
- -- TODO: virtual void setDeriveDepthBias(bool derive, float baseValue = 0.0f,
- -- TODO: float multiplier = 0.0f, float slopeScale = 0.0f)
- -- TODO: {
- -- TODO: mDerivedDepthBias = derive;
- -- TODO: mDerivedDepthBiasBase = baseValue;
- -- TODO: mDerivedDepthBiasMultiplier = multiplier;
- -- TODO: mDerivedDepthBiasSlopeScale = slopeScale;
- -- TODO: }
-
- {-|
- * Set current render target to target, enabling its device context if needed
- -}
- -- TODO: virtual void _setRenderTarget(RenderTarget *target) = 0;
-
-class (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => Renderable r vb ib t lp | r -> vb ib t lp where
- prepare :: Matrix4 -> r -> [RenderEntity vb ib t lp]
-
-data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => RenderEntity vb ib t lp
- = RenderEntity
- { reOperation :: RenderOperation vb ib
- , rePassList :: [Pass t lp]
- , reMatrix :: Matrix4
- }
-
---setPass :: RenderSystem -> Pass -> IO ()
-setPass time rs pass = do
- let rsc = getCapabilities rs
- caps = rscCapabilities rsc
- Pass
- { --psName :: String -- ^ optional name for the pass
-
- -- Colour properties, only applicable in fixed-function passes
- psAmbient = ambient
- , psDiffuse = diffuse
- , psSpecular = specular
- , psEmissive = emissive
- , psShininess = shininess
- , psTracking = vertexColourTracking
-
- -- Blending factors
- , psSourceBlendFactor = sourceBlendFactor
- , psDestBlendFactor = destBlendFactor
- , psSourceBlendFactorAlpha = sourceBlendFactorAlpha
- , psDestBlendFactorAlpha = destBlendFactorAlpha
-
- , psSeparateBlend = separateBlend
-
- -- Blending operations
- , psBlendOperation = blendOperation
- , psAlphaBlendOperation = alphaBlendOperation
- , psSeparateBlendOperation = separateBlendOperation
-
- -- Depth buffer settings
- , psDepthCheck = depthCheck
- , psDepthWrite = depthWrite
- , psDepthFunc = depthFunc
- , psDepthBiasConstant = depthBiasConstant
- , psDepthBiasSlopeScale = depthBiasSlopeScale
--- , psDepthBiasPerIteration :: FloatType
-
- -- Colour buffer settings
- , psColourWrite = colourWrite
-
- -- Alpha reject settings
- , psAlphaRejectFunc = alphaRejectFunc
- , psAlphaRejectVal = alphaRejectVal
- , psAlphaToCoverageEnabled = alphaToCoverageEnabled
-
--- , psTransparentSorting :: Bool -- ^ Transparent depth sorting
--- , psTransparentSortingForced :: Bool -- ^ Transparent depth sorting forced
-
- -- Culling mode
- , psCullMode = cullMode
--- , psManualCullMode :: ManualCullingMode
-
- , psLightingEnabled = lightingEnabled
--- , psMaxSimultaneousLights :: Int -- ^ Max simultaneous lights
--- , psStartLight :: Int -- ^ Starting light index
--- , psLightsPerIteration :: Maybe Int -- ^ Run this pass once per light? Iterate per how many lights?
--- , psOnlyLightType :: Maybe LightTypes -- ^ Should it only be run for a certain light type?
-
- , psShadeOptions = shadeOptions
- , psPolygonMode = polygonMode
-
- -- Normalisation
--- , psNormaliseNormals :: Bool
- , psPolygonModeOverrideable = polygonModeOverrideable
-
- -- Fog
- , psFogOverride = fogOverride
- , psFogMode = fogMode
- , psFogColour = fogColour
- , psFogStart = fogStart
- , psFogEnd = fogEnd
- , psFogDensity = fogDensity
-
- , psTextureUnitStates = textureUnitStates
-
- , psVertexProgramUsage = vertexProgramUsage
- -- , psShadowCasterVertexProgramUsage :: GpuProgramUsage -- ^ Vertex program details
- -- , psShadowReceiverVertexProgramUsage :: GpuProgramUsage -- ^ Vertex program details
- , psFragmentProgramUsage = fragmentProgramUsage
- -- , psShadowReceiverFragmentProgramUsage :: GpuProgramUsage -- ^ Fragment program details
- , psGeometryProgramUsage = geometryProgramUsage
- , psLinkedGpuProgram = linkedGpuProgram
- -- , psQueuedForDeletion :: Bool -- ^ Is this pass queued for deletion?
-
--- , psPassIterationCount :: Int -- ^ number of pass iterations to perform
-
- , psPointSize = pointSize
- , psPointMinSize = pointMinSize
- , psPointMaxSize = pointMaxSize
- , psPointSpritesEnabled = pointSpritesEnabled
- , psPointAttenuationEnabled = pointAttenuationEnabled
--- , psPointAttenuationCoeffs :: FloatType3 -- ^ constant, linear, quadratic coeffs
-
- {-
- // TU Content type lookups
- typedef vector::type ContentTypeLookup;
- mutable ContentTypeLookup mShadowContentTypeLookup;
- mutable bool mContentTypeLookupBuilt;
- -}
--- , psLightScissoring :: Bool -- ^ Scissoring for the light?
--- , psLightClipPlanes :: Bool -- ^ User clip planes for light?
--- , psIlluminationStage :: IlluminationStage -- ^ Illumination stage?
- } = pass
- {-
- if (!mSuppressRenderStateChanges || evenIfSuppressed)
- {
- if (mIlluminationStage == IRS_RENDER_TO_TEXTURE && shadowDerivation)
- {
- // Derive a special shadow caster pass from this one
- pass = deriveShadowCasterPass(pass);
- }
- else if (mIlluminationStage == IRS_RENDER_RECEIVER_PASS && shadowDerivation)
- {
- pass = deriveShadowReceiverPass(pass);
- }
-
- // Tell params about current pass
- mAutoParamDataSource->setCurrentPass(pass);
-
- bool passSurfaceAndLightParams = true;
- bool passFogParams = true;
- -}
- let passSurfaceAndLightParams = True
- passFogParams = True
-
- case linkedGpuProgram of
- { Nothing -> unbindLinkedGpuProgram rs
- ; Just lp -> bindLinkedGpuProgram rs lp
- }
-
- when passSurfaceAndLightParams $ do
- -- Set surface reflectance properties, only valid if lighting is enabled
- when lightingEnabled $
- setSurfaceParams rs ambient diffuse specular emissive shininess vertexColourTracking
- -- Dynamic lighting enabled?
- setLightingEnabled rs lightingEnabled
-
- when passFogParams $ do
- -- New fog params can either be from scene or from material
- -- TODO: implement override
- --setFog rs newFogMode newFogColour newFogDensity newFogStart newFogEnd
- setFog rs fogMode fogColour fogDensity fogStart fogEnd
- -- TODO
- {-
- if (passFogParams)
- {
- // New fog params can either be from scene or from material
- FogMode newFogMode;
- ColourValue newFogColour;
- Real newFogStart, newFogEnd, newFogDensity;
- if (pass->getFogOverride())
- {
- // New fog params from material
- newFogMode = pass->getFogMode();
- newFogColour = pass->getFogColour();
- newFogStart = pass->getFogStart();
- newFogEnd = pass->getFogEnd();
- newFogDensity = pass->getFogDensity();
- }
- else
- {
- // New fog params from scene
- newFogMode = mFogMode;
- newFogColour = mFogColour;
- newFogStart = mFogStart;
- newFogEnd = mFogEnd;
- newFogDensity = mFogDensity;
- }
-
- /* In D3D, it applies to shaders prior
- to version vs_3_0 and ps_3_0. And in OGL, it applies to "ARB_fog_XXX" in
- fragment program, and in other ways, them maybe access by gpu program via
- "state.fog.XXX".
- */
- mDestRenderSystem->_setFog(
- newFogMode, newFogColour, newFogDensity, newFogStart, newFogEnd);
- }
-
- // Tell params about ORIGINAL fog
- // Need to be able to override fixed function fog, but still have
- // original fog parameters available to a shader than chooses to use
- mAutoParamDataSource->setFog(
- mFogMode, mFogColour, mFogDensity, mFogStart, mFogEnd);
- -}
-
- -- The rest of the settings are the same no matter whether we use programs or not
-
- -- Set scene blending
- case separateBlend of
- { True -> setSeparateSceneBlending rs sourceBlendFactor destBlendFactor
- sourceBlendFactorAlpha destBlendFactorAlpha
- blendOperation
- (if separateBlendOperation then blendOperation else alphaBlendOperation)
- ; False -> case psSeparateBlendOperation pass of
- { True -> setSeparateSceneBlending rs sourceBlendFactor destBlendFactor
- sourceBlendFactor destBlendFactor
- blendOperation alphaBlendOperation
- ; False -> setSceneBlending rs sourceBlendFactor destBlendFactor blendOperation
- }
- }
-
- -- Set point parameters
- let (pac,pal,paq) = psPointAttenuationCoeffs pass -- TODO: refactor
- setPointParameters rs pointSize pointAttenuationEnabled pac pal paq pointMinSize pointMaxSize
-
- when (Set.member RSC_POINT_SPRITES caps) $
- setPointSpritesEnabled rs pointSpritesEnabled
-
- -- Texture unit settings
- -- TODO
- {-
- Pass::ConstTextureUnitStateIterator texIter = pass->getTextureUnitStateIterator();
- size_t unit = 0;
- // Reset the shadow texture index for each pass
- size_t startLightIndex = pass->getStartLight();
- size_t shadowTexUnitIndex = 0;
- size_t shadowTexIndex = mShadowTextures.size();
- if (mShadowTextureIndexLightList.size() > startLightIndex)
- shadowTexIndex = mShadowTextureIndexLightList[startLightIndex];
- while(texIter.hasMoreElements())
- {
- TextureUnitState* pTex = texIter.getNext();
- if (!pass->getIteratePerLight() &&
- isShadowTechniqueTextureBased() &&
- pTex->getContentType() == TextureUnitState::CONTENT_SHADOW)
- {
- // Need to bind the correct shadow texture, based on the start light
- // Even though the light list can change per object, our restrictions
- // say that when texture shadows are enabled, the lights up to the
- // number of texture shadows will be fixed for all objects
- // to match the shadow textures that have been generated
- // see Listener::sortLightsAffectingFrustum and
- // MovableObject::Listener::objectQueryLights
- // Note that light iteration throws the indexes out so we don't bind here
- // if that's the case, we have to bind when lights are iterated
- // in renderSingleObject
-
- TexturePtr shadowTex;
- if (shadowTexIndex < mShadowTextures.size())
- {
- shadowTex = getShadowTexture(shadowTexIndex);
- // Hook up projection frustum
- Camera *cam = shadowTex->getBuffer()->getRenderTarget()->getViewport(0)->getCamera();
- // Enable projective texturing if fixed-function, but also need to
- // disable it explicitly for program pipeline.
- pTex->setProjectiveTexturing(!pass->hasVertexProgram(), cam);
- mAutoParamDataSource->setTextureProjector(cam, shadowTexUnitIndex);
- }
- else
- {
- // Use fallback 'null' shadow texture
- // no projection since all uniform colour anyway
- shadowTex = mNullShadowTexture;
- pTex->setProjectiveTexturing(false);
- mAutoParamDataSource->setTextureProjector(0, shadowTexUnitIndex);
-
- }
- pTex->_setTexturePtr(shadowTex);
-
- ++shadowTexIndex;
- ++shadowTexUnitIndex;
- }
- else if (mIlluminationStage == IRS_NONE && pass->hasVertexProgram())
- {
- // Manually set texture projector for shaders if present
- // This won't get set any other way if using manual projection
- TextureUnitState::EffectMap::const_iterator effi =
- pTex->getEffects().find(TextureUnitState::ET_PROJECTIVE_TEXTURE);
- if (effi != pTex->getEffects().end())
- {
- mAutoParamDataSource->setTextureProjector(effi->second.frustum, unit);
- }
- }
- mDestRenderSystem->_setTextureUnitSettings(unit, *pTex);
- ++unit;
- }
- // Disable remaining texture units
- mDestRenderSystem->_disableTextureUnitsFrom(pass->getNumTextureUnitStates());
- -}
- -- TODO
- mapM_ (uncurry $ setTextureUnitSettings time rs) $ zip [0..] textureUnitStates
-
- -- Disable remaining texture units
- forM_ [(length textureUnitStates)..((rscNumTextureUnits $ getCapabilities rs) - 1)] $ \tu -> do
- -- TODO: dont disable disabled texunits
- setActiveTextureUnit rs tu
- setTexture rs Nothing
-
- -- Set up non-texture related material settings
- -- Depth buffer settings
- --FIXME: high level haskell gl binding handles depth check activation and depth function in one function
- setDepthBufferFunction rs depthCheck depthFunc
- {- -- HINT: GL has unified function for this
- setDepthBufferFunction rs depthFunc
- setDepthBufferCheckEnabled rs depthCheck
- -}
- setDepthBufferWriteEnabled rs depthWrite
- setDepthBias rs depthBiasConstant depthBiasSlopeScale
-
- -- Alpha-reject settings
- setAlphaRejectSettings rs alphaRejectFunc alphaRejectVal alphaToCoverageEnabled
-
- -- Set colour write mode
- -- Right now we only use on/off, not per-channel
- setColourBufferWriteEnabled rs colourWrite colourWrite colourWrite colourWrite
- -- TODO
- {-
- // Culling mode
- if (isShadowTechniqueTextureBased()
- && mIlluminationStage == IRS_RENDER_TO_TEXTURE
- && mShadowCasterRenderBackFaces
- && pass->getCullingMode() == CULL_CLOCKWISE)
- {
- // render back faces into shadow caster, can help with depth comparison
- mPassCullingMode = CULL_ANTICLOCKWISE;
- }
- else
- {
- mPassCullingMode = pass->getCullingMode();
- }
- -}
- -- TODO: calc cull mode according illumination stage
- setCullingMode rs cullMode
- -- Shading
- setShadingType rs shadeOptions
-
- -- Polygon mode
- unless polygonModeOverrideable $
- setPolygonMode rs polygonMode
-
- -- TODO
- {-
- // set pass number
- mAutoParamDataSource->setPassNumber( pass->getIndex() );
-
- // mark global params as dirty
- mGpuParamsDirty |= (uint16)GPV_GLOBAL;
- -}
- return ()
-
-{-
- const TexturePtr& TextureUnitState::_getTexturePtr(size_t frame) const
- {
- if (mContentType == CONTENT_NAMED)
- {
- if (frame < mFrames.size() && !mTextureLoadFailed)
- {
- ensureLoaded(frame);
- return mFramePtrs[frame];
- }
- else
- {
- // Silent fail with empty texture for internal method
- static TexturePtr nullTexPtr;
- return nullTexPtr;
- }
- }
- else
- {
- // Manually bound texture, no name or loading
- assert(frame < mFramePtrs.size());
- return mFramePtrs[frame];
- }
- }
--}
-
-{-| Utility function for setting all the properties of a texture unit at once.
-This method is also worth using over the individual texture unit settings because it
-only sets those settings which are different from the current settings for this
-unit, thus minimising render state changes.
--}
---setTextureUnitSettings :: RenderSystem a vb ib q t p => a -> Int -> TextureUnitState t -> IO ()
-setTextureUnitSettings time rs texUnit tl = do
- -- This method is only ever called to set a texture unit to valid details
- -- The method _disableTextureUnit is called to turn a unit off
- let rsc = getCapabilities rs
- caps = rscCapabilities rsc
- TextureUnitState
- { tusAnimDuration = animDuration
--- , tusCubic :: Bool -- ^ is this a series of 6 2D textures to make up a cube?
-
- , tusTextureType = texType
--- , tusDesiredFormat :: PixelFormat
--- , tusTextureSrcMipmaps :: Int -- ^ Request number of mipmaps
-
--- , tusTextureCoordSetIndex :: Int
- , tusAddressMode = uvw
- , tusBorderColour = borderColour
-
- , tusColourBlendMode = colourBlendMode
--- , tusColourBlendFallbackSrc :: SceneBlendFactor
--- , tusColourBlendFallbackDest :: SceneBlendFactor
-
- , tusAlphaBlendMode = alphaBlendMode
- -- mutable bool mTextureLoadFailed;
- -- , tusTextureLoadFailed :: Bool
--- , tusIsAlpha :: Bool
--- , tusHwGamma :: Bool
-
- -- mutable bool mRecalcTexMatrix;
- -- Real mUMod, mVMod;
- -- Real mUScale, mVScale;
- -- Radian mRotate;
- -- mutable Matrix4 mTexModMatrix;
-
- , tusMinFilter = minFilter
- , tusMagFilter = magFilter
- , tusMipFilter = mipFilter
-
- , tusMaxAniso = maxAniso
- , tusMipmapBias = mipmapBias
-
- -- bool mIsDefaultAniso;
- -- bool mIsDefaultFiltering;
- , tusBindingType = bindingType
--- , tusContentType :: ContentType -- ^ Content type of texture (normal loaded texture, auto-texture)
-
--- , tusFrameNames :: [String]
- , tusFrames = frames
--- , tusName :: String -- ^ optional name for the TUS
--- , tusTextureAlias :: String -- ^ optional alias for texture frames
- , tusEffects = effects
- } = tl
- texl = fromMaybe (error "fromJust 12") frames -- TODO: const TexturePtr& tex = tl._getTexturePtr();
-
- -- Activate TextureUnit
- setActiveTextureUnit rs texUnit
- -- Vertex texture binding?
- unless (null texl) $ do
- let tex = case animDuration of
- { Nothing -> head texl
- ; Just 0 -> head texl
- ; Just d -> texl !! (floor $ (fromIntegral $ length texl) * (snd $ properFraction $ time / d))
- }
- case (Set.member RSC_VERTEX_TEXTURE_FETCH caps && (not $ rscVertexTextureUnitsShared rsc)) of
- { True -> case bindingType of
- { BT_VERTEX -> do
- -- Bind vertex texture
- setVertexTexture rs $ Just tex
- -- bind nothing to fragment unit (hardware isn't shared but fragment
- -- unit can't be using the same index
- setTexture rs Nothing
- ; _ -> do
- -- vice versa
- setVertexTexture rs Nothing
- setTexture rs $ Just tex
- }
- ; False -> do
- -- Shared vertex / fragment textures or no vertex texture support
- -- Bind texture (may be blank)
- setTexture rs $ Just tex
- }
-
- -- Set texture layer filtering
- setTextureUnitFiltering rs texType minFilter magFilter mipFilter
-
- -- Set texture layer filtering
- when (Set.member RSC_ANISOTROPY caps) $
- setTextureLayerAnisotropy rs texType maxAniso
-
- -- Set mipmap biasing
- when (Set.member RSC_MIPMAP_LOD_BIAS caps) $
- setTextureMipmapBias rs mipmapBias
-
- -- Set blend modes
- -- Check to see if blending is supported
- when (Set.member RSC_BLENDING caps) $ do
- setTextureBlendMode rs colourBlendMode alphaBlendMode
- --HINT: Obsolete below, due to stateful behaviour
- -- Note, colour before alpha is important
- --setTextureBlendMode rs colourBlendMode
- --setTextureBlendMode rs alphaBlendMode
-
- -- Texture addressing mode
- setTextureAddressingMode rs texType uvw
- -- Set texture border colour only if required
- when ( amU uvw == TAM_BORDER ||
- amV uvw == TAM_BORDER ||
- amW uvw == TAM_BORDER ) $
- setTextureBorderColour rs texType borderColour
-
- -- Set texture effects
- -- TODO
--- mapM_ effects
- setTextureCoordCalculation rs TEXCALC_NONE
- forM_ effects $ \ e -> case teType e of
- { ET_ENVIRONMENT_MAP -> setTextureCoordCalculation rs TEXCALC_ENVIRONMENT_MAP
- ; _ -> return ()
- }
--- effects
-{-
- // Set texture effects
- TextureUnitState::EffectMap::iterator effi;
- // Iterate over new effects
- bool anyCalcs = false;
- for (effi = tl.mEffects.begin(); effi != tl.mEffects.end(); ++effi)
- {
- switch (effi->second.type)
- {
- case TextureUnitState::ET_ENVIRONMENT_MAP:
- if (effi->second.subtype == TextureUnitState::ENV_CURVED)
- {
- _setTextureCoordCalculation(texUnit, TEXCALC_ENVIRONMENT_MAP);
- anyCalcs = true;
- }
- else if (effi->second.subtype == TextureUnitState::ENV_PLANAR)
- {
- _setTextureCoordCalculation(texUnit, TEXCALC_ENVIRONMENT_MAP_PLANAR);
- anyCalcs = true;
- }
- else if (effi->second.subtype == TextureUnitState::ENV_REFLECTION)
- {
- _setTextureCoordCalculation(texUnit, TEXCALC_ENVIRONMENT_MAP_REFLECTION);
- anyCalcs = true;
- }
- else if (effi->second.subtype == TextureUnitState::ENV_NORMAL)
- {
- _setTextureCoordCalculation(texUnit, TEXCALC_ENVIRONMENT_MAP_NORMAL);
- anyCalcs = true;
- }
- break;
- case TextureUnitState::ET_UVSCROLL:
- case TextureUnitState::ET_USCROLL:
- case TextureUnitState::ET_VSCROLL:
- case TextureUnitState::ET_ROTATE:
- case TextureUnitState::ET_TRANSFORM:
- break;
- case TextureUnitState::ET_PROJECTIVE_TEXTURE:
- _setTextureCoordCalculation(texUnit, TEXCALC_PROJECTIVE_TEXTURE,
- effi->second.frustum);
- anyCalcs = true;
- break;
- }
- }
- // Ensure any previous texcoord calc settings are reset if there are now none
- if (!anyCalcs)
- {
- _setTextureCoordCalculation(texUnit, TEXCALC_NONE);
- }
-
- // Change tetxure matrix
- _setTextureMatrix(texUnit, tl.getTextureTransform());
- }
--}
- return ()
-{-
- const Matrix4& TextureUnitState::getTextureTransform() const
- {
- if (mRecalcTexMatrix)
- recalcTextureMatrix();
- return mTexModMatrix;
-
- }
--}
-calcTextureMatrix tus = do
- return ()
-{-
- //-----------------------------------------------------------------------
- void TextureUnitState::recalcTextureMatrix() const
- {
- // Assumption: 2D texture coords
- Matrix4 xform;
-
- xform = Matrix4::IDENTITY;
- if (mUScale != 1 || mVScale != 1)
- {
- // Offset to center of texture
- xform[0][0] = 1/mUScale;
- xform[1][1] = 1/mVScale;
- // Skip matrix concat since first matrix update
- xform[0][3] = (-0.5 * xform[0][0]) + 0.5;
- xform[1][3] = (-0.5 * xform[1][1]) + 0.5;
- }
-
- if (mUMod || mVMod)
- {
- Matrix4 xlate = Matrix4::IDENTITY;
-
- xlate[0][3] = mUMod;
- xlate[1][3] = mVMod;
-
- xform = xlate * xform;
- }
-
- if (mRotate != Radian(0))
- {
- Matrix4 rot = Matrix4::IDENTITY;
- Radian theta ( mRotate );
- Real cosTheta = Math::Cos(theta);
- Real sinTheta = Math::Sin(theta);
-
- rot[0][0] = cosTheta;
- rot[0][1] = -sinTheta;
- rot[1][0] = sinTheta;
- rot[1][1] = cosTheta;
- // Offset center of rotation to center of texture
- rot[0][3] = 0.5 + ( (-0.5 * cosTheta) - (-0.5 * sinTheta) );
- rot[1][3] = 0.5 + ( (-0.5 * sinTheta) + (-0.5 * cosTheta) );
-
- xform = rot * xform;
- }
-
- mTexModMatrix = xform;
- mRecalcTexMatrix = false;
-
- }
--}
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, ParallelListComp #-}
+module Graphics.LambdaCube.RenderSystem where
+
+import Control.Monad
+import Data.Maybe
+import Data.Word
+import Foreign.Ptr
+import qualified Data.Set as Set
+
+import Graphics.LambdaCube.BlendMode
+import Graphics.LambdaCube.Common
+import Graphics.LambdaCube.GpuProgram
+import Graphics.LambdaCube.HardwareBuffer
+import Graphics.LambdaCube.HardwareIndexBuffer
+import Graphics.LambdaCube.HardwareOcclusionQuery
+import Graphics.LambdaCube.HardwareVertexBuffer
+import Graphics.LambdaCube.Image
+import Graphics.LambdaCube.Light
+import Graphics.LambdaCube.Pass
+import Graphics.LambdaCube.PixelFormat
+import Graphics.LambdaCube.RenderOperation
+import Graphics.LambdaCube.RenderSystemCapabilities
+import Graphics.LambdaCube.Texture
+import Graphics.LambdaCube.TextureUnitState
+import Graphics.LambdaCube.Types
+
+data TexCoordCalcMethod
+ = TEXCALC_NONE -- ^ No calculated texture coordinates
+ | TEXCALC_ENVIRONMENT_MAP -- ^ Environment map based on vertex normals
+ | TEXCALC_ENVIRONMENT_MAP_PLANAR -- ^ Environment map based on vertex positions
+ | TEXCALC_ENVIRONMENT_MAP_REFLECTION -- ^ Environment map based on vertex positions
+ | TEXCALC_ENVIRONMENT_MAP_NORMAL -- ^ Environment map based on vertex positions
+ | TEXCALC_PROJECTIVE_TEXTURE -- ^ Projective texture
+ deriving Eq
+
+data StencilOperation
+ = SOP_KEEP -- ^ Leave the stencil buffer unchanged
+ | SOP_ZERO -- ^ Set the stencil value to zero
+ | SOP_REPLACE -- ^ Set the stencil value to the reference value
+ | SOP_INCREMENT -- ^ Increase the stencil value by 1, clamping at the maximum value
+ | SOP_DECREMENT -- ^ Decrease the stencil value by 1, clamping at 0
+ | SOP_INCREMENT_WRAP -- ^ Increase the stencil value by 1, wrapping back to 0 when incrementing the maximum value
+ | SOP_DECREMENT_WRAP -- ^ Decrease the stencil value by 1, wrapping when decrementing 0
+ | SOP_INVERT -- ^ Invert the bits of the stencil buffer
+ deriving Eq
+
+class (HardwareVertexBuffer vb, HardwareIndexBuffer ib, HardwareOcclusionQuery q, Texture t, GpuProgram p, LinkedGpuProgram lp) => RenderSystem rs vb ib q t p lp | rs -> vb ib q t p lp where
+ prepareRender :: rs -> IO ()
+ finishRender :: rs -> IO ()
+ createVertexBuffer :: rs -> Int -> Int -> Usage -> Bool -> IO vb
+ createIndexBuffer :: rs -> IndexType -> Int -> Usage -> Bool -> IO ib
+ createTexture :: rs -> String -> TextureType -> Int -> Int -> Int -> TextureMipmap -> PixelFormat -> TextureUsage -> Bool -> Int -> String -> Maybe [Image] -> IO t
+ withFrameBuffer :: rs -> Int -> Int -> Int -> Int -> (Ptr Word8 -> IO ()) -> IO ()
+ dirtyHackCopyTexImage :: rs -> t -> Int -> Int -> Int -> Int -> IO () --FIXME: TEMP HACK!!!!!
+ createGpuProgram :: rs -> GpuProgramType -> String -> IO (Either p String) -- TODO
+ createLinkedGpuProgram :: rs -> [p] -> IO (Either lp String) -- TODO
+ getName :: rs -> String -- ^ Returns the name of the rendering system.
+ createOcclusionQuery :: rs -> IO q -- ^ Create an object for performing hardware occlusion queries.
+ setAmbientLight :: rs -> Float -> Float -> Float -> IO () -- ^ Sets the colour & strength of the ambient (global directionless) light in the world.
+ setShadingType :: rs -> ShadeOptions -> IO () -- ^ Sets the type of light shading required (default = Gouraud).
+ setLightingEnabled :: rs -> Bool -> IO ()
+ setWBufferEnabled :: rs -> Bool -> IO ()
+ setWaitForVerticalBlank :: rs -> Bool -> IO ()
+ useLights :: rs -> [(Proj4,Light)] -> IO ()
+ setWorldMatrix :: rs -> Proj4 -> IO () -- ^ Sets the world transform matrix.
+ setViewMatrix :: rs -> Proj4 -> IO () -- ^ Sets the view transform matrix
+ setProjectionMatrix :: rs -> Mat4 -> IO () -- ^ Sets the projection transform matrix
+ setSurfaceParams :: rs -> ColourValue -> ColourValue -> ColourValue -> ColourValue -> FloatType -> TrackVertexColourType -> IO ()
+ setPointSpritesEnabled :: rs -> Bool -> IO ()
+ setPointParameters :: rs -> FloatType -> Bool -> FloatType -> FloatType -> FloatType -> FloatType -> FloatType -> IO ()
+ setActiveTextureUnit :: rs -> Int -> IO ()
+ setTexture :: rs -> Maybe t -> IO ()
+ setVertexTexture :: rs -> Maybe t -> IO ()
+ setTextureCoordCalculation :: rs -> TexCoordCalcMethod{- -> Frustum-} -> IO ()
+ setTextureBlendMode :: rs -> LayerBlendModeEx -> LayerBlendModeEx -> IO ()
+ setTextureUnitFiltering :: rs -> TextureType -> FilterOptions -> FilterOptions -> FilterOptions -> IO ()
+ setTextureLayerAnisotropy :: rs -> TextureType -> Int -> IO ()
+ setTextureAddressingMode :: rs -> TextureType -> UVWAddressingMode -> IO ()
+ setTextureBorderColour :: rs -> TextureType -> ColourValue -> IO ()
+ setTextureMipmapBias :: rs -> FloatType -> IO ()
+ setTextureMatrix :: rs -> Proj4 -> IO ()
+ setSceneBlending :: rs -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendOperation -> IO ()
+ setSeparateSceneBlending :: rs -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendOperation -> SceneBlendOperation -> IO ()
+ setAlphaRejectSettings :: rs -> CompareFunction -> Int -> Bool -> IO ()
+ setViewport :: rs -> Int -> Int -> Int -> Int -> IO ()
+ setCullingMode :: rs -> CullingMode -> IO ()
+ setDepthBufferParams :: rs -> Bool -> Bool -> CompareFunction -> IO ()
+ setDepthBufferCheckEnabled :: rs -> Bool -> IO ()
+ setDepthBufferWriteEnabled :: rs -> Bool -> IO ()
+ setDepthBufferFunction :: rs -> CompareFunction -> IO ()
+ setColourBufferWriteEnabled :: rs -> Bool -> Bool -> Bool -> Bool -> IO ()
+ setDepthBias :: rs -> FloatType -> FloatType -> IO ()
+ setFog :: rs -> FogMode -> ColourValue -> FloatType -> FloatType -> FloatType -> IO ()
+ setPolygonMode :: rs -> PolygonMode -> IO ()
+ setStencilCheckEnabled :: rs -> Bool -> IO ()
+ setStencilBufferParams :: rs -> CompareFunction -> Word32 -> Word32 -> StencilOperation -> StencilOperation -> StencilOperation -> Bool -> IO ()
+ setNormaliseNormals :: rs -> Bool -> IO ()
+ render :: rs -> RenderOperation vb ib -> IO ()
+ bindGeometry :: rs -> RenderOperation vb ib -> [TextureUnitState t] -> IO ()
+ unbindGeometry :: rs -> RenderOperation vb ib -> IO ()
+ getCapabilities :: rs -> RenderSystemCapabilities
+ bindLinkedGpuProgram :: rs -> lp -> IO ()
+ unbindLinkedGpuProgram :: rs -> IO ()
+ setScissorTest :: rs -> Bool -> Int -> Int -> Int -> Int -> IO ()
+ clearFrameBuffer :: rs -> FrameBufferType -> ColourValue -> FloatType -> Word16 -> IO ()
+ getHorizontalTexelOffset :: rs -> IO FloatType
+ getVerticalTexelOffset :: rs -> IO FloatType
+ getMinimumDepthInputValue :: rs -> FloatType
+ getMaximumDepthInputValue :: rs -> FloatType
+
+class (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => Renderable r vb ib t lp | r -> vb ib t lp where
+ prepare :: Proj4 -> r -> [RenderEntity vb ib t lp]
+
+data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => RenderEntity vb ib t lp
+ = RenderEntity
+ { reOperation :: RenderOperation vb ib
+ , rePassList :: [Pass t lp]
+ , reMatrix :: Proj4
+ , reBoundRadius :: FloatType
+ }
+
+setPass :: (RenderSystem rs vb ib q t p lp) => FloatType -> rs -> Pass t lp -> IO ()
+setPass time rs pass = do
+ let rsc = getCapabilities rs
+ caps = rscCapabilities rsc
+ Pass
+ { --psName :: String -- ^ optional name for the pass
+
+ -- Colour properties, only applicable in fixed-function passes
+ psAmbient = ambient
+ , psDiffuse = diffuse
+ , psSpecular = specular
+ , psEmissive = emissive
+ , psShininess = shininess
+ , psTracking = vertexColourTracking
+
+ -- Blending factors
+ , psSourceBlendFactor = sourceBlendFactor
+ , psDestBlendFactor = destBlendFactor
+ , psSourceBlendFactorAlpha = sourceBlendFactorAlpha
+ , psDestBlendFactorAlpha = destBlendFactorAlpha
+
+ , psSeparateBlend = separateBlend
+
+ -- Blending operations
+ , psBlendOperation = blendOperation
+ , psAlphaBlendOperation = alphaBlendOperation
+ , psSeparateBlendOperation = separateBlendOperation
+
+ -- Depth buffer settings
+ , psDepthCheck = depthCheck
+ , psDepthWrite = depthWrite
+ , psDepthFunc = depthFunc
+ , psDepthBiasConstant = depthBiasConstant
+ , psDepthBiasSlopeScale = depthBiasSlopeScale
+-- , psDepthBiasPerIteration :: FloatType
+
+ -- Colour buffer settings
+ , psColourWrite = colourWrite
+
+ -- Alpha reject settings
+ , psAlphaRejectFunc = alphaRejectFunc
+ , psAlphaRejectVal = alphaRejectVal
+ , psAlphaToCoverageEnabled = alphaToCoverageEnabled
+
+-- , psTransparentSorting :: Bool -- ^ Transparent depth sorting
+-- , psTransparentSortingForced :: Bool -- ^ Transparent depth sorting forced
+
+ -- Culling mode
+ , psCullMode = cullMode
+-- , psManualCullMode :: ManualCullingMode
+
+ , psLightingEnabled = lightingEnabled
+-- , psMaxSimultaneousLights :: Int -- ^ Max simultaneous lights
+-- , psStartLight :: Int -- ^ Starting light index
+-- , psLightsPerIteration :: Maybe Int -- ^ Run this pass once per light? Iterate per how many lights?
+-- , psOnlyLightType :: Maybe LightTypes -- ^ Should it only be run for a certain light type?
+
+ , psShadeOptions = shadeOptions
+ , psPolygonMode = polygonMode
+
+ -- Normalisation
+-- , psNormaliseNormals :: Bool
+ , psPolygonModeOverrideable = polygonModeOverrideable
+
+ -- Fog
+-- , psFogOverride = fogOverride
+ , psFogMode = fogMode
+ , psFogColour = fogColour
+ , psFogStart = fogStart
+ , psFogEnd = fogEnd
+ , psFogDensity = fogDensity
+
+ , psTextureUnitStates = textureUnitStates
+
+-- , psVertexProgramUsage = vertexProgramUsage
+-- , psFragmentProgramUsage = fragmentProgramUsage
+-- , psGeometryProgramUsage = geometryProgramUsage
+ , psLinkedGpuProgram = linkedGpuProgram
+
+-- , psPassIterationCount :: Int -- ^ number of pass iterations to perform
+
+ , psPointSize = pointSize
+ , psPointMinSize = pointMinSize
+ , psPointMaxSize = pointMaxSize
+ , psPointSpritesEnabled = pointSpritesEnabled
+ , psPointAttenuationEnabled = pointAttenuationEnabled
+-- , psPointAttenuationCoeffs :: FloatType3 -- ^ constant, linear, quadratic coeffs
+
+-- , psLightScissoring :: Bool -- ^ Scissoring for the light?
+-- , psLightClipPlanes :: Bool -- ^ User clip planes for light?
+-- , psIlluminationStage :: IlluminationStage -- ^ Illumination stage?
+ } = pass
+ let passSurfaceAndLightParams = True
+ passFogParams = True
+
+ case linkedGpuProgram of
+ Nothing -> unbindLinkedGpuProgram rs
+ Just lp -> bindLinkedGpuProgram rs lp
+
+ when passSurfaceAndLightParams $ do
+ -- Set surface reflectance properties, only valid if lighting is enabled
+ when lightingEnabled $
+ setSurfaceParams rs ambient diffuse specular emissive shininess vertexColourTracking
+ -- Dynamic lighting enabled?
+ setLightingEnabled rs lightingEnabled
+
+ when passFogParams $ do
+ -- New fog params can either be from scene or from material
+ -- TODO: implement override
+ --setFog rs newFogMode newFogColour newFogDensity newFogStart newFogEnd
+ setFog rs fogMode fogColour fogDensity fogStart fogEnd
+ -- TODO
+
+ -- The rest of the settings are the same no matter whether we use programs or not
+
+ -- Set scene blending
+ case separateBlend of
+ True -> setSeparateSceneBlending rs sourceBlendFactor destBlendFactor
+ sourceBlendFactorAlpha destBlendFactorAlpha blendOperation
+ (if separateBlendOperation then blendOperation else alphaBlendOperation)
+ False -> case psSeparateBlendOperation pass of
+ True -> setSeparateSceneBlending rs sourceBlendFactor destBlendFactor
+ sourceBlendFactor destBlendFactor blendOperation alphaBlendOperation
+ False -> setSceneBlending rs sourceBlendFactor destBlendFactor blendOperation
+
+ -- Set point parameters
+ let (pac,pal,paq) = psPointAttenuationCoeffs pass -- TODO: refactor
+ setPointParameters rs pointSize pointAttenuationEnabled pac pal paq pointMinSize pointMaxSize
+
+ when (Set.member RSC_POINT_SPRITES caps) $
+ setPointSpritesEnabled rs pointSpritesEnabled
+
+ -- Texture unit settings
+
+ -- TODO
+ sequence_ [setTextureUnitSettings time rs i tus | i <- [0..] | tus <- textureUnitStates]
+
+ -- Disable remaining texture units
+ forM_ [length textureUnitStates..rscNumTextureUnits (getCapabilities rs) - 1] $ \tu -> do
+ -- TODO: dont disable disabled texunits
+ setActiveTextureUnit rs tu
+ setTexture rs Nothing
+
+ -- Set up non-texture related material settings
+ -- Depth buffer settings
+ setDepthBufferFunction rs depthFunc
+ setDepthBufferCheckEnabled rs depthCheck
+ setDepthBufferWriteEnabled rs depthWrite
+ setDepthBias rs depthBiasConstant depthBiasSlopeScale
+
+ -- Alpha-reject settings
+ setAlphaRejectSettings rs alphaRejectFunc alphaRejectVal alphaToCoverageEnabled
+
+ -- Set colour write mode
+ -- Right now we only use on/off, not per-channel
+ setColourBufferWriteEnabled rs colourWrite colourWrite colourWrite colourWrite
+ -- TODO: calc cull mode according illumination stage
+ setCullingMode rs cullMode
+ -- Shading
+ setShadingType rs shadeOptions
+
+ -- Polygon mode
+ unless polygonModeOverrideable $
+ setPolygonMode rs polygonMode
+
+setTextureUnitSettings :: (RenderSystem rs vb ib q t p lp) => FloatType -> rs -> Int -> TextureUnitState t -> IO ()
+setTextureUnitSettings time rs texUnit tl = do
+ let rsc = getCapabilities rs
+ caps = rscCapabilities rsc
+ TextureUnitState
+ { tusAnimDuration = animDuration
+-- , tusCubic :: Bool -- ^ is this a series of 6 2D textures to make up a cube?
+
+ , tusTextureType = texType
+-- , tusDesiredFormat :: PixelFormat
+-- , tusTextureSrcMipmaps :: Int -- ^ Request number of mipmaps
+
+-- , tusTextureCoordSetIndex :: Int
+ , tusAddressMode = uvw
+ , tusBorderColour = borderColour
+
+ , tusColourBlendMode = colourBlendMode
+-- , tusColourBlendFallbackSrc :: SceneBlendFactor
+-- , tusColourBlendFallbackDest :: SceneBlendFactor
+
+ , tusAlphaBlendMode = alphaBlendMode
+ -- , tusTextureLoadFailed :: Bool
+-- , tusIsAlpha :: Bool
+-- , tusHwGamma :: Bool
+
+ , tusMinFilter = minFilter
+ , tusMagFilter = magFilter
+ , tusMipFilter = mipFilter
+
+ , tusMaxAniso = maxAniso
+ , tusMipmapBias = mipmapBias
+
+ , tusBindingType = bindingType
+-- , tusContentType :: ContentType -- ^ Content type of texture (normal loaded texture, auto-texture)
+
+-- , tusFrameNames :: [String]
+ , tusFrames = frames
+-- , tusName :: String -- ^ optional name for the TUS
+-- , tusTextureAlias :: String -- ^ optional alias for texture frames
+ , tusEffects = effects
+ } = tl
+ texl = fromMaybe (error "fromJust 12") frames
+
+ -- Activate TextureUnit
+ setActiveTextureUnit rs texUnit
+ -- Vertex texture binding?
+ unless (null texl) $ do
+ let tex = case animDuration of
+ Nothing -> head texl
+ Just 0 -> head texl
+ Just d -> texl !! (floor $ (fromIntegral $ length texl) * (snd $ pf $ time / d))
+ where
+ pf :: FloatType -> (Int, FloatType)
+ pf = properFraction
+ case Set.member RSC_VERTEX_TEXTURE_FETCH caps && not (rscVertexTextureUnitsShared rsc) of
+ True -> case bindingType of
+ BT_VERTEX -> do
+ -- Bind vertex texture
+ setVertexTexture rs $ Just tex
+ -- bind nothing to fragment unit (hardware isn't shared but fragment
+ -- unit can't be using the same index
+ setTexture rs Nothing
+ _ -> do
+ -- vice versa
+ setVertexTexture rs Nothing
+ setTexture rs $ Just tex
+ False -> do
+ -- Shared vertex / fragment textures or no vertex texture support
+ -- Bind texture (may be blank)
+ setTexture rs $ Just tex
+
+ -- Set texture layer filtering
+ setTextureUnitFiltering rs texType minFilter magFilter mipFilter
+
+ -- Set texture layer filtering
+ when (Set.member RSC_ANISOTROPY caps) $
+ setTextureLayerAnisotropy rs texType maxAniso
+
+ -- Set mipmap biasing
+ when (Set.member RSC_MIPMAP_LOD_BIAS caps) $
+ setTextureMipmapBias rs mipmapBias
+
+ -- Set blend modes
+ -- Check to see if blending is supported
+ when (Set.member RSC_BLENDING caps) $ do
+ setTextureBlendMode rs colourBlendMode alphaBlendMode
+ --HINT: Obsolete below, due to stateful behaviour
+ -- Note, colour before alpha is important
+ --setTextureBlendMode rs colourBlendMode
+ --setTextureBlendMode rs alphaBlendMode
+
+ -- Texture addressing mode
+ setTextureAddressingMode rs texType uvw
+ -- Set texture border colour only if required
+ when (amU uvw == TAM_BORDER || amV uvw == TAM_BORDER || amW uvw == TAM_BORDER) $
+ setTextureBorderColour rs texType borderColour
+
+ -- Set texture effects
+ -- TODO
+ setTextureCoordCalculation rs TEXCALC_NONE
+ forM_ effects $ \e -> case teType e of
+ ET_ENVIRONMENT_MAP -> setTextureCoordCalculation rs TEXCALC_ENVIRONMENT_MAP
+ _ -> return ()
diff --git a/Graphics/LambdaCube/RenderSystem/GL.hs b/Graphics/LambdaCube/RenderSystem/GL.hs
--- a/Graphics/LambdaCube/RenderSystem/GL.hs
+++ b/Graphics/LambdaCube/RenderSystem/GL.hs
@@ -2,11 +2,11 @@
import Graphics.LambdaCube.Entity
import Graphics.LambdaCube.RenderSystem
-import Graphics.LambdaCube.RenderSystem.GL.GLRenderSystem
-import Graphics.LambdaCube.RenderSystem.GL.GLVertexBuffer
-import Graphics.LambdaCube.RenderSystem.GL.GLIndexBuffer
-import Graphics.LambdaCube.RenderSystem.GL.GLTexture
-import Graphics.LambdaCube.RenderSystem.GL.GLGpuProgram
+import Graphics.LambdaCube.RenderSystem.GL.GpuProgram
+import Graphics.LambdaCube.RenderSystem.GL.IndexBuffer
+import Graphics.LambdaCube.RenderSystem.GL.RenderSystem
+import Graphics.LambdaCube.RenderSystem.GL.Texture
+import Graphics.LambdaCube.RenderSystem.GL.VertexBuffer
type GLEntity = Entity GLVertexBuffer GLIndexBuffer GLTexture GLLinkedGpuProgram
diff --git a/Graphics/LambdaCube/RenderSystem/GL/Capabilities.hs b/Graphics/LambdaCube/RenderSystem/GL/Capabilities.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/LambdaCube/RenderSystem/GL/Capabilities.hs
@@ -0,0 +1,217 @@
+module Graphics.LambdaCube.RenderSystem.GL.Capabilities where
+
+import qualified Data.Set as Set
+
+import Graphics.Rendering.OpenGL.Raw.Core31
+import qualified Graphics.Rendering.OpenGL.Raw.ARB.Compatibility as Compat
+
+import Graphics.LambdaCube.RenderSystemCapabilities
+import Graphics.LambdaCube.RenderSystem.GL.Utils
+
+mkGLCapabilities :: IO RenderSystemCapabilities
+mkGLCapabilities = do
+ vendorS <- getString gl_VENDOR
+ extSList <- getGLExtensions
+ -- setup device name
+ deviceName <- getString gl_RENDERER
+ -- setup vendor
+ let v = words vendorS
+ vendorName = if elem "NVIDIA" v then GPU_NVIDIA
+ else if elem "ATI" v then GPU_ATI
+ else if elem "Intel" v then GPU_INTEL
+ else if elem "S3" v then GPU_S3
+ else if elem "Matrox" v then GPU_MATROX
+ else if elem "3DLabs" v then GPU_3DLABS
+ else if elem "SiS" v then GPU_SIS
+ else GPU_UNKNOWN
+
+ (major,minor) <- getGLVersion
+ -- setup capabilities
+ let ext = Set.fromList extSList
+ glVer a b = major > a || (major >= a && minor >= b)
+ supports s = Set.member s ext
+ driverVersion = DriverVersion (fromIntegral major) (fromIntegral minor) 0 0 -- TODO
+ caps0 =
+ [ RSC_FIXED_FUNCTION -- Supports fixed-function
+ , RSC_SCISSOR_TEST -- Scissor test is standard in GL 1.2 (is it emulated on some cards though?)
+ , RSC_USER_CLIP_PLANES -- As are user clipping planes
+ , RSC_VERTEX_FORMAT_UBYTE4 -- UBYTE4 always supported
+ , RSC_INFINITE_FAR_PLANE -- Infinite far plane always supported
+ , RSC_TEXTURE_3D -- 3D textures should be supported by GL 1.2, which is our minimum version
+ ]
+
+ -- Check for hardware mipmapping support.
+ caps1 = if not (glVer 1 4 || supports "GL_SGIS_generate_mipmap") then [] else
+ [RSC_AUTOMIPMAP] -- FIXME
+ {-
+ case vendorName of
+ { GPU_ATI -> [] -- Apple & Linux ATI drivers have faults in hardware mipmap generation
+ -- The Intel 915G frequently corrupts textures when using hardware mip generation
+ -- I'm not currently sure how many generations of hardware this affects,
+ -- so for now, be safe.
+ ; GPU_INTEL -> []
+ ; GPU_SIS -> [] -- SiS chipsets also seem to have problems with this
+ ; _ -> [RSC_AUTOMIPMAP]
+ }
+ -}
+ -- Check for blending support
+ caps2 = if (glVer 1 3 || supports "GL_ARB_texture_env_combine" || supports "GL_EXT_texture_env_combine") then [RSC_BLENDING] else []
+
+ -- Check for Multitexturing support and set number of texture units
+ numTexUnits <- case glVer 1 3 || supports "GL_ARB_multitexture" of
+ True -> do
+ --mtu <- getInteger Compat.gl_MAX_TEXTURE_UNITS
+ mtimu <- case supports "GL_ARB_fragment_program" of
+ { True -> do
+ -- Also check GL_MAX_TEXTURE_IMAGE_UNITS_ARB since NV at least
+ -- only increased this on the FX/6x00 series
+ getInteger gl_MAX_TEXTURE_IMAGE_UNITS
+ ; False -> return 0
+ }
+ -- FIXME: enable at becoming hgl binding
+ return mtimu -- -- $ max mtu (fromIntegral mtimu)
+ False -> return 1
+
+ -- Check for Anisotropy support
+ let caps3 = if (supports "GL_EXT_texture_filter_anisotropic") then [RSC_ANISOTROPY] else []
+
+ -- Check for DOT3 support
+ caps4 = if (glVer 1 3 || supports "GL_ARB_texture_env_dot3" || supports "GL_EXT_texture_env_dot3") then [RSC_DOT3] else []
+
+ -- Check for cube mapping
+ caps5 = if (glVer 1 3 || supports "GL_ARB_texture_cube_map" || supports "GL_EXT_texture_cube_map") then [RSC_CUBEMAPPING] else []
+
+ -- Point sprites
+ caps6 = if (glVer 2 0 || supports "GL_ARB_point_sprite") then [RSC_POINT_SPRITES] else []
+
+ -- Check for point parameters
+ caps7 = if (glVer 1 4) then [RSC_POINT_EXTENDED_PARAMETERS] else []
+ caps8 = if (supports "GL_ARB_point_parameters") then [RSC_POINT_EXTENDED_PARAMETERS_ARB] else []
+ caps9 = if (supports "GL_EXT_point_parameters") then [RSC_POINT_EXTENDED_PARAMETERS_EXT] else []
+
+ -- Check for hardware stencil support and set bit depth
+ stencilBits <- getInteger Compat.gl_STENCIL_BITS
+ let caps10 = if stencilBits > 0 then [RSC_HWSTENCIL] else []
+
+ caps11 = if not (glVer 1 5 || supports "GL_ARB_vertex_buffer_object") then [] else
+ [RSC_VBO] ++ (if not (supports "GL_ARB_vertex_buffer_object") then [RSC_GL1_5_NOVBO] else [])
+-- TODO: haskell gl binding does not support query for GL_MAX_PROGRAM_LOCAL_PARAMETERS_ARB
+ (prof1,caps12) = if supports "GL_NV_register_combiners2" && supports "GL_NV_texture_shader" then (["fp20"],[RSC_FRAGMENT_PROGRAM]) else ([],[])
+
+ -- check for ATI fragment shader support
+ -- no boolean params allowed
+ -- no integer params allowed
+ -- only 8 Vector4 constant floats supported
+ (prof2,caps13,fragConstBool,fragConstInt,fragConstFloat) = if supports "GL_ATI_fragment_shader" then (["ps_1_4","ps_1_3","ps_1_2","ps_1_1"],[RSC_FRAGMENT_PROGRAM],0,0,8) else ([],[],0,0,0)
+ -- Check if GLSL is supported
+ prof3 = if glVer 2 0 ||
+ (supports "GL_ARB_shading_language_100"
+ && supports "GL_ARB_shader_objects"
+ && supports "GL_ARB_fragment_shader"
+ && supports "GL_ARB_vertex_shader") then ["glsl"] else []
+ -- Check if render to vertex buffer (transform feedback in OpenGL)
+ caps14 = if (glVer 2 0 && supports "GL_NV_transform_feedback") then [RSC_HWRENDER_TO_VERTEX_BUFFER] else []
+ -- Check for texture compression
+ caps15 = if not (glVer 1 3 || supports "GL_ARB_texture_compression") then [] else
+ [RSC_TEXTURE_COMPRESSION]
+ -- Check for dxt compression
+ ++ (if supports "GL_EXT_texture_compression_s3tc" then [RSC_TEXTURE_COMPRESSION_DXT] else [])
+ -- Check for vtc compression
+ ++ (if supports "GL_NV_texture_compression_vtc" then [RSC_TEXTURE_COMPRESSION_VTC] else [])
+
+ -- 2-sided stencil?
+ caps16 = if (glVer 2 0 || supports "GL_EXT_stencil_two_side") then [RSC_TWO_SIDED_STENCIL] else []
+ caps17 = if (glVer 1 4 || supports "GL_EXT_stencil_wrap") then [RSC_STENCIL_WRAP] else []
+
+ -- Check for hardware occlusion support
+ caps18 = case glVer 1 5 || supports "GL_ARB_occlusion_query" of
+ -- Some buggy driver claim that it is GL 1.5 compliant and not support ARB_occlusion_query
+ { True -> [RSC_HWOCCLUSION] ++ (if not (supports "GL_ARB_occlusion_query") then [RSC_GL1_5_NOHWOCCLUSION] else [])
+ -- Support NV extension too for old hardware
+ ; False -> if supports "GL_NV_occlusion_query" then [RSC_HWOCCLUSION] else []
+ }
+ -- Check for non-power-of-2 texture support
+ caps19 = if (supports "GL_ARB_texture_non_power_of_two") then [RSC_NON_POWER_OF_2_TEXTURES] else []
+
+ -- Check for Float textures
+ caps20 = if (supports "GL_ATI_texture_float" || supports "GL_ARB_texture_float") then [RSC_TEXTURE_FLOAT] else []
+
+ -- Check for framebuffer object extension
+ (numMTR,caps21) <- case supports "GL_EXT_framebuffer_object" of
+ True -> do
+ -- Probe number of draw buffers
+ -- Only makes sense with FBO support, so probe here
+ (n,c) <- case glVer 2 0 || supports "GL_ARB_draw_buffers" || supports "GL_ATI_draw_buffers" of
+ True -> do
+ m <- getInteger gl_MAX_DRAW_BUFFERS
+ -- Before GL version 2.0, we need to get one of the extensions
+ let cp = case (glVer 2 0, supports "GL_ARB_draw_buffers", supports "GL_ATI_draw_buffers") of
+ (False,True,True) -> [RSC_FBO_ARB,RSC_FBO_ATI]
+ (False,True,False) -> [RSC_FBO_ARB]
+ (False,False,True) -> [RSC_FBO_ATI]
+ _ -> []
+ -- Set FBO flag for all 3 'subtypes'
+ return (m,[RSC_MRT_DIFFERENT_BIT_DEPTHS,RSC_FBO] ++ cp)
+ False -> return (0,[])
+ return (n,RSC_HWRENDER_TO_TEXTURE:c)
+ False -> do
+ return (0,[])
+ ------------------------------------------------------
+ -- FIXE: haskell gl binding does not have query for GL_POINT_SIZE_RANGE
+ -- Point size
+ maxPointSize <- getFloat Compat.gl_POINT_SIZE_MAX
+ -- Vertex texture fetching
+ (numVertTexUnits,caps22,vertTexUnitsShared) <- case supports "GL_ARB_vertex_shader" of
+ True -> do
+ vunits <- getInteger gl_MAX_VERTEX_TEXTURE_IMAGE_UNITS
+ -- GL always shares vertex and fragment texture units (for now?)
+ return (vunits,if vunits > 0 then [RSC_VERTEX_TEXTURE_FETCH] else [], True)
+ False -> return (0,[],False)
+
+ -- Mipmap LOD biasing?
+ let caps23 = if (glVer 1 4 || supports "GL_EXT_texture_lod_bias") then [RSC_MIPMAP_LOD_BIAS] else []
+
+ -- Alpha to coverage?
+ -- Alpha to coverage always 'supported' when MSAA is available
+ -- although card may ignore it if it doesn't specifically support A2C
+ caps24 = if (supports "GL_ARB_multisample") then [RSC_ALPHA_TO_COVERAGE] else []
+
+ -- Advanced blending operations
+ caps25 = if (glVer 2 0) then [RSC_ADVANCED_BLEND_OPERATIONS] else []
+ return RenderSystemCapabilities
+ { rscDriverVersion = driverVersion
+ , rscVendor = vendorName
+
+-- , rscNumWorldMatrices :: Int -- ^ The number of world matrices available
+ , rscNumTextureUnits = fromIntegral numTexUnits
+ , rscStencilBufferBitDepth = fromIntegral stencilBits
+-- , rscNumVertexBlendMatrices :: Int
+ , rscCapabilities = Set.fromList $ caps0 ++ caps1 ++ caps2 ++ caps3 ++ caps4 ++ caps5 ++ caps6 ++ caps7 ++ caps8 ++ caps9
+ ++ caps10 ++ caps11 ++ caps12 ++ caps13 ++ caps14 ++ caps15 ++ caps16 ++ caps17 ++ caps18 ++ caps19
+ ++ caps20 ++ caps21 ++ caps22 ++ caps23 ++ caps24 ++ caps25
+
+ , rscDeviceName = deviceName
+ , rscRenderSystemName = "OpenGL Rendering Subsystem"
+-- TODO
+ , rscVertexProgramConstantFloatCount = undefined
+ , rscVertexProgramConstantIntCount = undefined
+ , rscVertexProgramConstantBoolCount = undefined
+
+ , rscGeometryProgramConstantFloatCount = undefined
+ , rscGeometryProgramConstantIntCount = undefined
+ , rscGeometryProgramConstantBoolCount = undefined
+
+ , rscFragmentProgramConstantFloatCount = fragConstFloat
+ , rscFragmentProgramConstantIntCount = fragConstInt
+ , rscFragmentProgramConstantBoolCount = fragConstBool
+
+ , rscNumMultiRenderTargets = fromIntegral numMTR
+ , rscMaxPointSize = realToFrac maxPointSize
+ , rscNonPOW2TexturesLimited = False
+ , rscNumVertexTextureUnits = fromIntegral numVertTexUnits
+ , rscVertexTextureUnitsShared = vertTexUnitsShared
+-- TODO
+ , rscGeometryProgramNumOutputVertices = undefined
+
+ , rscSupportedShaderProfiles = Set.fromList $ prof1 ++ prof2 ++ prof3
+ }
diff --git a/Graphics/LambdaCube/RenderSystem/GL/GLCapabilities.hs b/Graphics/LambdaCube/RenderSystem/GL/GLCapabilities.hs
deleted file mode 100644
--- a/Graphics/LambdaCube/RenderSystem/GL/GLCapabilities.hs
+++ /dev/null
@@ -1,404 +0,0 @@
-module Graphics.LambdaCube.RenderSystem.GL.GLCapabilities where
-
-import Data.Set (Set)
-import qualified Data.Set as Set
-
-import Graphics.Rendering.OpenGL (($=))
-import qualified Graphics.Rendering.OpenGL as GL
-
-import Graphics.LambdaCube.Types
-import Graphics.LambdaCube.RenderSystemCapabilities
-
- {-
- vendor, renderer, glVersion, glExtensions, shadingLanguageVersion,
- majorMinor, contextProfile
-vendor :: GettableStateVar String
-renderer :: GettableStateVar String
-glVersion :: GettableStateVar String
-glExtensions :: GettableStateVar [String]
-shadingLanguageVersion :: GettableStateVar String
-
- = DriverVersion
- { dvMajor :: Int
- , dvMinor :: Int
- , dvRelease :: Int
- , dvBuild :: Int
- }
- -}
-
-
---mkRenderSystemCapabilities :: IO RenderSystemCapabilities
-mkGLCapabilities = do
- vendorS <- GL.get GL.vendor
- versionS <- GL.get GL.glVersion
- extSList <- GL.get GL.glExtensions
- shLngVerS <- GL.get GL.shadingLanguageVersion
-
- -- setup driver version
- {-
- StringVector tokens = StringUtil::split(mGLSupport->getGLVersion(), ".");
-
- if (!tokens.empty())
- {
- mDriverVersion.major = StringConverter::parseInt(tokens[0]);
- if (tokens.size() > 1)
- mDriverVersion.minor = StringConverter::parseInt(tokens[1]);
- if (tokens.size() > 2)
- mDriverVersion.release = StringConverter::parseInt(tokens[2]);
- }
- mDriverVersion.build = 0;
- -}
- -- setup device name
- deviceName <- GL.get GL.renderer
- {-
- const char* deviceName = (const char*)glGetString(GL_RENDERER);
- rsc->setDeviceName(deviceName);
- -}
- -- setup vendor
- let v = words vendorS
- vendorName = if elem "NVIDIA" v then GPU_NVIDIA
- else if elem "ATI" v then GPU_ATI
- else if elem "Intel" v then GPU_INTEL
- else if elem "S3" v then GPU_S3
- else if elem "Matrox" v then GPU_MATROX
- else if elem "3DLabs" v then GPU_3DLABS
- else if elem "SiS" v then GPU_SIS
- else GPU_UNKNOWN
-
- (major,minor) <- GL.get $ GL.majorMinor GL.glVersion
- -- setup capabilities
- let ext = Set.fromList extSList
- glVer a b = major > a || (major >= a && minor >= b)
- supports s = Set.member s ext
- driverVersion = DriverVersion major minor 0 0 -- TODO
- caps0 =
- [ RSC_FIXED_FUNCTION -- Supports fixed-function
- , RSC_SCISSOR_TEST -- Scissor test is standard in GL 1.2 (is it emulated on some cards though?)
- , RSC_USER_CLIP_PLANES -- As are user clipping planes
- , RSC_VERTEX_FORMAT_UBYTE4 -- UBYTE4 always supported
- , RSC_INFINITE_FAR_PLANE -- Infinite far plane always supported
- , RSC_TEXTURE_3D -- 3D textures should be supported by GL 1.2, which is our minimum version
- ]
-
- -- Check for hardware mipmapping support.
- caps1 = if not (glVer 1 4 || supports "GL_SGIS_generate_mipmap") then [] else
- [RSC_AUTOMIPMAP] -- FIXME
- {-
- case vendorName of
- { GPU_ATI -> [] -- Apple & Linux ATI drivers have faults in hardware mipmap generation
- -- The Intel 915G frequently corrupts textures when using hardware mip generation
- -- I'm not currently sure how many generations of hardware this affects,
- -- so for now, be safe.
- ; GPU_INTEL -> []
- ; GPU_SIS -> [] -- SiS chipsets also seem to have problems with this
- ; _ -> [RSC_AUTOMIPMAP]
- }
- -}
- -- Check for blending support
- caps2 = if (glVer 1 3 || supports "GL_ARB_texture_env_combine" || supports "GL_EXT_texture_env_combine") then [RSC_BLENDING] else []
-
- -- Check for Multitexturing support and set number of texture units
- numTexUnits <- case glVer 1 3 || supports "GL_ARB_multitexture" of
- { True -> do
- GL.TextureUnit mtu <- GL.get GL.maxTextureUnit
- mtimu <- case supports "GL_ARB_fragment_program" of
- { True -> do
- -- Also check GL_MAX_TEXTURE_IMAGE_UNITS_ARB since NV at least
- -- only increased this on the FX/6x00 series
- GL.get GL.maxTextureImageUnits
- ; False -> return 0
- }
- -- FIXME: enable at becoming hgl binding
- return mtimu -- $ max mtu (fromIntegral mtimu)
- ; False -> return 1
- }
-
- -- Check for Anisotropy support
- let caps3 = if (supports "GL_EXT_texture_filter_anisotropic") then [RSC_ANISOTROPY] else []
-
- -- Check for DOT3 support
- caps4 = if (glVer 1 3 || supports "GL_ARB_texture_env_dot3" || supports "GL_EXT_texture_env_dot3") then [RSC_DOT3] else []
-
- -- Check for cube mapping
- caps5 = if (glVer 1 3 || supports "GL_ARB_texture_cube_map" || supports "GL_EXT_texture_cube_map") then [RSC_CUBEMAPPING] else []
-
- -- Point sprites
- caps6 = if (glVer 2 0 || supports "GL_ARB_point_sprite") then [RSC_POINT_SPRITES] else []
-
- -- Check for point parameters
- caps7 = if (glVer 1 4) then [RSC_POINT_EXTENDED_PARAMETERS] else []
- caps8 = if (supports "GL_ARB_point_parameters") then [RSC_POINT_EXTENDED_PARAMETERS_ARB] else []
- caps9 = if (supports "GL_EXT_point_parameters") then [RSC_POINT_EXTENDED_PARAMETERS_EXT] else []
-
- -- Check for hardware stencil support and set bit depth
- stencilBits <- GL.get GL.stencilBits
- let caps10 = if stencilBits > 0 then [RSC_HWSTENCIL] else []
-
- caps11 = if not (glVer 1 5 || supports "GL_ARB_vertex_buffer_object") then [] else
- [RSC_VBO] ++ (if not (supports "GL_ARB_vertex_buffer_object") then [RSC_GL1_5_NOVBO] else [])
--- TODO: haskell gl binding does not support query for GL_MAX_PROGRAM_LOCAL_PARAMETERS_ARB
-{-
- if(GLEW_ARB_vertex_program)
- {
- rsc->setCapability(RSC_VERTEX_PROGRAM);
-
- // Vertex Program Properties
- rsc->setVertexProgramConstantBoolCount(0);
- rsc->setVertexProgramConstantIntCount(0);
-
- GLint floatConstantCount;
- glGetProgramivARB(GL_VERTEX_PROGRAM_ARB, GL_MAX_PROGRAM_LOCAL_PARAMETERS_ARB, &floatConstantCount);
- rsc->setVertexProgramConstantFloatCount(floatConstantCount);
-
- rsc->addShaderProfile("arbvp1");
- if (GLEW_NV_vertex_program2_option)
- {
- rsc->addShaderProfile("vp30");
- }
-
- if (GLEW_NV_vertex_program3)
- {
- rsc->addShaderProfile("vp40");
- }
-
- if (GLEW_NV_vertex_program4)
- {
- rsc->addShaderProfile("gp4vp");
- rsc->addShaderProfile("gpu_vp");
- }
- }
--}
- (prof1,caps12) = if supports "GL_NV_register_combiners2" && supports "GL_NV_texture_shader" then (["fp20"],[RSC_FRAGMENT_PROGRAM]) else ([],[])
-
- -- check for ATI fragment shader support
- -- no boolean params allowed
- -- no integer params allowed
- -- only 8 Vector4 constant floats supported
- (prof2,caps13,fragConstBool,fragConstInt,fragConstFloat) = if supports "GL_ATI_fragment_shader" then (["ps_1_4","ps_1_3","ps_1_2","ps_1_1"],[RSC_FRAGMENT_PROGRAM],0,0,8) else ([],[],0,0,0)
--- TODO
-------------------------------------------------------------------------------
-{-
- (prof,cap,fragConstBool,fragConstInt,fragConstFloat) <- case supports "GL_ARB_fragment_program" of
- { True -> do
- -- Fragment Program Properties
- return ([],[RSC_FRAGMENT_PROGRAM],0,0,)
- ; False -> ([],[],0,0,0)
- }
--}
-{-
-
- if (GLEW_ARB_fragment_program)
- {
- rsc->setCapability(RSC_FRAGMENT_PROGRAM);
-
- // Fragment Program Properties
- rsc->setFragmentProgramConstantBoolCount(0);
- rsc->setFragmentProgramConstantIntCount(0);
-
- GLint floatConstantCount;
- glGetProgramivARB(GL_FRAGMENT_PROGRAM_ARB, GL_MAX_PROGRAM_LOCAL_PARAMETERS_ARB, &floatConstantCount);
- rsc->setFragmentProgramConstantFloatCount(floatConstantCount);
-
- rsc->addShaderProfile("arbfp1");
- if (GLEW_NV_fragment_program_option)
- {
- rsc->addShaderProfile("fp30");
- }
-
- if (GLEW_NV_fragment_program2)
- {
- rsc->addShaderProfile("fp40");
- }
- }
--}
-------------------------------------------------------------------------------
- -- Check if GLSL is supported
- prof3 = if glVer 2 0 ||
- (supports "GL_ARB_shading_language_100"
- && supports "GL_ARB_shader_objects"
- && supports "GL_ARB_fragment_shader"
- && supports "GL_ARB_vertex_shader") then ["glsl"] else []
--- TODO
---------------------------------------------------------------------------------------
- -- Check if geometry shaders are supported
- {-
- (cap,prof,boolC,intC,floatC,outVertN) <- case glVer 2 0 && supports "GL_EXT_geometry_shader4" of
- { True -> do
- return ([RSC_GEOMETRY_PROGRAM],["nvgp4","gpu_gp","gp4gp"],0,0,)
- ; False -> return ([],[],0,0,0,0)
- }
- -}
-{-
- // Check if geometry shaders are supported
- if (GLEW_VERSION_2_0 &&
- GLEW_EXT_geometry_shader4)
- {
- rsc->setCapability(RSC_GEOMETRY_PROGRAM);
- rsc->addShaderProfile("nvgp4");
-
- //Also add the CG profiles
- rsc->addShaderProfile("gpu_gp");
- rsc->addShaderProfile("gp4gp");
-
- rsc->setGeometryProgramConstantBoolCount(0);
- rsc->setGeometryProgramConstantIntCount(0);
-
- GLint floatConstantCount;
- glGetProgramivARB(GL_GEOMETRY_PROGRAM_NV, GL_MAX_PROGRAM_LOCAL_PARAMETERS_ARB, &floatConstantCount);
- rsc->setGeometryProgramConstantFloatCount(floatConstantCount);
-
- GLint maxOutputVertices;
- glGetIntegerv(GL_MAX_GEOMETRY_OUTPUT_VERTICES_EXT,&maxOutputVertices);
- rsc->setGeometryProgramNumOutputVertices(maxOutputVertices);
- }
--}
---------------------------------------------------------------------------------------
- -- Check if render to vertex buffer (transform feedback in OpenGL)
- caps14 = if (glVer 2 0 && supports "GL_NV_transform_feedback") then [RSC_HWRENDER_TO_VERTEX_BUFFER] else []
-
- -- Check for texture compression
- caps15 = if not (glVer 1 3 || supports "GL_ARB_texture_compression") then [] else
- [RSC_TEXTURE_COMPRESSION]
- -- Check for dxt compression
- --------------------------------------------------------------------------------
- {- FIXME: we should disable DXT on (apple && ati && ppc)
- -- if defined(__APPLE__) && defined(__PPC__)
- -- // Apple on ATI & PPC has errors in DXT
- -- if (mGLSupport->getGLVendor().find("ATI") == std::string::npos)
- -- endif
- -}
- --------------------------------------------------------------------------------
- ++ (if supports "GL_EXT_texture_compression_s3tc" then [RSC_TEXTURE_COMPRESSION_DXT] else [])
- -- Check for vtc compression
- ++ (if supports "GL_NV_texture_compression_vtc" then [RSC_TEXTURE_COMPRESSION_VTC] else [])
-
- -- 2-sided stencil?
- caps16 = if (glVer 2 0 || supports "GL_EXT_stencil_two_side") then [RSC_TWO_SIDED_STENCIL] else []
- caps17 = if (glVer 1 4 || supports "GL_EXT_stencil_wrap") then [RSC_STENCIL_WRAP] else []
-
- -- Check for hardware occlusion support
- caps18 = case glVer 1 5 || supports "GL_ARB_occlusion_query" of
- -- Some buggy driver claim that it is GL 1.5 compliant and not support ARB_occlusion_query
- { True -> [RSC_HWOCCLUSION] ++ (if not (supports "GL_ARB_occlusion_query") then [RSC_GL1_5_NOHWOCCLUSION] else [])
- -- Support NV extension too for old hardware
- ; False -> if supports "GL_NV_occlusion_query" then [RSC_HWOCCLUSION] else []
- }
- -- Check for non-power-of-2 texture support
- caps19 = if (supports "GL_ARB_texture_non_power_of_two") then [RSC_NON_POWER_OF_2_TEXTURES] else []
-
- -- Check for Float textures
- caps20 = if (supports "GL_ATI_texture_float" || supports "GL_ARB_texture_float") then [RSC_TEXTURE_FLOAT] else []
-
- -- Check for framebuffer object extension
- (numMTR,caps21) <- case supports "GL_EXT_framebuffer_object" of
- { True -> do
- -- Probe number of draw buffers
- -- Only makes sense with FBO support, so probe here
- (n,c) <- case glVer 2 0 || supports "GL_ARB_draw_buffers" || supports "GL_ATI_draw_buffers" of
- { True -> do
- m <- GL.get GL.maxDrawBuffers
- -- Before GL version 2.0, we need to get one of the extensions
- let cp = case (glVer 2 0, supports "GL_ARB_draw_buffers", supports "GL_ATI_draw_buffers") of
- { (False,True,True) -> [RSC_FBO_ARB,RSC_FBO_ATI]
- ; (False,True,False) -> [RSC_FBO_ARB]
- ; (False,False,True) -> [RSC_FBO_ATI]
- ; _ -> []
- }
- -- Set FBO flag for all 3 'subtypes'
- return (m,[RSC_MRT_DIFFERENT_BIT_DEPTHS,RSC_FBO] ++ cp)
- ; False -> return (0,[])
- }
- return (n,RSC_HWRENDER_TO_TEXTURE:c)
- ; False -> do
- -- TODO
- ----------------------------------------------
- {-
- // Check GLSupport for PBuffer support
- if(mGLSupport->supportsPBuffers())
- {
- // Use PBuffers
- rsc->setCapability(RSC_HWRENDER_TO_TEXTURE);
- rsc->setCapability(RSC_PBUFFER);
- }
- -}
- ----------------------------------------------
- return (0,[])
- }
- ------------------------------------------------------
- -- FIXE: haskell gl binding does not have query for GL_POINT_SIZE_RANGE
- -- Point size
- (_,maxPointSize) <- GL.get GL.pointSizeRange
- {-
- if (GLEW_VERSION_1_4)
- {
- float ps;
- glGetFloatv(GL_POINT_SIZE_MAX, &ps);
- rsc->setMaxPointSize(ps);
- }
- else
- {
- GLint vSize[2];
- glGetIntegerv(GL_POINT_SIZE_RANGE,vSize);
- rsc->setMaxPointSize(vSize[1]);
- }
- -}
- -- Point size: Ends here
- ------------------------------------------------------
-
- -- Vertex texture fetching
- (numVertTexUnits,caps22,vertTexUnitsShared) <- case supports "GL_ARB_vertex_shader" of
- { True -> do
- vunits <- GL.get GL.maxVertexTextureImageUnits
- -- GL always shares vertex and fragment texture units (for now?)
- return (vunits,if vunits > 0 then [RSC_VERTEX_TEXTURE_FETCH] else [], True)
- ; False -> return (0,[],False)
- }
-
- -- Mipmap LOD biasing?
- let caps23 = if (glVer 1 4 || supports "GL_EXT_texture_lod_bias") then [RSC_MIPMAP_LOD_BIAS] else []
-
- -- Alpha to coverage?
- -- Alpha to coverage always 'supported' when MSAA is available
- -- although card may ignore it if it doesn't specifically support A2C
- caps24 = if (supports "GL_ARB_multisample") then [RSC_ALPHA_TO_COVERAGE] else []
-
- -- Advanced blending operations
- caps25 = if (glVer 2 0) then [RSC_ADVANCED_BLEND_OPERATIONS] else []
- return RenderSystemCapabilities
- { rscDriverVersion = driverVersion
- , rscVendor = vendorName
-
--- , rscNumWorldMatrices :: Int -- ^ The number of world matrices available
- , rscNumTextureUnits = fromIntegral numTexUnits
- , rscStencilBufferBitDepth = fromIntegral stencilBits
--- , rscNumVertexBlendMatrices :: Int
- , rscCapabilities = Set.fromList $ caps0 ++ caps1 ++ caps2 ++ caps3 ++ caps4 ++ caps5 ++ caps6 ++ caps7 ++ caps8 ++ caps9
- ++ caps10 ++ caps11 ++ caps12 ++ caps13 ++ caps14 ++ caps15 ++ caps16 ++ caps17 ++ caps18 ++ caps19
- ++ caps20 ++ caps21 ++ caps22 ++ caps23 ++ caps24 ++ caps25
-
- , rscDeviceName = deviceName
- , rscRenderSystemName = "OpenGL Rendering Subsystem"
--- TODO
- , rscVertexProgramConstantFloatCount = undefined
- , rscVertexProgramConstantIntCount = undefined
- , rscVertexProgramConstantBoolCount = undefined
-
- , rscGeometryProgramConstantFloatCount = undefined
- , rscGeometryProgramConstantIntCount = undefined
- , rscGeometryProgramConstantBoolCount = undefined
-
- , rscFragmentProgramConstantFloatCount = fragConstFloat
- , rscFragmentProgramConstantIntCount = fragConstInt
- , rscFragmentProgramConstantBoolCount = fragConstBool
-
- , rscNumMultiRenderTargets = fromIntegral numMTR
- , rscMaxPointSize = realToFrac maxPointSize
- , rscNonPOW2TexturesLimited = False
- , rscNumVertexTextureUnits = fromIntegral numVertTexUnits
- , rscVertexTextureUnitsShared = vertTexUnitsShared
--- TODO
- , rscGeometryProgramNumOutputVertices = undefined
-
- , rscSupportedShaderProfiles = Set.fromList $ prof1 ++ prof2 ++ prof3
- }
-
diff --git a/Graphics/LambdaCube/RenderSystem/GL/GLGpuProgram.hs b/Graphics/LambdaCube/RenderSystem/GL/GLGpuProgram.hs
deleted file mode 100644
--- a/Graphics/LambdaCube/RenderSystem/GL/GLGpuProgram.hs
+++ /dev/null
@@ -1,147 +0,0 @@
-module Graphics.LambdaCube.RenderSystem.GL.GLGpuProgram where
-
-import Data.Either
-
-import System.Log.Logger
-import Graphics.Rendering.OpenGL (($=))
-import qualified Graphics.Rendering.OpenGL as GL
-
-import Graphics.LambdaCube.HardwareVertexBuffer
-import Graphics.LambdaCube.GpuProgram
-import Graphics.LambdaCube.GpuProgramParams
-
--- Some drivers (e.g. OS X on nvidia) incorrectly determine the attribute binding automatically
--- and end up aliasing existing built-ins. So avoid! Fixed builtins are:
-
--- a builtin custom attrib name
--- ----------------------------------------------
--- 0 gl_Vertex vertex
--- 1 n/a blendWeights
--- 2 gl_Normal normal
--- 3 gl_Color colour
--- 4 gl_SecondaryColor secondary_colour
--- 5 gl_FogCoord fog_coord
--- 7 n/a blendIndices
--- 8 gl_MultiTexCoord0 uv0
--- 9 gl_MultiTexCoord1 uv1
--- 10 gl_MultiTexCoord2 uv2
--- 11 gl_MultiTexCoord3 uv3
--- 12 gl_MultiTexCoord4 uv4
--- 13 gl_MultiTexCoord5 uv5
--- 14 gl_MultiTexCoord6 uv6, tangent
--- 15 gl_MultiTexCoord7 uv7, binormal
-getFixedAttributeIndex :: VertexElementSemantic -> Int -> Int
-getFixedAttributeIndex semantic index = case semantic of
- { VES_POSITION -> 0
- ; VES_BLEND_WEIGHTS -> 1
- ; VES_NORMAL -> 2
- ; VES_DIFFUSE -> 3
- ; VES_SPECULAR -> 4
- ; VES_BLEND_INDICES -> 7
- ; VES_TEXTURE_COORDINATES -> 8 + index
- ; VES_TANGENT -> 14
- ; VES_BINORMAL -> 15
- --; _ -> error "Missing attribute!"
- }
-
-isAttributeValid :: VertexElementSemantic -> Int -> Bool
-isAttributeValid semantic index = case semantic of
- { VES_POSITION -> False
- ; VES_NORMAL -> False
- ; VES_DIFFUSE -> False
- ; VES_SPECULAR -> False
- ; VES_TEXTURE_COORDINATES -> False
- ; VES_BLEND_WEIGHTS -> True
- ; VES_BLEND_INDICES -> True
- ; VES_BINORMAL -> True
- ; VES_TANGENT -> True
- }
-{-
-data GLGpuProgram
- = GLGpuProgram
- { glgpType :: GpuProgramType -- ^ The type of the program
- , glgpFilename :: String -- ^ The name of the file to load source from (may be blank)
- , glgpSource :: String -- ^ The assembler source of the program (may be blank until file loaded)
- , glgpLoadFromFile :: Bool -- ^ Whether we need to load source from file or not
- , glgpSyntaxCode :: String -- ^ Syntax code e.g. arbvp1, vs_2_0 etc
- , glgpSkeletalAnimation :: Bool -- ^ Does this (vertex) program include skeletal animation?
- , glgpMorphAnimation :: Bool -- ^ Does this (vertex) program include morph animation?
- , glgpPoseAnimation :: Int -- ^ Does this (vertex) program include pose animation (count of number of poses supported)
- , glgpVertexTextureFetch :: Bool -- ^ Does this (vertex) program require support for vertex texture fetch?
- , glgpNeedsAdjacencyInfo :: Bool -- ^ Does this (geometry) program require adjacency information?
- , glgpDefaultParams :: GpuProgramParameters -- ^ The default parameters for use with this object
- , glgpCompileError :: Bool -- ^ Did we encounter a compilation error?
-
- , glgpProgramObject :: GL.Program
- }
--}
-data GLGpuProgram
- = GLGpuProgram
- { glgpShaderObject :: Either GL.VertexShader GL.FragmentShader
- }
- deriving Eq
-
-data GLLinkedGpuProgram
- = GLLinkedGpuProgram
- { gllgpProgramObject :: GL.Program
- }
- deriving Eq
-
-instance LinkedGpuProgram GLLinkedGpuProgram --where
-
-instance GpuProgram GLGpuProgram --where
--- gpType = undefined
-
-compileShader src = do
- [shader] <- GL.genObjectNames 1
- GL.shaderSource shader $= [src]
- GL.compileShader shader
-
- -- TEMP CODE
- infoLog <- GL.get (GL.shaderInfoLog shader)
- infoM "ResourceLibrary" $ "infoLog cmp " ++ infoLog
- ok <- GL.get (GL.compileStatus shader)
- case ok of
- { False -> do
- GL.deleteObjectNames [shader]
- errl <- GL.get GL.errors
- return $ Right $ "shader compilation failed: " ++ concat [show c ++ " - " ++ m ++ "\n" | GL.Error c m <- errl]
- ; True -> return $ Left shader
- }
-
-mkGLGpuProgram ptype src = case ptype of
- { GPT_VERTEX_PROGRAM -> do
- debugM "ResourceLibrary" $ "compiling vertex shader: "
- s <- compileShader src
- case s of
- { Right m -> return $ Right m
- ; Left sh -> return $ Left $ GLGpuProgram $ Left sh
- }
- ; GPT_FRAGMENT_PROGRAM -> do
- debugM "ResourceLibrary" $ "compiling fragment shader: "
- s <- compileShader src
- case s of
- { Right m -> return $ Right m
- ; Left sh -> return $ Left $ GLGpuProgram $ Right sh
- }
- ; GPT_GEOMETRY_PROGRAM -> undefined
- }
-
-mkGLLinkedGpuProgram :: [GLGpuProgram] -> IO (Either GLLinkedGpuProgram String)
-mkGLLinkedGpuProgram pl = do
- [p] <- GL.genObjectNames 1
- let vp = lefts $ map glgpShaderObject pl
- fp = rights $ map glgpShaderObject pl
- GL.attachedShaders p $= (vp, fp)
- GL.linkProgram p
-
- ok <- GL.get (GL.linkStatus p)
- infoLog <- GL.get (GL.programInfoLog p)
- infoM "ResourceLibrary" $ "infoLog link " ++ infoLog
- case ok of
- { False -> do
- GL.deleteObjectNames [p]
- errl <- GL.get GL.errors
- return $ Right $ "GpuProgram linking failed: " ++ concat [show c ++ " - " ++ m ++ "\n" | GL.Error c m <- errl]
- ; True -> return $ Left $ GLLinkedGpuProgram p
- }
diff --git a/Graphics/LambdaCube/RenderSystem/GL/GLIndexBuffer.hs b/Graphics/LambdaCube/RenderSystem/GL/GLIndexBuffer.hs
deleted file mode 100644
--- a/Graphics/LambdaCube/RenderSystem/GL/GLIndexBuffer.hs
+++ /dev/null
@@ -1,142 +0,0 @@
-module Graphics.LambdaCube.RenderSystem.GL.GLIndexBuffer where
-
-import Data.Word
-import Data.Maybe
-import Foreign.Marshal.Alloc
-import Foreign.Marshal.Utils
-import Foreign.Storable
-import Foreign.C.Types
-import Foreign.Ptr
-import Data.IORef
-import Control.Monad
-
-import Graphics.Rendering.OpenGL (($=))
-import qualified Graphics.Rendering.OpenGL as GL
-
-import Graphics.LambdaCube.RenderSystem
-import Graphics.LambdaCube.HardwareBuffer
-import Graphics.LambdaCube.HardwareIndexBuffer
-import Graphics.LambdaCube.RenderSystem.GL.GLUtils
-
-
--- | Specialisation of HardwareIndexBuffer for GL
-data GLIndexBuffer
- = GLIndexBuffer
- { glibType :: IndexType
- , glibNumIndexes :: Int
-
- , glibUsage :: Usage
- , glibLockInfo :: IORef (Maybe (Int,Int,Bool)) -- LockStart LockSize RequireUpdate
-
- , glibShadowBuffer :: Maybe (Ptr Word8)
- , glibBufferObject :: Maybe GL.BufferObject
- }
- deriving Eq
-
-instance HardwareIndexBuffer GLIndexBuffer where
- getIndexType = glibType
- getNumIndexes = glibNumIndexes
- getIndexSize b = case getIndexType b of
- { IT_16BIT -> 2
- ; IT_32BIT -> 4
- }
-
-instance HardwareBuffer GLIndexBuffer where
- getSizeInBytes b = getIndexSize b * glibNumIndexes b
- isSystemMemory = isNothing . glibBufferObject
- hasShadowBuffer b = (isJust $ glibShadowBuffer b) && (isJust $ glibBufferObject b)
- getUsage = glibUsage
- isLocked = glibIsLocked
- unlock = glibUnlock
- lock = glibLock
-
-glibIsLocked b = do
- i <- readIORef $ glibLockInfo b
- return $ isJust i
-
-glibLock a offs len opts = do
- lockinfo <- readIORef (glibLockInfo a)
- when (isJust lockinfo) $ error "Cannot lock this buffer, it is already locked!"
- writeIORef (glibLockInfo a) $ Just (offs,len,opts /= HBL_READ_ONLY)
- case glibShadowBuffer a of
- { Just b -> return $ plusPtr b offs
- ; Nothing -> do
- GL.bindBuffer GL.ElementArrayBuffer $= (glibBufferObject a)
- -- Discard if required
- when (opts == HBL_DISCARD) $ GL.bufferData GL.ElementArrayBuffer $= (fromIntegral $ getSizeInBytes a, nullPtr, getGLUsage $ getUsage a)
- let isWriteOnly = case getUsage a of
- { HBU_WRITE_ONLY -> True
- ; HBU_STATIC_WRITE_ONLY -> True
- ; HBU_DYNAMIC_WRITE_ONLY -> True
- ; HBU_DYNAMIC_WRITE_ONLY_DISCARDABLE -> True
- ; _ -> False
- }
- access = case (isWriteOnly,opts == HBL_READ_ONLY) of
- { (False,False) -> GL.ReadWrite
- ; (False,True) -> GL.ReadOnly
- ; (True,_) -> GL.WriteOnly
- }
- mb <- GL.mapBuffer GL.ElementArrayBuffer access
- case mb of
- { Just b -> return $ plusPtr b offs
- ; Nothing -> error "Index Buffer: Out of memory"
- }
- }
-
-glibUnlock a = do
- lockinfo <- readIORef (glibLockInfo a)
- let (lockStart,lockSize,reqUpdate) = case lockinfo of
- { Just li -> li
- ; Nothing -> error "Cannot unlock this buffer, it is not locked!"
- }
- writeIORef (glibLockInfo a) Nothing
- case glibShadowBuffer a of
- { Just b -> when reqUpdate $ do -- If we used the shadow buffer this time...
- GL.bindBuffer GL.ElementArrayBuffer $= (glibBufferObject a)
- case lockStart == 0 && lockSize == getSizeInBytes a of
- { True -> GL.bufferData GL.ElementArrayBuffer $= (fromIntegral lockSize, b, getGLUsage $ getUsage a)
- ; False -> GL.bufferSubData GL.ElementArrayBuffer GL.WriteToBuffer (fromIntegral lockStart) (fromIntegral lockSize) b
- }
- ; Nothing -> do
- GL.bindBuffer GL.ElementArrayBuffer $= (glibBufferObject a)
- ok <- GL.unmapBuffer GL.ElementArrayBuffer
- unless ok $ error "Buffer data corrupted, please reload"
- }
-
---mkGLIndexBuffer :: RenderSystem rs vb _ _ => rs -> IndexType -> Int -> Usage -> Bool -> IO GLIndexBuffer
-mkGLIndexBuffer rs itype numIndexes usage useShadowBuffer = do
- let isize = case itype of
- { IT_16BIT -> 2
- ; IT_32BIT -> 4
- }
- lockinfo <- newIORef Nothing
- [bufferObject] <- GL.genObjectNames 1
- GL.bindBuffer GL.ElementArrayBuffer $= Just bufferObject
- GL.bufferData GL.ElementArrayBuffer $= (fromIntegral $ numIndexes * isize, nullPtr, getGLUsage usage)
- shadowBuffer <- case useShadowBuffer of
- { True -> do
- b <- mallocBytes $ numIndexes * isize
- return $ Just b
- ; False -> return Nothing
- }
- return $ GLIndexBuffer
- { glibType = itype
- , glibNumIndexes = numIndexes
-
- , glibUsage = usage
- , glibLockInfo = lockinfo
-
- , glibShadowBuffer = shadowBuffer
- , glibBufferObject = Just bufferObject
- }
-
-rmGLIndexBuffer :: GLIndexBuffer -> IO ()
-rmGLIndexBuffer a = do
- case glibBufferObject a of
- { Just b -> GL.deleteObjectNames [b]
- ; Nothing -> return ()
- }
- case glibShadowBuffer a of
- { Just b -> free b
- ; Nothing -> return ()
- }
diff --git a/Graphics/LambdaCube/RenderSystem/GL/GLOcclusionQuery.hs b/Graphics/LambdaCube/RenderSystem/GL/GLOcclusionQuery.hs
deleted file mode 100644
--- a/Graphics/LambdaCube/RenderSystem/GL/GLOcclusionQuery.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-module Graphics.LambdaCube.RenderSystem.GL.GLOcclusionQuery where
-
-import Graphics.Rendering.OpenGL (($=))
-import qualified Graphics.Rendering.OpenGL as GL
-
-import Graphics.LambdaCube.HardwareOcclusionQuery
-
-data GLOcclusionQuery
- = GLOcclusionQuery
- { gloqQueryObject :: GL.QueryObject
- }
-
-instance HardwareOcclusionQuery GLOcclusionQuery where
- beginOcclusionQuery = glBeginOcclusionQuery
- endOcclusionQuery = glEndOcclusionQuery
- pullOcclusionQuery = glPullOcclusionQuery
--- getLastQuerysPixelcount :: a -> IO Int
- isStillOutstanding = glStillOutstanding
-
-mkGLOcclusionQuery = do
- [q] <- GL.genObjectNames 1
- return $ GLOcclusionQuery q
-
-rmGLOcclusionQuery o = do
- GL.deleteObjectNames [gloqQueryObject o]
-
-glBeginOcclusionQuery o = GL.beginQuery GL.SamplesPassed $ gloqQueryObject o
-
-glEndOcclusionQuery o = GL.endQuery GL.SamplesPassed
-
-glPullOcclusionQuery o = do
- c <- GL.get $ GL.queryResult $ gloqQueryObject o
- return $ fromIntegral c
-
-glStillOutstanding o = do
- b <- GL.get $ GL.queryResultAvailable $ gloqQueryObject o
- return $ not b
diff --git a/Graphics/LambdaCube/RenderSystem/GL/GLRenderSystem.hs b/Graphics/LambdaCube/RenderSystem/GL/GLRenderSystem.hs
deleted file mode 100644
--- a/Graphics/LambdaCube/RenderSystem/GL/GLRenderSystem.hs
+++ /dev/null
@@ -1,1402 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-module Graphics.LambdaCube.RenderSystem.GL.GLRenderSystem where
-
-import Data.IntMap ((!))
-import qualified Data.Map as Map
-import qualified Data.IntMap as IntMap
-import qualified Data.Set as Set
-import Data.IORef
-import Data.Word
-import Data.Maybe
-import Control.Monad
-import Foreign.C.Types
-import Foreign.Ptr
-
-import Graphics.Rendering.OpenGL (($=))
-import qualified Graphics.Rendering.OpenGL as GL
-
-import Graphics.LambdaCube.Types
-import Graphics.LambdaCube.Common
-import Graphics.LambdaCube.Math
-import Graphics.LambdaCube.BlendMode
-import Graphics.LambdaCube.HardwareBuffer
-import Graphics.LambdaCube.HardwareVertexBuffer
-import Graphics.LambdaCube.HardwareIndexBuffer
-import Graphics.LambdaCube.VertexIndexData
-import Graphics.LambdaCube.RenderOperation
-import Graphics.LambdaCube.Texture
-import Graphics.LambdaCube.TextureUnitState
-import Graphics.LambdaCube.GpuProgram
-import Graphics.LambdaCube.RenderSystemCapabilities
-import Graphics.LambdaCube.RenderSystem
-import Graphics.LambdaCube.RenderSystem.GL.GLGpuProgram
-import Graphics.LambdaCube.RenderSystem.GL.GLTexture
-import Graphics.LambdaCube.RenderSystem.GL.GLVertexBuffer
-import Graphics.LambdaCube.RenderSystem.GL.GLIndexBuffer
-import Graphics.LambdaCube.RenderSystem.GL.GLOcclusionQuery
-import Graphics.LambdaCube.RenderSystem.GL.GLUtils
-import Graphics.LambdaCube.RenderSystem.GL.GLCapabilities
-
-data GLRenderSystem
- = GLRenderSystem
- { glrsWorldMatrix :: IORef (GL.GLmatrix GL.GLfloat)
- , glrsViewMatrix :: IORef (GL.GLmatrix GL.GLfloat)
- , glrsCapabilities :: RenderSystemCapabilities
- }
-
-mkGLRenderSystem = do
- mat <- toGLMatrix $ scal 1
- worldMat <- newIORef mat
- viewMat <- newIORef mat
- cap <- mkGLCapabilities
-
- -- Initialize OpenGL
- extSList <- GL.get GL.glExtensions
- (major,minor) <- GL.get $ GL.majorMinor GL.glVersion
- -- setup capabilities
- let ext = Set.fromList extSList
- glVer a b = major > a || (major >= a && minor >= b)
- supports s = Set.member s ext
-
- when (glVer 1 2) $ do
- -- Set nicer lighting model -- d3d9 has this by default
- GL.lightModelColorControl $= GL.SeparateSpecularColor
- GL.lightModelLocalViewer $= GL.Enabled
-
- when (glVer 1 4) $ do
- GL.colorSum $= GL.Enabled
- GL.dither $= GL.Disabled
-
- -- Check for FSAA
- when (supports "GL_ARB_multisample") $ do
- fsaa <- GL.get GL.sampleBuffers
- when (fsaa > 0) $
- GL.multisample $= GL.Enabled
-
- return $ GLRenderSystem
- { glrsWorldMatrix = worldMat
- , glrsViewMatrix = viewMat
- , glrsCapabilities = cap
- }
-
-glDirtyHackCopyTexImage tex x y w h = do
- GL.textureBinding GL.Texture2D $= (Just $ gltxTextureObject tex)
- -- only hint code: glCopyTexImage2D(GL_TEXTURE_2D, 0, GL_LUMINANCE, 0, 0, 128, 128, 0);
- GL.copyTexImage2D Nothing 0 GL.RGBA' (GL.Position (fromIntegral x) (fromIntegral y)) (GL.TextureSize2D (fromIntegral w) (fromIntegral h)) 0
-
-
-instance RenderSystem GLRenderSystem GLVertexBuffer GLIndexBuffer GLOcclusionQuery GLTexture GLGpuProgram GLLinkedGpuProgram where
- dirtyHackCopyTexImage _ = glDirtyHackCopyTexImage
- getName _ = "OpenGL Rendering Subsystem"
- getCapabilities = glrsCapabilities
- createVertexBuffer = mkGLVertexBuffer
- createIndexBuffer = mkGLIndexBuffer
- createOcclusionQuery _ = mkGLOcclusionQuery
- createTexture rs = mkGLTexture (glrsCapabilities rs)
- createGpuProgram _ = mkGLGpuProgram
- createLinkedGpuProgram _ = mkGLLinkedGpuProgram
- bindLinkedGpuProgram _ = glBindLinkedGpuProgram
- unbindLinkedGpuProgram _ = glUnBindLinkedGpuProgram
- render _ = glRender
- bindGeometry _ = glBindGeometry
- unbindGeometry rs = glUnBindGeometry (glrsCapabilities rs)
- setViewport _ x y w h = glSetViewport x y w h
- setPolygonMode _ pm = glSetPolygonMode pm
- setWorldMatrix = glSetWorldMatrix
- setViewMatrix = glSetViewMatrix
- setProjectionMatrix _ m = glSetProjectionMatrix m
- clearFrameBuffer _ b c d s = glClearFrameBuffer b c d s
- setShadingType _ = glSetShadingType
- setCullingMode _ = glSetCullingMode
- setAlphaRejectSettings rs = glSetAlphaRejectSettings (glrsCapabilities rs)
- setDepthBias _ = glSetDepthBias
- setDepthBufferWriteEnabled _ = glSetDepthBufferWriteEnabled
- setDepthBufferFunction _ = glSetDepthBufferFunction --FIXME
- setColourBufferWriteEnabled _ = glSetColourBufferWriteEnabled
- setSurfaceParams _ = glSetSurfaceParams
- setLightingEnabled _ = glSetLightingEnabled
- setFog _ = glSetFog
- setSceneBlending _ = glSetSceneBlending
- setSeparateSceneBlending _ = glSetSeparateSceneBlending
- setPointParameters = glSetPointParameters
- setPointSpritesEnabled rs = glSetPointSpritesEnabled (glrsCapabilities rs)
- setActiveTextureUnit _ = glSetActiveTextureUnit
- setTexture _ = glSetTexture
- setTextureAddressingMode _ = glSetTextureAddressingMode
- setTextureUnitFiltering _ = glSetTextureUnitFiltering
- setTextureLayerAnisotropy _ = glSetTextureLayerAnisotropy
- setTextureMipmapBias _ = glSetTextureMipmapBias
- setTextureMatrix _ = glSetTextureMatrix
- setTextureBorderColour _ = glSetTextureBorderColour
- setTextureCoordCalculation _ = glSetTextureCoordCalculation
- setTextureBlendMode rs = glSetTextureBlendMode (glrsCapabilities rs)
- getMinimumDepthInputValue _ = -1
- getMaximumDepthInputValue _ = 1
-
-
-glSetDepthBias constantBias slopeScaleBias = case constantBias /= 0 || slopeScaleBias /= 0 of
- { True -> do
- GL.polygonOffsetFill $= GL.Enabled
- GL.polygonOffsetPoint $= GL.Enabled
- GL.polygonOffsetLine $= GL.Enabled
- GL.polygonOffset $= (realToFrac (-slopeScaleBias), realToFrac (-constantBias))
- ; False -> do
- GL.polygonOffsetFill $= GL.Disabled
- GL.polygonOffsetPoint $= GL.Disabled
- GL.polygonOffsetLine $= GL.Disabled
- }
-
-glSetViewport x y w h = do
- let x' = fromIntegral x
- y' = fromIntegral y
- w' = fromIntegral w
- h' = fromIntegral h
- GL.viewport $= (GL.Position x' y', GL.Size w' h')
- GL.scissor $= Just (GL.Position x' y', GL.Size w' h') -- Configure the viewport clipping
-
-glSetPolygonMode pm = case pm of
- { PM_POINTS -> GL.polygonMode $= (GL.Point,GL.Point)
- ; PM_WIREFRAME -> GL.polygonMode $= (GL.Line,GL.Line)
- ; PM_SOLID -> GL.polygonMode $= (GL.Fill,GL.Fill)
- }
-
-glSetWorldMatrix rs m = do
- worldMat <- toGLMatrix m
- writeIORef (glrsWorldMatrix rs) worldMat
- viewMat <- readIORef $ glrsViewMatrix rs
- GL.matrixMode $= (GL.Modelview 0)
- GL.matrix (Just (GL.Modelview 0)) $= viewMat
- GL.multMatrix worldMat
-
-glSetViewMatrix rs m = do
- viewMat <- toGLMatrix m
- writeIORef (glrsViewMatrix rs) viewMat
- worldMat <- readIORef $ glrsWorldMatrix rs
- GL.matrixMode $= (GL.Modelview 0)
- GL.matrix (Just (GL.Modelview 0)) $= viewMat
- GL.multMatrix worldMat
-
-glSetProjectionMatrix m = do
- mat <- toGLMatrix m
- GL.matrix (Just GL.Projection) $= mat
-
-glClearFrameBuffer buffers colour depth stencil = do
- tmpColorMask <- GL.get GL.colorMask
- tmpDepthMask <- GL.get GL.depthMask
- tmpStencilMask <- GL.get GL.stencilMask
- tmpScissor <- GL.get GL.scissor
-
- when (fbtColour buffers) $ do
- let (r',g',b',a') = colour
- (r,g,b,a) = (f r',f g',f b',f a')
- f :: FloatType -> GL.GLclampf
- f = realToFrac
- GL.colorMask $= GL.Color4 GL.Enabled GL.Enabled GL.Enabled GL.Enabled
- GL.clearColor $= GL.Color4 r g b a
-
- when (fbtDepth buffers) $ do
- let f :: FloatType -> GL.GLclampd
- f = realToFrac
- GL.depthMask $= GL.Enabled
- GL.clearDepth $= f depth
-
- when (fbtStencil buffers) $ do
- let f :: Word16 -> GL.GLint
- f = fromIntegral
- GL.stencilMask $= (maxBound::GL.GLuint)
- GL.clearStencil $= f stencil
-
- view <- GL.get GL.viewport
- GL.scissor $= Just view
-
- -- HINT: workaround for a mesa gma bug
- when (fbtColour buffers) $ GL.clear [GL.ColorBuffer]
- when (fbtDepth buffers) $ GL.clear [GL.DepthBuffer]
- when (fbtStencil buffers) $ GL.clear [GL.StencilBuffer]
- --GL.clear $ map fst $ filter (\(_,b) -> b) $ zip [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer] [fbtColour buffers, fbtDepth buffers, fbtStencil buffers]
-
- GL.scissor $= tmpScissor
-
- GL.depthMask $= tmpDepthMask
- GL.colorMask $= tmpColorMask
- GL.stencilMask $= tmpStencilMask
-
-
---glBindGeometry :: (HardwareVertexBuffer vb, HardwareIndexBuffer ib) => RenderOperation vb ib -> IO ()
---glBindGeometry :: RenderOperation GLVertexBuffer GLIndexBuffer -> IO ()
-glBindGeometry ro tl = do
- let multitexturing = True -- 1 < (rscNumTextureUnits rcap)
- vertexData = roVertexData ro
- decl = vdVertexDeclaration vertexData
- checkBinding e = case vdVertexBufferBinding vertexData of
- VertexBufferBinding bm -> veSource e `IntMap.member` bm
- -- bind vertex elements
- mapM_ (bindElement ro tl) $ filter checkBinding $ vdElementList decl
-
- when multitexturing $ GL.clientActiveTexture $= GL.TextureUnit 0
- -- bind index data and call draw operation
- case roIndexData ro of
- { Just indexData -> do
- let indexBuffer = idIndexBuffer indexData
- GL.bindBuffer GL.ElementArrayBuffer $= glibBufferObject indexBuffer
- ; Nothing -> return ()
- }
-
---glUnBindGeometry :: RenderOperation GLVertexBuffer GLIndexBuffer -> IO ()
-glUnBindGeometry rsc ro = do
- let multitexturing = True -- 1 < (rscNumTextureUnits rcap)
- f :: Int -> GL.GLuint
- f = fromIntegral
-
- GL.clientState GL.VertexArray $= GL.Disabled
-
- -- only valid up to GL_MAX_TEXTURE_UNITS, which is recorded in mFixedFunctionTextureUnits
- case multitexturing of
- { True -> do
- forM_ [0..(rscNumTextureUnits rsc - 1)] $ \stage -> do
- GL.clientActiveTexture $= (GL.TextureUnit $ f stage)
- GL.clientState GL.TextureCoordArray $= GL.Disabled
- GL.clientActiveTexture $= GL.TextureUnit 0
- ; False -> GL.clientState GL.TextureCoordArray $= GL.Disabled
- }
- GL.clientState GL.NormalArray $= GL.Disabled
- GL.clientState GL.ColorArray $= GL.Disabled
- GL.clientState GL.SecondaryColorArray $= GL.Disabled
-
- -- unbind any custom attributes
- {-
- for (vector::type::iterator ai = attribsBound.begin(); ai != attribsBound.end(); ++ai)
- {
- glDisableVertexAttribArrayARB(*ai);
- }
- -}
-
- -- unbind buffers
- GL.bindBuffer GL.ElementArrayBuffer $= Nothing
- GL.bindBuffer GL.ArrayBuffer $= Nothing
-
--- _render :: RenderSystemCapabilities -> RenderOperation -> IO ()
---glRender :: Int -> GLRenderState -> RenderOperation -> IO GLRenderState
---glRender :: (HardwareVertexBuffer vb, HardwareIndexBuffer ib) => Int -> RenderOperation vb ib -> IO ()
-glRender :: RenderOperation GLVertexBuffer GLIndexBuffer -> IO ()
-glRender ro = do
- -- TODO:
- -- calculate statistics
- {-
- -- Update stats
- size_t val;
-
- if (op.useIndexes)
- val = op.indexData->indexCount;
- else
- val = op.vertexData->vertexCount;
-
- -- account for a pass having multiple iterations
- if (mCurrentPassIterationCount > 1)
- val *= mCurrentPassIterationCount;
- mCurrentPassIterationNum = 0;
-
- switch(op.operationType)
- {
- case RenderOperation::OT_TRIANGLE_LIST:
- mFaceCount += val / 3;
- break;
- case RenderOperation::OT_TRIANGLE_STRIP:
- case RenderOperation::OT_TRIANGLE_FAN:
- mFaceCount += val - 2;
- break;
- case RenderOperation::OT_POINT_LIST:
- case RenderOperation::OT_LINE_LIST:
- case RenderOperation::OT_LINE_STRIP:
- break;
- }
-
- mVertexCount += op.vertexData->vertexCount;
- mBatchCount += mCurrentPassIterationCount;
-
- -- sort out clip planes
- -- have to do it here in case of matrix issues
- if (mClipPlanesDirty)
- {
- setClipPlanesImpl(mClipPlanes);
- mClipPlanesDirty = false;
- }
- -}
- -- TODO
- let vertexData = roVertexData ro
- multitexturing = True -- 1 < (rscNumTextureUnits rcap)
- --Use adjacency if there is a geometry program and it requested adjacency info
- -- TODO
- --bool useAdjacency = (mGeometryProgramBound && mCurrentGeometryProgram->isAdjacencyInfoRequired());
- primType = case roOperationType ro of -- Find the correct type to render
- { OT_POINT_LIST -> GL.Points
- ; OT_LINE_LIST -> GL.Lines
- ; OT_LINE_STRIP -> GL.LineStrip
- ; OT_TRIANGLE_LIST -> GL.Triangles
- ; OT_TRIANGLE_STRIP -> GL.TriangleStrip
- ; OT_TRIANGLE_FAN -> GL.TriangleFan
- }
- {-
- GLint primType;
- switch (op.operationType)
- {
- case RenderOperation::OT_POINT_LIST:
- primType = GL_POINTS;
- break;
- case RenderOperation::OT_LINE_LIST:
- primType = useAdjacency ? GL_LINES_ADJACENCY_EXT : GL_LINES;
- break;
- case RenderOperation::OT_LINE_STRIP:
- primType = useAdjacency ? GL_LINE_STRIP_ADJACENCY_EXT : GL_LINE_STRIP;
- break;
- default:
- case RenderOperation::OT_TRIANGLE_LIST:
- primType = useAdjacency ? GL_TRIANGLES_ADJACENCY_EXT : GL_TRIANGLES;
- break;
- case RenderOperation::OT_TRIANGLE_STRIP:
- primType = useAdjacency ? GL_TRIANGLE_STRIP_ADJACENCY_EXT : GL_TRIANGLE_STRIP;
- break;
- case RenderOperation::OT_TRIANGLE_FAN:
- primType = GL_TRIANGLE_FAN;
- break;
- }
- -}
-
- -- bind index data and call draw operation
- case roIndexData ro of
- { Just indexData -> do
- let indexBuffer = idIndexBuffer indexData
- dp = if isJust $ glibBufferObject indexBuffer then nullPtr else fromMaybe (error "fromJust 7") $ glibShadowBuffer indexBuffer
- pBufferData = plusPtr dp $ idIndexStart indexData * getIndexSize indexBuffer
- indexType = if getIndexType indexBuffer == IT_16BIT then GL.UnsignedShort else GL.UnsignedInt
- GL.drawElements primType (fromIntegral (idIndexCount indexData)) indexType pBufferData
- ; Nothing -> do
- GL.drawArrays primType 0 (fromIntegral (vdVertexCount vertexData))
- }
-
--- GL.color $ GL.Color4 1 1 1 (1 :: GL.GLfloat)
--- GL.secondaryColor $ GL.Color3 0 0 (0 :: GL.GLfloat)
- return ()
-{-
- bool RenderSystem::updatePassIterationRenderState(void)
- {
- if (mCurrentPassIterationCount <= 1)
- return false;
-
- --mCurrentPassIterationCount;
- ++mCurrentPassIterationNum;
- if (!mActiveVertexGpuProgramParameters.isNull())
- {
- mActiveVertexGpuProgramParameters->incPassIterationNumber();
- bindGpuProgramPassIterationParameters(GPT_VERTEX_PROGRAM);
- }
- if (!mActiveGeometryGpuProgramParameters.isNull())
- {
- mActiveGeometryGpuProgramParameters->incPassIterationNumber();
- bindGpuProgramPassIterationParameters(GPT_GEOMETRY_PROGRAM);
- }
- if (!mActiveFragmentGpuProgramParameters.isNull())
- {
- mActiveFragmentGpuProgramParameters->incPassIterationNumber();
- bindGpuProgramPassIterationParameters(GPT_FRAGMENT_PROGRAM);
- }
- return true;
- }
-
--}
-
-bindElement rop tl elem = do
- let vertexData = roVertexData $ rop
-
- case vdVertexBufferBinding vertexData of
- VertexBufferBinding bm -> let vertexBuffer = bm ! (veSource elem) in do
- dp <- case glvbBufferObject vertexBuffer of
- { Just b -> do
- GL.bindBuffer GL.ArrayBuffer $= Just b
- return nullPtr
- ; Nothing -> return $ fromMaybe (error "fromJust 8") $ glvbShadowBuffer vertexBuffer
- }
- let pBufferData = plusPtr dp $ vdVertexStart vertexData * getVertexSize vertexBuffer + veOffset elem
- sem = veSemantic elem
- isCustomAttrib = False
- bindArray t = do
- GL.arrayPointer t $= GL.VertexArrayDescriptor (fromIntegral . getTypeCount . veType $ elem) (getGLType . veType $ elem) (fromIntegral . getVertexSize $ vertexBuffer) pBufferData
- GL.clientState t $= GL.Enabled
- {-
- if (mCurrentVertexProgram)
- isCustomAttrib = mCurrentVertexProgram->isAttributeValid(sem, elem->getIndex());
- -}
- --bind vertexBuffer
- case isCustomAttrib of
- { True -> do
- -- Custom attribute support
- -- tangents, binormals, blendweights etc always via this route
- -- builtins may be done this way too
- let attrib = GL.AttribLocation . fromIntegral . getFixedAttributeIndex sem $ veIndex elem
- GL.vertexAttribPointer attrib $= (GL.KeepIntegral,GL.VertexArrayDescriptor (fromIntegral . getTypeCount . veType $ elem) (getGLType . veType $ elem) (fromIntegral . getVertexSize $ vertexBuffer) pBufferData)
- GL.vertexAttribArray attrib $= GL.Enabled
- --attribsBound.push_back(attrib);
- ; False -> case sem of -- fixed-function & builtin attribute support
- { VES_POSITION -> bindArray GL.VertexArray
- ; VES_NORMAL -> bindArray GL.NormalArray
- ; VES_DIFFUSE -> bindArray GL.ColorArray
- ; VES_SPECULAR -> bindArray GL.SecondaryColorArray
- ; VES_TEXTURE_COORDINATES -> do
- -- TODO
- let idx = veIndex elem
- tus = map fst $ filter (\(_,a)-> idx==a) $ zip [0..] $ map tusTextureCoordSetIndex tl
- f :: Int -> GL.GLuint
- f = fromIntegral
- forM_ tus $ \tidx -> do
- --print $ "bind stage="++show tidx ++ " texcoord="++show idx
- GL.clientActiveTexture $= (GL.TextureUnit $ f tidx)
- bindArray GL.TextureCoordArray
- -- TEMP CODE
-{-
- if (mCurrentVertexProgram)
- {
- -- Programmable pipeline - direct UV assignment
- glClientActiveTextureARB(GL_TEXTURE0 + elem->getIndex());
- glTexCoordPointer(
- VertexElement::getTypeCount(elem->getType()),
- GLBufferManager::getGLType(elem->getType()),
- static_cast(vertexBuffer->getVertexSize()),
- pBufferData);
- glEnableClientState( GL_TEXTURE_COORD_ARRAY );
- }
- else
- {
- -- fixed function matching to units based on tex_coord_set
- for (i = 0; i < mDisabledTexUnitsFrom; i++)
- {
- -- Only set this texture unit's texcoord pointer if it
- -- is supposed to be using this element's index
- if (mTextureCoordIndex[i] == elem->getIndex() && i < mFixedFunctionTextureUnits)
- {
- if (multitexturing)
- glClientActiveTextureARB(GL_TEXTURE0 + i);
- glTexCoordPointer(
- VertexElement::getTypeCount(elem->getType()),
- GLBufferManager::getGLType(elem->getType()),
- static_cast(vertexBuffer->getVertexSize()),
- pBufferData);
- glEnableClientState( GL_TEXTURE_COORD_ARRAY );
- }
- }
- }
--}
- }
- }
-
-
-glSetShadingType so = case so of
- { SO_FLAT -> GL.shadeModel $= GL.Flat
- ; _ -> GL.shadeModel $= GL.Smooth
- }
-
-glSetAlphaRejectSettings rsc func value alphaToCoverage = do
- let caps = rscCapabilities rsc
- f :: Int -> GL.GLclampf
- f = fromIntegral
- case func == CMPF_ALWAYS_PASS of
- { True -> do
- GL.alphaFunc $= Nothing
- GL.sampleAlphaToCoverage $= GL.Disabled
- ; False -> do
- GL.alphaFunc $= Just (convertCompareFunction func, f value / 255)
- let f x = case x of
- { True -> GL.Enabled
- ; False -> GL.Disabled
- }
- when (Set.member RSC_ALPHA_TO_COVERAGE caps) $
- GL.sampleAlphaToCoverage $= f alphaToCoverage
- }
-
-glSetDepthBufferWriteEnabled enabled = case enabled of
- { True -> GL.depthMask $= GL.Enabled
- ; False -> GL.depthMask $= GL.Disabled
- }
-
-glSetDepthBufferFunction enabled func = do
- GL.depthFunc $= if enabled then Just $ convertCompareFunction func else Nothing
---FIXME: gl haskell binding has unified api for depthFunc
---glSetDepthBufferCheckEnabled enabled = case enabled of
-
-glSetPointSpritesEnabled rsc enabled = do
- case enabled of
- { True -> GL.pointSprite $= GL.Enabled
- ; False -> GL.pointSprite $= GL.Disabled
- }
- --FIXME: Haskell GL bininding does not support these
- {-
- let maxTex = rscNumTextureUnits rsc
- a <- GL.get GL.activeTexture
- -- Set sprite texture coord generation
- -- Don't offer this as an option since D3D links it to sprite enabled
- for (ushort i = 0; i < mFixedFunctionTextureUnits; ++i)
- {
- activateGLTextureUnit(i);
- glTexEnvi(GL_POINT_SPRITE, GL_COORD_REPLACE,
- enabled ? GL_TRUE : GL_FALSE);
- }
- GL.activeTexture $= a
- -}
-
-glSetSceneBlending sourceFactor destFactor op = do
- case sourceFactor == SBF_ONE && destFactor == SBF_ZERO of
- { True -> GL.blend $= GL.Disabled
- ; False -> do
- GL.blend $= GL.Enabled
- GL.blendFunc $= (getBlendMode sourceFactor, getBlendMode destFactor)
- }
- GL.blendEquation $= getBlendEquation op
- -- FIXME
- {-
- if(GLEW_VERSION_1_4 || GLEW_ARB_imaging)
- {
- glBlendEquation(func);
- }
- else if(GLEW_EXT_blend_minmax && (func == GL_MIN || func == GL_MAX))
- {
- glBlendEquationEXT(func);
- }
- -}
-
-glSetSurfaceParams ambient diffuse specular emissive shininess (TrackVertexColourType a d s e) = do
- -- Track vertex colour
- -- There are actually 15 different combinations for tracking, of which
- -- GL only supports the most used 5. This means that we have to do some
- -- magic to find the best match. NOTE:
- -- GL_AMBIENT_AND_DIFFUSE != GL_AMBIENT | GL__DIFFUSE
- case (a,d,s,e) of
- { (False,False,False,False) -> GL.colorMaterial $= Nothing
- ; (True,True,_,_) -> GL.colorMaterial $= Just (GL.FrontAndBack,GL.AmbientAndDiffuse)
- ; (True,False,_,_) -> GL.colorMaterial $= Just (GL.FrontAndBack,GL.Ambient)
- ; (_,True,_,_) -> GL.colorMaterial $= Just (GL.FrontAndBack,GL.Diffuse)
- ; (_,_,True,_) -> GL.colorMaterial $= Just (GL.FrontAndBack,GL.Specular)
- ; (_,_,_,True) -> GL.colorMaterial $= Just (GL.FrontAndBack,GL.Emission)
- }
- let f = realToFrac
- c (r,g,b,a) = GL.Color4 (f r) (f g) (f b) (f a)
- GL.materialDiffuse GL.FrontAndBack $= c diffuse
- GL.materialAmbient GL.FrontAndBack $= c ambient
- GL.materialSpecular GL.FrontAndBack $= c specular
- GL.materialEmission GL.FrontAndBack $= c emissive
- GL.materialShininess GL.FrontAndBack $= f shininess
-
-glSetLightingEnabled enabled = case enabled of
- { True -> GL.lighting $= GL.Enabled
- ; False -> GL.lighting $= GL.Disabled
- }
-
-glSetFog mode colour density start end = do
- let c (r,g,b,a) = GL.Color4 (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a)
- case mode of
- { FOG_NONE -> do
- GL.fog $= GL.Disabled
- ; FOG_EXP -> do
- GL.fog $= GL.Enabled
- GL.fogMode $= (GL.Exp $ realToFrac density)
- GL.fogColor $= c colour
- ; FOG_EXP2 -> do
- GL.fog $= GL.Enabled
- GL.fogMode $= (GL.Exp2 $ realToFrac density)
- GL.fogColor $= c colour
- ; FOG_LINEAR-> do
- GL.fog $= GL.Enabled
- GL.fogMode $= (GL.Linear (realToFrac start) (realToFrac end))
- GL.fogColor $= c colour
- }
-
-glSetSeparateSceneBlending sourceFactor destFactor sourceFactorAlpha destFactorAlpha op alphaOp = do
- case sourceFactor == SBF_ONE && destFactor == SBF_ZERO &&
- sourceFactorAlpha == SBF_ONE && destFactorAlpha == SBF_ZERO of
- { True -> GL.blend $= GL.Disabled
- ; False -> do
- let f = getBlendMode
- GL.blend $= GL.Enabled
- GL.blendFuncSeparate $= ((f sourceFactor, f sourceFactorAlpha), (f destFactor, f destFactorAlpha))
- }
- GL.blendEquationSeparate $= (getBlendEquation op, getBlendEquation alphaOp)
---FIXME: gl binding does not access these
-{-
- if(GLEW_VERSION_2_0) {
- glBlendEquationSeparate(func, alphaFunc);
- }
- else if(GLEW_EXT_blend_equation_separate) {
- glBlendEquationSeparateEXT(func, alphaFunc);
- }
--}
-
-glSetPointParameters rs size attenuationEnabled constant linear quadratic minSize maxSize = do
- let rsc = getCapabilities rs
- caps = rscCapabilities rsc
- (size',minSize',maxSize',constant',linear',quadratic') <- case attenuationEnabled of
- { True -> do
- -- Point size is still calculated in pixels even when attenuation is
- -- enabled, which is pretty awkward, since you typically want a viewport
- -- independent size if you're looking for attenuation.
- -- So, scale the point size up by viewport size (this is equivalent to
- -- what D3D does as standard)
-
- -- TODO
- {-
- size = size * mActiveViewport->getActualHeight();
- minSize = minSize * mActiveViewport->getActualHeight();
- if (maxSize == 0.0f)
- maxSize = mCurrentCapabilities->getMaxPointSize(); // pixels
- else
- maxSize = maxSize * mActiveViewport->getActualHeight();
- -}
- when (Set.member RSC_VERTEX_PROGRAM caps) $ GL.vertexProgramPointSize $= GL.Enabled
- -- XXX: why do I need this for results to be consistent with D3D?
- -- Equations are supposedly the same once you factor in vp height
- let correction = 0.005
- return (size,minSize,if maxSize == 0 then rscMaxPointSize rsc else maxSize,constant,linear * correction,quadratic * correction)
- ; False -> do
- when (Set.member RSC_VERTEX_PROGRAM caps) $ GL.vertexProgramPointSize $= GL.Disabled
- return (size,minSize,if maxSize == 0 then rscMaxPointSize rsc else maxSize,constant,linear,quadratic)
- }
- --no scaling required
- -- GL has no disabled flag for this so just set to constant
- let f = realToFrac
- GL.pointSize $= f size'
- GL.pointDistanceAttenuation $= (f constant',f linear',f quadratic')
- GL.pointSizeRange $= (f minSize',f maxSize')
- -- FIXME: gl binding handles this
- {-
- if (mCurrentCapabilities->hasCapability(RSC_POINT_EXTENDED_PARAMETERS))
- {
- glPointParameterfv(GL_POINT_DISTANCE_ATTENUATION, val);
- glPointParameterf(GL_POINT_SIZE_MIN, minSize);
- glPointParameterf(GL_POINT_SIZE_MAX, maxSize);
- }
- else if (mCurrentCapabilities->hasCapability(RSC_POINT_EXTENDED_PARAMETERS_ARB))
- {
- glPointParameterfvARB(GL_POINT_DISTANCE_ATTENUATION, val);
- glPointParameterfARB(GL_POINT_SIZE_MIN, minSize);
- glPointParameterfARB(GL_POINT_SIZE_MAX, maxSize);
- }
- else if (mCurrentCapabilities->hasCapability(RSC_POINT_EXTENDED_PARAMETERS_EXT))
- {
- glPointParameterfvEXT(GL_POINT_DISTANCE_ATTENUATION, val);
- glPointParameterfEXT(GL_POINT_SIZE_MIN, minSize);
- glPointParameterfEXT(GL_POINT_SIZE_MAX, maxSize);
- }
- -}
- return ()
-
-glSetActiveTextureUnit stage = do
- let f :: Int -> GL.GLuint
- f = fromIntegral
- GL.activeTexture $= GL.TextureUnit (f stage)
-{-
- if (GLEW_VERSION_1_2 && unit < getCapabilities()->getNumTextureUnits())
- {
- glActiveTextureARB(GL_TEXTURE0 + unit);
- mActiveTextureUnit = unit;
- return true;
- }
- else if (!unit)
- {
- // always ok to use the first unit
- return true;
- }
- else
- {
- return false;
- }
--}
-
-glSetTexture tex = case tex of
- { Just t -> do
- --TEMP CODE
- GL.texture GL.Texture1D $= GL.Disabled
- GL.textureBinding GL.Texture1D $= Nothing
-
- GL.texture GL.Texture2D $= GL.Disabled
- GL.textureBinding GL.Texture2D $= Nothing
-
- GL.texture GL.Texture3D $= GL.Disabled
- GL.textureBinding GL.Texture3D $= Nothing
-
- GL.texture GL.TextureCubeMap $= GL.Disabled
- GL.textureBinding GL.TextureCubeMap $= Nothing
-
- let target = getGLTextureTarget $ txTextureType t
- GL.texture target $= GL.Enabled
- GL.textureBinding target $= (Just $ gltxTextureObject t)
- ; Nothing -> do
- --TODO
- GL.texture GL.Texture1D $= GL.Disabled
- GL.textureBinding GL.Texture1D $= Nothing
-
- GL.texture GL.Texture2D $= GL.Disabled
- GL.textureBinding GL.Texture2D $= Nothing
-
- GL.texture GL.Texture3D $= GL.Disabled
- GL.textureBinding GL.Texture3D $= Nothing
-
- GL.texture GL.TextureCubeMap $= GL.Disabled
- GL.textureBinding GL.TextureCubeMap $= Nothing
- }
-
-{-
- void GLRenderSystem::_setTexture(size_t stage, bool enabled, const TexturePtr &texPtr)
- {
- GLTexturePtr tex = texPtr;
-
- GLenum lastTextureType = mTextureTypes[stage];
-
- if (!activateGLTextureUnit(stage))
- return;
-
- if (enabled)
- {
- if (!tex.isNull())
- {
- // note used
- tex->touch();
- mTextureTypes[stage] = tex->getGLTextureTarget();
- }
- else
- // assume 2D
- mTextureTypes[stage] = GL_TEXTURE_2D;
-
- if(lastTextureType != mTextureTypes[stage] && lastTextureType != 0)
- {
- if (stage < mFixedFunctionTextureUnits)
- {
- glDisable( lastTextureType );
- }
- }
-
- if (stage < mFixedFunctionTextureUnits)
- {
- glEnable( mTextureTypes[stage] );
- }
-
- if(!tex.isNull())
- glBindTexture( mTextureTypes[stage], tex->getGLID() );
- else
- glBindTexture( mTextureTypes[stage], static_cast(mTextureManager)->getWarningTextureID() );
- }
- else
- {
- if (stage < mFixedFunctionTextureUnits)
- {
- if (lastTextureType != 0)
- {
- glDisable( mTextureTypes[stage] );
- }
- glTexEnvf(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE);
- }
- // bind zero texture
- glBindTexture(GL_TEXTURE_2D, 0);
- }
-
- activateGLTextureUnit(0);
- }
-
- void GLRenderSystem::_setTextureCoordSet(size_t stage, size_t index)
- {
- mTextureCoordIndex[stage] = index;
- }
--}
-{-
- void GLRenderSystem::_useLights(const LightList& lights, unsigned short limit)
- {
- // Save previous modelview
- glMatrixMode(GL_MODELVIEW);
- glPushMatrix();
- // just load view matrix (identity world)
- GLfloat mat[16];
- makeGLMatrix(mat, mViewMatrix);
- glLoadMatrixf(mat);
-
- LightList::const_iterator i, iend;
- iend = lights.end();
- unsigned short num = 0;
- for (i = lights.begin(); i != iend && num < limit; ++i, ++num)
- {
- setGLLight(num, *i);
- mLights[num] = *i;
- }
- // Disable extra lights
- for (; num < mCurrentLights; ++num)
- {
- setGLLight(num, NULL);
- mLights[num] = NULL;
- }
- mCurrentLights = std::min(limit, static_cast(lights.size()));
-
- setLights();
-
- // restore previous
- glPopMatrix();
-
- }
-
- void GLRenderSystem::setGLLight(size_t index, Light* lt)
- {
- GLenum gl_index = GL_LIGHT0 + index;
-
- if (!lt)
- {
- // Disable in the scene
- glDisable(gl_index);
- }
- else
- {
- switch (lt->getType())
- {
- case Light::LT_SPOTLIGHT:
- glLightf( gl_index, GL_SPOT_CUTOFF, 0.5f * lt->getSpotlightOuterAngle().valueDegrees() );
- glLightf(gl_index, GL_SPOT_EXPONENT, lt->getSpotlightFalloff());
- break;
- default:
- glLightf( gl_index, GL_SPOT_CUTOFF, 180.0 );
- break;
- }
-
- // Color
- ColourValue col;
- col = lt->getDiffuseColour();
-
-
- GLfloat f4vals[4] = {col.r, col.g, col.b, col.a};
- glLightfv(gl_index, GL_DIFFUSE, f4vals);
-
- col = lt->getSpecularColour();
- f4vals[0] = col.r;
- f4vals[1] = col.g;
- f4vals[2] = col.b;
- f4vals[3] = col.a;
- glLightfv(gl_index, GL_SPECULAR, f4vals);
-
-
- // Disable ambient light for movables;
- f4vals[0] = 0;
- f4vals[1] = 0;
- f4vals[2] = 0;
- f4vals[3] = 1;
- glLightfv(gl_index, GL_AMBIENT, f4vals);
-
- setGLLightPositionDirection(lt, gl_index);
-
-
- // Attenuation
- glLightf(gl_index, GL_CONSTANT_ATTENUATION, lt->getAttenuationConstant());
- glLightf(gl_index, GL_LINEAR_ATTENUATION, lt->getAttenuationLinear());
- glLightf(gl_index, GL_QUADRATIC_ATTENUATION, lt->getAttenuationQuadric());
- // Enable in the scene
- glEnable(gl_index);
-
- }
-
- }
-
- void GLRenderSystem::setLights()
- {
- for (size_t i = 0; i < MAX_LIGHTS; ++i)
- {
- if (mLights[i] != NULL)
- {
- Light* lt = mLights[i];
- setGLLightPositionDirection(lt, GL_LIGHT0 + i);
- }
- }
- }
-
- void GLRenderSystem::setGLLightPositionDirection(Light* lt, GLenum lightindex)
- {
- // Set position / direction
- Vector4 vec;
- // Use general 4D vector which is the same as GL's approach
- vec = lt->getAs4DVector(true);
-
-#if OGRE_DOUBLE_PRECISION
- // Must convert to float*
- float tmp[4] = {vec.x, vec.y, vec.z, vec.w};
- glLightfv(lightindex, GL_POSITION, tmp);
-#else
- glLightfv(lightindex, GL_POSITION, vec.ptr());
-#endif
- // Set spotlight direction
- if (lt->getType() == Light::LT_SPOTLIGHT)
- {
- vec = lt->getDerivedDirection();
- vec.w = 0.0;
-#if OGRE_DOUBLE_PRECISION
- // Must convert to float*
- float tmp2[4] = {vec.x, vec.y, vec.z, vec.w};
- glLightfv(lightindex, GL_SPOT_DIRECTION, tmp2);
-#else
- glLightfv(lightindex, GL_SPOT_DIRECTION, vec.ptr());
-#endif
- }
- }
--}
-
-glSetTextureAddressingMode texTarget (UVWAddressingMode u v w) = do
- let target = getGLTextureTarget texTarget
- GL.textureWrapMode target GL.S $= getTextureAddressingMode u
- GL.textureWrapMode target GL.T $= getTextureAddressingMode v
- GL.textureWrapMode target GL.R $= getTextureAddressingMode w
-
-glSetTextureBorderColour texTarget (r,g,b,a) = do
- let target = getGLTextureTarget texTarget
- f = realToFrac
- GL.textureBorderColor target $= GL.Color4 (f r) (f g) (f b) (f a)
-
-glSetTextureUnitFiltering texTarget minFilter magFilter mipFilter = do
- let target = getGLTextureTarget texTarget
- mag = case magFilter of
- { FO_ANISOTROPIC -> GL.Linear'
- ; FO_LINEAR -> GL.Linear'
- ; FO_POINT -> GL.Nearest
- ; FO_NONE -> GL.Nearest
- }
- min = case minFilter of
- { FO_ANISOTROPIC -> GL.Linear'
- ; FO_LINEAR -> GL.Linear'
- ; FO_POINT -> GL.Nearest
- ; FO_NONE -> GL.Nearest
- }
- mip = case mipFilter of
- { FO_ANISOTROPIC -> Just GL.Linear'
- ; FO_LINEAR -> Just GL.Linear'
- ; FO_POINT -> Just GL.Nearest
- ; FO_NONE -> Nothing
- }
- GL.textureFilter target $= ((min,mip),mag)
-
-glSetTextureLayerAnisotropy texTarget maxAnisotropy = do
- let target = getGLTextureTarget texTarget
- maxSupportedAnisotropy <- GL.get GL.maxTextureMaxAnisotropy
- GL.textureMaxAnisotropy target $= (min (realToFrac maxAnisotropy) (realToFrac maxSupportedAnisotropy))
-
-glSetTextureMipmapBias bias = do
- GL.textureUnitLODBias $= realToFrac bias
-
-{-
- = LayerBlendModeEx
- { lbBlendType :: LayerBlendType -- ^ The type of blending (colour or alpha)
- , lbOperation :: LayerBlendOperationEx -- ^ The operation to be applied
- , lbSource1 :: LayerBlendSource -- ^ The first source of colour/alpha
- , lbSource2 :: LayerBlendSource -- ^ The second source of colour/alpha
- , lbColourArg1 :: ColourValue -- ^ Manual colour value for manual source1
- , lbColourArg2 :: ColourValue -- ^ Manual colour value for manual source2
- , lbAlphaArg1 :: FloatType -- ^ Manual alpha value for manual source1
- , lbAlphaArg2 :: FloatType -- ^ Manual alpha value for manual source2
- , lbFactor :: FloatType -- ^ Manual blending factor
- }
-
-doc: http://www.informit.com/articles/article.aspx?p=770639&seqNum=6
-FIXME: Test this code
--}
-glSetTextureBlendMode rsc colorbm alphabm = do
- let caps = rscCapabilities rsc
- hasDot3 = Set.member RSC_DOT3 caps
- csrc1op = getLayerBlendSource $ lbSource1 colorbm
- csrc2op = getLayerBlendSource $ lbSource2 colorbm
- ccmd = getTextureCombineFunction hasDot3 $ lbOperation colorbm
- asrc1op = getLayerBlendSource $ lbSource1 alphabm
- asrc2op = getLayerBlendSource $ lbSource2 alphabm
- acmd = getTextureCombineFunction hasDot3 $ lbOperation alphabm
- f = realToFrac
-
- GL.textureFunction $= GL.Combine
- GL.combineRGB $= ccmd
- GL.argRGB GL.Arg0 $= GL.Arg GL.SrcColor csrc1op
- GL.argRGB GL.Arg1 $= GL.Arg GL.SrcColor csrc2op
- GL.argRGB GL.Arg2 $= GL.Arg GL.SrcColor GL.Constant
- GL.combineAlpha $= acmd
- GL.argAlpha GL.Arg0 $= GL.Arg GL.SrcAlpha asrc1op
- GL.argAlpha GL.Arg1 $= GL.Arg GL.SrcAlpha asrc2op
- GL.argAlpha GL.Arg2 $= GL.Arg GL.SrcAlpha GL.Constant
-
- let argf bm cv1 cv2 = do
- case lbOperation bm of
- { LBX_BLEND_DIFFUSE_COLOUR -> do
- GL.argRGB GL.Arg2 $= GL.Arg GL.SrcColor GL.PrimaryColor
- GL.argAlpha GL.Arg2 $= GL.Arg GL.SrcAlpha GL.PrimaryColor
- ; LBX_BLEND_DIFFUSE_ALPHA -> do
- GL.argRGB GL.Arg2 $= GL.Arg GL.SrcAlpha GL.PrimaryColor
- GL.argAlpha GL.Arg2 $= GL.Arg GL.SrcAlpha GL.PrimaryColor
- ; LBX_BLEND_TEXTURE_ALPHA -> do
- GL.argRGB GL.Arg2 $= GL.Arg GL.SrcAlpha GL.CurrentUnit
- GL.argAlpha GL.Arg2 $= GL.Arg GL.SrcAlpha GL.CurrentUnit
- ; LBX_BLEND_CURRENT_ALPHA -> do
- GL.argRGB GL.Arg2 $= GL.Arg GL.SrcAlpha GL.Previous
- GL.argAlpha GL.Arg2 $= GL.Arg GL.SrcAlpha GL.Previous
- ; LBX_BLEND_MANUAL -> do
- GL.constantColor $= GL.Color4 0 0 0 (f $ lbFactor bm)
- ; _ -> return ()
- }
-
- when (LBS_MANUAL == lbSource1 bm) $
- GL.constantColor $= cv1
-
- when (LBS_MANUAL == lbSource2 bm) $
- GL.constantColor $= cv2
-
- (cr1,cg1,cb1,ca1) = lbColourArg1 colorbm
- (cr2,cg2,cb2,ca2) = lbColourArg2 colorbm
- cf r g b a = GL.Color4 (f r) (f g) (f b) (f a)
- aa1 = lbAlphaArg1 alphabm
- aa2 = lbAlphaArg2 alphabm
- argf colorbm (cf cr1 cg1 cb1 ca1) (cf cr2 cg2 cb2 ca2)
- argf alphabm (cf cr1 cg1 cb1 aa1) (cf cr2 cg2 cb2 aa2)
-
- case lbOperation colorbm of
- { LBX_MODULATE_X2 -> GL.rgbScale $= 2
- ; LBX_MODULATE_X4 -> GL.rgbScale $= 4
- ; _ -> GL.rgbScale $= 1
- }
-
- case lbOperation alphabm of
- { LBX_MODULATE_X2 -> GL.alphaScale $= 2
- ; LBX_MODULATE_X4 -> GL.alphaScale $= 4
- ; _ -> GL.alphaScale $= 1
- }
-
-glSetCullingMode mode = case mode of
- { CULL_NONE -> GL.cullFace $= Nothing
- ; CULL_CLOCKWISE -> GL.cullFace $= (Just GL.Back)
- ; CULL_ANTICLOCKWISE -> GL.cullFace $= (Just GL.Front)
- }
-
-glSetColourBufferWriteEnabled r g b a = do
- let f x = case x of
- { True -> GL.Enabled
- ; False -> GL.Disabled
- }
- GL.colorMask $= GL.Color4 (f r) (f g) (f b) (f a)
-
-glBindLinkedGpuProgram lp = do
- GL.currentProgram $= Just (gllgpProgramObject lp)
- --TEMP CODE
- let p = gllgpProgramObject lp
- loc_tex0 <- GL.get (GL.uniformLocation p "tex0")
- loc_tex1 <- GL.get (GL.uniformLocation p "tex1")
- (GL.uniform loc_tex0) GL.$=! (GL.Index1 (0::GL.GLint))
- (GL.uniform loc_tex1) GL.$=! (GL.Index1 (1::GL.GLint))
-
-glUnBindLinkedGpuProgram = do
- GL.currentProgram $= Nothing
-
-{-
- void GLRenderSystem::unbindGpuProgram(GpuProgramType gptype)
- {
-
- if (gptype == GPT_VERTEX_PROGRAM && mCurrentVertexProgram)
- {
- mActiveVertexGpuProgramParameters.setNull();
- mCurrentVertexProgram->unbindProgram();
- mCurrentVertexProgram = 0;
- }
- else if (gptype == GPT_GEOMETRY_PROGRAM && mCurrentGeometryProgram)
- {
- mActiveGeometryGpuProgramParameters.setNull();
- mCurrentGeometryProgram->unbindProgram();
- mCurrentGeometryProgram = 0;
- }
- else if (gptype == GPT_FRAGMENT_PROGRAM && mCurrentFragmentProgram)
- {
- mActiveFragmentGpuProgramParameters.setNull();
- mCurrentFragmentProgram->unbindProgram();
- mCurrentFragmentProgram = 0;
- }
- RenderSystem::unbindGpuProgram(gptype);
-
- }
-
- void RenderSystem::unbindGpuProgram(GpuProgramType gptype)
- {
- switch(gptype)
- {
- case GPT_VERTEX_PROGRAM:
- // mark clip planes dirty if changed (programmable can change space)
- if (mVertexProgramBound && !mClipPlanes.empty())
- mClipPlanesDirty = true;
- mVertexProgramBound = false;
- break;
- case GPT_GEOMETRY_PROGRAM:
- mGeometryProgramBound = false;
- break;
- case GPT_FRAGMENT_PROGRAM:
- mFragmentProgramBound = false;
- break;
- }
- }
--}
-
---glSetTextureMatrix :: Matrix4 -> IO ()
-glSetTextureMatrix xform = do
- mat <- toGLMatrix xform
- GL.matrix (Just GL.Texture) $= mat
-
-{-
- void GLRenderSystem::_setTextureMatrix(size_t stage, const Matrix4& xform)
- {
- if (stage >= mFixedFunctionTextureUnits)
- {
- // Can't do this
- return;
- }
-
- GLfloat mat[16];
- makeGLMatrix(mat, xform);
-
- if (!activateGLTextureUnit(stage))
- return;
- glMatrixMode(GL_TEXTURE);
-
- // Load this matrix in
- glLoadMatrixf(mat);
-
- if (mUseAutoTextureMatrix)
- {
- // Concat auto matrix
- glMultMatrixf(mAutoTextureMatrix);
- }
-
- glMatrixMode(GL_MODELVIEW);
- activateGLTextureUnit(0);
- }
--}
-
--- glSetTextureCoordCalculation :: TexCoordCalcMethod -> IO ()
-glSetTextureCoordCalculation m = case m of
- { TEXCALC_NONE -> do
- GL.textureGenMode GL.S $= Nothing
- GL.textureGenMode GL.T $= Nothing
- GL.textureGenMode GL.R $= Nothing
- GL.textureGenMode GL.Q $= Nothing
-
- ; TEXCALC_ENVIRONMENT_MAP -> do
- GL.textureGenMode GL.S $= Just GL.SphereMap
- GL.textureGenMode GL.T $= Just GL.SphereMap
- GL.textureGenMode GL.R $= Nothing
- GL.textureGenMode GL.Q $= Nothing
- -- TODO
- {-
- // Need to use a texture matrix to flip the spheremap
- mUseAutoTextureMatrix = true;
- memset(mAutoTextureMatrix, 0, sizeof(GLfloat)*16);
- mAutoTextureMatrix[0] = mAutoTextureMatrix[10] = mAutoTextureMatrix[15] = 1.0f;
- mAutoTextureMatrix[5] = -1.0f;
- -}
-
- ; TEXCALC_ENVIRONMENT_MAP_PLANAR -> do
- GL.textureGenMode GL.S $= Just GL.SphereMap
- GL.textureGenMode GL.T $= Just GL.SphereMap
- GL.textureGenMode GL.R $= Nothing
- GL.textureGenMode GL.Q $= Nothing
-
- ; TEXCALC_ENVIRONMENT_MAP_REFLECTION -> do
- GL.textureGenMode GL.S $= Just GL.ReflectionMap
- GL.textureGenMode GL.T $= Just GL.ReflectionMap
- GL.textureGenMode GL.R $= Just GL.ReflectionMap
- GL.textureGenMode GL.Q $= Nothing
- {-
- // We need an extra texture matrix here
- // This sets the texture matrix to be the inverse of the view matrix
- mUseAutoTextureMatrix = true;
- makeGLMatrix( M, mViewMatrix);
-
- // Transpose 3x3 in order to invert matrix (rotation)
- // Note that we need to invert the Z _before_ the rotation
- // No idea why we have to invert the Z at all, but reflection is wrong without it
- mAutoTextureMatrix[0] = M[0]; mAutoTextureMatrix[1] = M[4]; mAutoTextureMatrix[2] = -M[8];
- mAutoTextureMatrix[4] = M[1]; mAutoTextureMatrix[5] = M[5]; mAutoTextureMatrix[6] = -M[9];
- mAutoTextureMatrix[8] = M[2]; mAutoTextureMatrix[9] = M[6]; mAutoTextureMatrix[10] = -M[10];
- mAutoTextureMatrix[3] = mAutoTextureMatrix[7] = mAutoTextureMatrix[11] = 0.0f;
- mAutoTextureMatrix[12] = mAutoTextureMatrix[13] = mAutoTextureMatrix[14] = 0.0f;
- mAutoTextureMatrix[15] = 1.0f;
- -}
-
- ; TEXCALC_ENVIRONMENT_MAP_NORMAL -> do
- GL.textureGenMode GL.S $= Just GL.NormalMap
- GL.textureGenMode GL.T $= Just GL.NormalMap
- GL.textureGenMode GL.R $= Just GL.NormalMap
- GL.textureGenMode GL.Q $= Nothing
-
- ; TEXCALC_PROJECTIVE_TEXTURE -> do
- GL.textureGenMode GL.S $= Just (GL.EyeLinear $ GL.Plane 1 0 0 0)
- GL.textureGenMode GL.T $= Just (GL.EyeLinear $ GL.Plane 0 1 0 0)
- GL.textureGenMode GL.R $= Just (GL.EyeLinear $ GL.Plane 0 0 1 0)
- GL.textureGenMode GL.Q $= Just (GL.EyeLinear $ GL.Plane 0 0 0 1)
- {-
- mUseAutoTextureMatrix = true;
-
- // Set scale and translation matrix for projective textures
- projectionBias = Matrix4::CLIPSPACE2DTOIMAGESPACE;
-
- projectionBias = projectionBias * frustum->getProjectionMatrix();
- if(mTexProjRelative)
- {
- Matrix4 viewMatrix;
- frustum->calcViewMatrixRelative(mTexProjRelativeOrigin, viewMatrix);
- projectionBias = projectionBias * viewMatrix;
- }
- else
- {
- projectionBias = projectionBias * frustum->getViewMatrix();
- }
- projectionBias = projectionBias * mWorldMatrix;
-
- makeGLMatrix(mAutoTextureMatrix, projectionBias);
- -}
- }
-
-{-
- void GLRenderSystem::_setTextureCoordCalculation(size_t stage, TexCoordCalcMethod m,
- const Frustum* frustum)
- {
- if (stage >= mFixedFunctionTextureUnits)
- {
- // Can't do this
- return;
- }
-
-
- GLfloat M[16];
- Matrix4 projectionBias;
-
- // Default to no extra auto texture matrix
- mUseAutoTextureMatrix = false;
-
- GLfloat eyePlaneS[] = {1.0, 0.0, 0.0, 0.0};
- GLfloat eyePlaneT[] = {0.0, 1.0, 0.0, 0.0};
- GLfloat eyePlaneR[] = {0.0, 0.0, 1.0, 0.0};
- GLfloat eyePlaneQ[] = {0.0, 0.0, 0.0, 1.0};
-
- if (!activateGLTextureUnit(stage))
- return;
-
- switch( m )
- {
- case TEXCALC_NONE:
- glDisable( GL_TEXTURE_GEN_S );
- glDisable( GL_TEXTURE_GEN_T );
- glDisable( GL_TEXTURE_GEN_R );
- glDisable( GL_TEXTURE_GEN_Q );
- break;
-
- case TEXCALC_ENVIRONMENT_MAP:
- glTexGeni( GL_S, GL_TEXTURE_GEN_MODE, GL_SPHERE_MAP );
- glTexGeni( GL_T, GL_TEXTURE_GEN_MODE, GL_SPHERE_MAP );
-
- glEnable( GL_TEXTURE_GEN_S );
- glEnable( GL_TEXTURE_GEN_T );
- glDisable( GL_TEXTURE_GEN_R );
- glDisable( GL_TEXTURE_GEN_Q );
-
- // Need to use a texture matrix to flip the spheremap
- mUseAutoTextureMatrix = true;
- memset(mAutoTextureMatrix, 0, sizeof(GLfloat)*16);
- mAutoTextureMatrix[0] = mAutoTextureMatrix[10] = mAutoTextureMatrix[15] = 1.0f;
- mAutoTextureMatrix[5] = -1.0f;
-
- break;
-
- case TEXCALC_ENVIRONMENT_MAP_PLANAR:
- // XXX This doesn't seem right?!
-#ifdef GL_VERSION_1_3
- glTexGeni( GL_S, GL_TEXTURE_GEN_MODE, GL_REFLECTION_MAP );
- glTexGeni( GL_T, GL_TEXTURE_GEN_MODE, GL_REFLECTION_MAP );
- glTexGeni( GL_R, GL_TEXTURE_GEN_MODE, GL_REFLECTION_MAP );
-
- glEnable( GL_TEXTURE_GEN_S );
- glEnable( GL_TEXTURE_GEN_T );
- glEnable( GL_TEXTURE_GEN_R );
- glDisable( GL_TEXTURE_GEN_Q );
-#else
- glTexGeni( GL_S, GL_TEXTURE_GEN_MODE, GL_SPHERE_MAP );
- glTexGeni( GL_T, GL_TEXTURE_GEN_MODE, GL_SPHERE_MAP );
-
- glEnable( GL_TEXTURE_GEN_S );
- glEnable( GL_TEXTURE_GEN_T );
- glDisable( GL_TEXTURE_GEN_R );
- glDisable( GL_TEXTURE_GEN_Q );
-#endif
- break;
- case TEXCALC_ENVIRONMENT_MAP_REFLECTION:
-
- glTexGeni( GL_S, GL_TEXTURE_GEN_MODE, GL_REFLECTION_MAP );
- glTexGeni( GL_T, GL_TEXTURE_GEN_MODE, GL_REFLECTION_MAP );
- glTexGeni( GL_R, GL_TEXTURE_GEN_MODE, GL_REFLECTION_MAP );
-
- glEnable( GL_TEXTURE_GEN_S );
- glEnable( GL_TEXTURE_GEN_T );
- glEnable( GL_TEXTURE_GEN_R );
- glDisable( GL_TEXTURE_GEN_Q );
-
- // We need an extra texture matrix here
- // This sets the texture matrix to be the inverse of the view matrix
- mUseAutoTextureMatrix = true;
- makeGLMatrix( M, mViewMatrix);
-
- // Transpose 3x3 in order to invert matrix (rotation)
- // Note that we need to invert the Z _before_ the rotation
- // No idea why we have to invert the Z at all, but reflection is wrong without it
- mAutoTextureMatrix[0] = M[0]; mAutoTextureMatrix[1] = M[4]; mAutoTextureMatrix[2] = -M[8];
- mAutoTextureMatrix[4] = M[1]; mAutoTextureMatrix[5] = M[5]; mAutoTextureMatrix[6] = -M[9];
- mAutoTextureMatrix[8] = M[2]; mAutoTextureMatrix[9] = M[6]; mAutoTextureMatrix[10] = -M[10];
- mAutoTextureMatrix[3] = mAutoTextureMatrix[7] = mAutoTextureMatrix[11] = 0.0f;
- mAutoTextureMatrix[12] = mAutoTextureMatrix[13] = mAutoTextureMatrix[14] = 0.0f;
- mAutoTextureMatrix[15] = 1.0f;
-
- break;
- case TEXCALC_ENVIRONMENT_MAP_NORMAL:
- glTexGeni( GL_S, GL_TEXTURE_GEN_MODE, GL_NORMAL_MAP );
- glTexGeni( GL_T, GL_TEXTURE_GEN_MODE, GL_NORMAL_MAP );
- glTexGeni( GL_R, GL_TEXTURE_GEN_MODE, GL_NORMAL_MAP );
-
- glEnable( GL_TEXTURE_GEN_S );
- glEnable( GL_TEXTURE_GEN_T );
- glEnable( GL_TEXTURE_GEN_R );
- glDisable( GL_TEXTURE_GEN_Q );
- break;
- case TEXCALC_PROJECTIVE_TEXTURE:
- glTexGeni(GL_S, GL_TEXTURE_GEN_MODE, GL_EYE_LINEAR);
- glTexGeni(GL_T, GL_TEXTURE_GEN_MODE, GL_EYE_LINEAR);
- glTexGeni(GL_R, GL_TEXTURE_GEN_MODE, GL_EYE_LINEAR);
- glTexGeni(GL_Q, GL_TEXTURE_GEN_MODE, GL_EYE_LINEAR);
- glTexGenfv(GL_S, GL_EYE_PLANE, eyePlaneS);
- glTexGenfv(GL_T, GL_EYE_PLANE, eyePlaneT);
- glTexGenfv(GL_R, GL_EYE_PLANE, eyePlaneR);
- glTexGenfv(GL_Q, GL_EYE_PLANE, eyePlaneQ);
- glEnable(GL_TEXTURE_GEN_S);
- glEnable(GL_TEXTURE_GEN_T);
- glEnable(GL_TEXTURE_GEN_R);
- glEnable(GL_TEXTURE_GEN_Q);
-
- mUseAutoTextureMatrix = true;
-
- // Set scale and translation matrix for projective textures
- projectionBias = Matrix4::CLIPSPACE2DTOIMAGESPACE;
-
- projectionBias = projectionBias * frustum->getProjectionMatrix();
- if(mTexProjRelative)
- {
- Matrix4 viewMatrix;
- frustum->calcViewMatrixRelative(mTexProjRelativeOrigin, viewMatrix);
- projectionBias = projectionBias * viewMatrix;
- }
- else
- {
- projectionBias = projectionBias * frustum->getViewMatrix();
- }
- projectionBias = projectionBias * mWorldMatrix;
-
- makeGLMatrix(mAutoTextureMatrix, projectionBias);
- break;
- default:
- break;
- }
- activateGLTextureUnit(0);
- }
--}
diff --git a/Graphics/LambdaCube/RenderSystem/GL/GLTexture.hs b/Graphics/LambdaCube/RenderSystem/GL/GLTexture.hs
deleted file mode 100644
--- a/Graphics/LambdaCube/RenderSystem/GL/GLTexture.hs
+++ /dev/null
@@ -1,361 +0,0 @@
-module Graphics.LambdaCube.RenderSystem.GL.GLTexture where
-
-import qualified Data.Set as Set
-import Data.Maybe
-import Control.Monad
-import Foreign.Ptr
-
-import Graphics.Rendering.OpenGL (($=))
-import qualified Graphics.Rendering.OpenGL as GL
-import System.Log.Logger
-
-import Graphics.LambdaCube.Types
-import Graphics.LambdaCube.PixelFormat
-import Graphics.LambdaCube.Texture
-import Graphics.LambdaCube.Image
-import Graphics.LambdaCube.HardwareBuffer
-import Graphics.LambdaCube.RenderSystemCapabilities
-import Graphics.LambdaCube.RenderSystem.GL.GLUtils
-
-data GLTexture
- = GLTexture
- { gltxName :: String
- , gltxWidth :: Int
- , gltxHeight :: Int
- , gltxDepth :: Int
- , gltxNumRequestedMipmaps :: TextureMipmap
- , gltxNumMipmaps :: Int
- , gltxMipmapsHardwareGenerated :: Bool
- , gltxGamma :: FloatType
- , gltxHwGamma :: Bool
- , gltxFSAA :: Int
- , gltxFSAAHint :: String
- , gltxTextureType :: TextureType
- , gltxFormat :: PixelFormat
- , gltxUsage :: TextureUsage
- , gltxSrcFormat :: PixelFormat
- , gltxSrcWidth :: Int
- , gltxSrcHeight :: Int
- , gltxSrcDepth :: Int
-
- , gltxDesiredFormat :: PixelFormat
- , gltxDesiredIntegerBitDepth :: Int
- , gltxDesiredFloatBitDepth :: Int
- , gltxTreatLuminanceAsAlpha :: Bool
-
- , gltxTextureObject :: GL.TextureObject
- }
-
-instance Eq GLTexture where
- (==) a b = gltxTextureObject a == gltxTextureObject b
-
-instance HardwareBuffer GLTexture
-
-instance Texture GLTexture where
- txName = gltxName
- txWidth = gltxWidth
- txHeight = gltxHeight
- txDepth = gltxDepth
- txNumRequestedMipmaps = gltxNumRequestedMipmaps
- txNumMipmaps = gltxNumMipmaps
- txMipmapsHardwareGenerated = gltxMipmapsHardwareGenerated
- txGamma = gltxGamma
- txHwGamma = gltxHwGamma
- txFSAA = gltxFSAA
- txFSAAHint = gltxFSAAHint
- txTextureType = gltxTextureType
- txFormat = gltxFormat
--- txUsage = gltxUsage
- txSrcFormat = gltxSrcFormat
- txSrcWidth = gltxSrcWidth
- txSrcHeight = gltxSrcHeight
- txSrcDepth = gltxSrcDepth
-
- txDesiredFormat = gltxDesiredFormat
- txDesiredIntegerBitDepth = gltxDesiredIntegerBitDepth
- txDesiredFloatBitDepth = gltxDesiredFloatBitDepth
- txTreatLuminanceAsAlpha = gltxTreatLuminanceAsAlpha
-
-{-
- virtual TexturePtr createManual(const String & name, const String& group,
- TextureType texType, uint width, uint height, uint depth,
- int num_mips, PixelFormat format, int usage = TU_DEFAULT, ManualResourceLoader* loader = 0,
- bool hwGammaCorrection = false, uint fsaa = 0, const String& fsaaHint = StringUtil::BLANK);
--}
---createTexture :: a -> String -> TextureType -> Int -> Int -> Int -> Int -> PixelFormat -> TextueUsage -> Bool -> Int -> String -> IO t
-{-
- virtual TexturePtr createManual(const String & name, const String& group,
- TextureType texType, uint width, uint height, uint depth,
- int num_mips, PixelFormat format, int usage = TU_DEFAULT, ManualResourceLoader* loader = 0,
- bool hwGammaCorrection = false, uint fsaa = 0, const String& fsaaHint = StringUtil::BLANK);
- TextureUsage = bufferUsage::Usage, autoMipmap::Bool, isTarget::Bool
- createTexture :: a -> String -> TextureType -> Int -> Int -> Int -> Int -> PixelFormat -> Usage -> Bool -> Bool -> Bool -> Int -> String -> IO t
--}
-mkGLTexture :: RenderSystemCapabilities -> String -> TextureType -> Int -> Int -> Int -> TextureMipmap -> PixelFormat -> TextureUsage -> Bool -> Int -> String -> Maybe [Image] -> IO GLTexture
---FIXME: image parameter is temporary!!!!
-mkGLTexture rcaps name texType width height depth numMips format usage hwGammaCorrection fsaa fsaaHint mimage = do
- let caps = rscCapabilities rcaps
- debugM "createTexture" $ "create " ++ show texType ++ " texture: " ++ name
-
- when (texType == TEX_TYPE_3D && Set.notMember RSC_TEXTURE_3D caps) $ error "3D Textures not supported before OpenGL 1.2"
-
- (major,minor) <- GL.get $ GL.majorMinor GL.glVersion
-
- let glVer a b = major > a || (major >= a && minor >= b)
- texTarget = (getGLTextureTarget texType)
- -- Convert to nearest power-of-two size if required
- mWidth = optionalPO2 rcaps width
- mHeight = optionalPO2 rcaps height
- mDepth = optionalPO2 rcaps depth
-
- -- Adjust format if required
- mFormat = getNativeFormat texType format False -- TODO
-
- -- Check requested number of mipmaps
- maxMips = getMaxMipmaps mWidth mHeight mDepth mFormat
- mNumMipmaps = maxMips -- TODO min maxMips numMips
-
- -- Generate texture name
- [mTextureID] <- GL.genObjectNames 1
-
- -- Set texture type
- GL.textureBinding texTarget $= Just mTextureID
-
- -- This needs to be set otherwise the texture doesn't get rendered
- when (glVer 1 2) $ GL.textureLevelRange texTarget $= (0,fromIntegral mNumMipmaps)
-
- -- Set some misc default parameters so NVidia won't complain, these can of course be changed later
- GL.textureFilter texTarget $= ((GL.Nearest,Nothing),GL.Nearest)
-
- when (glVer 1 2) $ do
- GL.textureWrapMode texTarget GL.S $= (GL.Repeated, GL.ClampToEdge)
- GL.textureWrapMode texTarget GL.T $= (GL.Repeated, GL.ClampToEdge)
-
- -- If we can do automip generation and the user desires this, do so
- let mMipmapsHardwareGenerated = Set.member RSC_AUTOMIPMAP caps
- -- FIXME
- {-
- // NVIDIA 175.16 drivers break hardware mip generation for non-compressed
- // textures - disable until fixed
- // Leave hardware gen on compressed textures since that's the only way we
- // can realistically do it since GLU doesn't support DXT
- // However DON'T do this on Apple, their drivers aren't subject to this
- // problem yet and in fact software generation appears to cause a crash
- // in some cases which I've yet to track down
-if OGRE_PLATFORM != OGRE_PLATFORM_APPLE
- if (Root::getSingleton().getRenderSystem()->getCapabilities()->getVendor() == GPU_NVIDIA
- && !PixelUtil::isCompressed(mFormat))
- {
- mMipmapsHardwareGenerated = false;
- }
-endif
- -}
---TODO
- let moreMips = case numMips of
- { MIP_UNLIMITED -> True
- ; MIP_DEFAULT -> True -- TODO
- ; MIP_NUMBER n -> n > 0
- }
-
- when (tuAutoMipmap usage && moreMips && mMipmapsHardwareGenerated) $ GL.generateMipmap texTarget $= GL.Enabled
-
- -- Allocate internal buffer so that glTexSubImageXD can be used
- -- Internal format
- let format' = getClosestGLInternalFormat mFormat hwGammaCorrection
- isCompressed _ = False -- TODO
- case isCompressed mFormat of
- { True -> do
- {-
- // Compressed formats
- size_t size = PixelUtil::getMemorySize(mWidth, mHeight, mDepth, mFormat);
- // Provide temporary buffer filled with zeroes as glCompressedTexImageXD does not
- // accept a 0 pointer like normal glTexImageXD
- // Run through this process for every mipmap to pregenerate mipmap piramid
- uint8 *tmpdata = new uint8[size];
- memset(tmpdata, 0, size);
-
- for(size_t mip=0; mip<=mNumMipmaps; mip++)
- {
- size = PixelUtil::getMemorySize(width, height, depth, mFormat);
- switch(mTextureType)
- {
- case TEX_TYPE_1D:
- glCompressedTexImage1DARB(GL_TEXTURE_1D, mip, format',
- width, 0,
- size, tmpdata);
- break;
- case TEX_TYPE_2D:
- glCompressedTexImage2DARB(GL_TEXTURE_2D, mip, format',
- width, height, 0,
- size, tmpdata);
- break;
- case TEX_TYPE_3D:
- glCompressedTexImage3DARB(GL_TEXTURE_3D, mip, format',
- width, height, depth, 0,
- size, tmpdata);
- break;
- case TEX_TYPE_CUBE_MAP:
- for(int face=0; face<6; face++) {
- glCompressedTexImage2DARB(GL_TEXTURE_CUBE_MAP_POSITIVE_X + face, mip, format',
- width, height, 0,
- size, tmpdata);
- }
- break;
- };
- if(width>1) width = width/2;
- if(height>1) height = height/2;
- if(depth>1) depth = depth/2;
- }
- delete [] tmpdata;
- -}
-
- -- Compressed formats
- -- Provide temporary buffer filled with zeroes as glCompressedTexImageXD does not
- -- accept a 0 pointer like normal glTexImageXD
- -- TODO: support compressed textures
- {-
- let setMip tmpdata (w,h,d) mip = do
- -- compressedTexImage1D :: Proxy -> Level -> TextureSize1D -> Border -> CompressedPixelData a -> IO ()
- -- CompressedPixelData !CompressedTextureFormat GLsizei (Ptr a)
- let size = getMemorySize w h d mFormat
- case texType of
- { TEX_TYPE_1D -> GL.compressedTexImage1D GL.NoProxy mip (GL.TextureSize1D w) 0 (GL.CompressedPixelData (CompressedTextureFormat ) size tmpdata)
- ; TEX_TYPE_2D ->
- ; TEX_TYPE_3D ->
- ; TEX_TYPE_CUBE_MAP -> do
- }
- return (max 1 (w `div` 2), max 1 (h `div` 2), max 1 (d `div` 2))
- setMips :: Ptr Word8 -> IO ()
- setMips tmpdata = do
- pokeArray tmpdata $ replicate size 0
- -- Run through this process for every mipmap to pregenerate mipmap piramid
- foldM_ (setMip tmpdata) (mWidth,mHeight,mDepth) [0..mNumMipmaps]
- allocaArray (getMemorySize mWidth mHeight mDepth mFormat) setMips
- -}
- return ()
- ; False -> do
- let setMip (w,h,d) mip = do
- -- Normal formats
- case texType of
- { TEX_TYPE_1D -> GL.texImage1D GL.NoProxy mip format' (GL.TextureSize1D w) 0 (GL.PixelData GL.RGBA GL.UnsignedByte nullPtr)
- ; TEX_TYPE_2D -> GL.texImage2D Nothing GL.NoProxy mip format' (GL.TextureSize2D w h) 0 (GL.PixelData GL.RGBA GL.UnsignedByte nullPtr)
- ; TEX_TYPE_3D -> GL.texImage3D GL.NoProxy mip format' (GL.TextureSize3D w h d) 0 (GL.PixelData GL.RGBA GL.UnsignedByte nullPtr)
- ; TEX_TYPE_CUBE_MAP -> do
- GL.texImage2D (Just GL.TextureCubeMapPositiveX) GL.NoProxy mip format' (GL.TextureSize2D w h) 0 (GL.PixelData GL.RGBA GL.UnsignedByte nullPtr)
- GL.texImage2D (Just GL.TextureCubeMapNegativeX) GL.NoProxy mip format' (GL.TextureSize2D w h) 0 (GL.PixelData GL.RGBA GL.UnsignedByte nullPtr)
- GL.texImage2D (Just GL.TextureCubeMapPositiveY) GL.NoProxy mip format' (GL.TextureSize2D w h) 0 (GL.PixelData GL.RGBA GL.UnsignedByte nullPtr)
- GL.texImage2D (Just GL.TextureCubeMapNegativeY) GL.NoProxy mip format' (GL.TextureSize2D w h) 0 (GL.PixelData GL.RGBA GL.UnsignedByte nullPtr)
- GL.texImage2D (Just GL.TextureCubeMapPositiveZ) GL.NoProxy mip format' (GL.TextureSize2D w h) 0 (GL.PixelData GL.RGBA GL.UnsignedByte nullPtr)
- GL.texImage2D (Just GL.TextureCubeMapNegativeZ) GL.NoProxy mip format' (GL.TextureSize2D w h) 0 (GL.PixelData GL.RGBA GL.UnsignedByte nullPtr)
- }
- return (max 1 (w `div` 2), max 1 (h `div` 2), max 1 (d `div` 2))
- f = fromIntegral
- -- Run through this process to pregenerate mipmap piramid
- foldM_ setMip (f mWidth,f mHeight,f mDepth) [0..(fromIntegral mNumMipmaps)]
- }
-
- -- TODO
- -- TEMP CODE
- when (isJust mimage) $ do
- let images = fromJust mimage
- imInfo i = (fmt,f w,f h)
- where
- f = fromIntegral
- fmt = case imFormat i of
- { PF_L8 -> GL.Luminance
- ; PF_BYTE_LA -> GL.LuminanceAlpha
- ; PF_R8G8B8 -> GL.RGB
- ; PF_R8G8B8A8 -> GL.RGBA
- }
- w = imWidth i
- h = imHeight i
- upload2D target i = do
- let (fmt,w,h) = imInfo i
- debugM "createTexture" $ "upload2d: " ++ imName i
- GL.texImage2D target GL.NoProxy 0 format' (GL.TextureSize2D w h) 0 (GL.PixelData fmt GL.UnsignedByte $ imData i)
-
- errl <- GL.get GL.errors
- unless (null errl) $ debugM "createTexture" $ "glerrors: \"" ++ concat [show c ++ " - " ++ m ++ "\n" | GL.Error c m <- errl] ++ "\""
- case texType of
- { TEX_TYPE_1D -> do
- let (fmt,w,h) = imInfo image
- image = head images
- GL.texImage1D GL.NoProxy 0 format' (GL.TextureSize1D w) 0 (GL.PixelData fmt GL.UnsignedByte $ imData image)
- ; TEX_TYPE_2D -> upload2D Nothing $ head images
- ; TEX_TYPE_CUBE_MAP -> mapM_ (uncurry upload2D) $ zip [ Just GL.TextureCubeMapPositiveZ -- front
- , Just GL.TextureCubeMapNegativeZ -- back
- , Just GL.TextureCubeMapPositiveY -- up
- , Just GL.TextureCubeMapNegativeY -- down
- , Just GL.TextureCubeMapNegativeX -- left
- , Just GL.TextureCubeMapPositiveX -- right
- ] images
- ; _ -> return ()
- }
- --_createSurfaceList();
-
- -- Get final internal format
- -- TODO
- --mFormat = getBuffer(0,0)->getFormat();
- debugM "createTexture" $ "created texture: " ++ name
- return GLTexture
- { gltxName = name
- , gltxWidth = 0 --TODO
- , gltxHeight = 0 --TODO
- , gltxDepth = 0 --TODO
- , gltxNumRequestedMipmaps = MIP_DEFAULT --TODO
- , gltxNumMipmaps = 0 --TODO
- , gltxMipmapsHardwareGenerated = True --TODO
- , gltxGamma = 0 --TODO
- , gltxHwGamma = True --TODO
- , gltxFSAA = 0 --TODO
- , gltxFSAAHint = "" --TODO
- , gltxTextureType = texType
- , gltxFormat = PF_R8G8B8 -- TODO
- , gltxUsage = TextureUsage HBU_WRITE_ONLY False False-- TODO
- , gltxSrcFormat = PF_R8G8B8 -- TODO
- , gltxSrcWidth = 0 --TODO
- , gltxSrcHeight = 0 --TODO
- , gltxSrcDepth = 0 --TODO
-
- , gltxDesiredFormat = PF_R8G8B8 --TODO
- , gltxDesiredIntegerBitDepth = 0 --TODO
- , gltxDesiredFloatBitDepth = 0 --TODO
- , gltxTreatLuminanceAsAlpha = True --TODO
-
- , gltxTextureObject = mTextureID
- }
-{-
- void GLTexture::_createSurfaceList()
- {
- mSurfaceList.clear();
-
- // For all faces and mipmaps, store surfaces as HardwarePixelBufferSharedPtr
- bool wantGeneratedMips = (mUsage & TU_AUTOMIPMAP)!=0;
-
- // Do mipmapping in software? (uses GLU) For some cards, this is still needed. Of course,
- // only when mipmap generation is desired.
- bool doSoftware = wantGeneratedMips && !mMipmapsHardwareGenerated && getNumMipmaps();
-
- for(size_t face=0; face(mUsage), doSoftware && mip==0, mHwGamma, mFSAA);
- mSurfaceList.push_back(HardwarePixelBufferSharedPtr(buf));
-
- /// Check for error
- if(buf->getWidth()==0 || buf->getHeight()==0 || buf->getDepth()==0)
- {
- OGRE_EXCEPT(
- Exception::ERR_RENDERINGAPI_ERROR,
- "Zero sized texture surface on texture "+getName()+
- " face "+StringConverter::toString(face)+
- " mipmap "+StringConverter::toString(mip)+
- ". Probably, the GL driver refused to create the texture.",
- "GLTexture::_createSurfaceList");
- }
- }
- }
- }
--}
diff --git a/Graphics/LambdaCube/RenderSystem/GL/GLUtils.hs b/Graphics/LambdaCube/RenderSystem/GL/GLUtils.hs
deleted file mode 100644
--- a/Graphics/LambdaCube/RenderSystem/GL/GLUtils.hs
+++ /dev/null
@@ -1,326 +0,0 @@
-module Graphics.LambdaCube.RenderSystem.GL.GLUtils where
-
-import qualified Data.Set as Set
-import Data.Bits
-import Unsafe.Coerce
-
-import Graphics.Rendering.OpenGL (($=))
-import qualified Graphics.Rendering.OpenGL as GL
-
-import Graphics.LambdaCube.Types
-import Graphics.LambdaCube.Math
-import Graphics.LambdaCube.Common
-import Graphics.LambdaCube.PixelFormat
-import Graphics.LambdaCube.Texture
-import Graphics.LambdaCube.BlendMode
-import Graphics.LambdaCube.HardwareBuffer
-import Graphics.LambdaCube.HardwareVertexBuffer
-import Graphics.LambdaCube.RenderSystemCapabilities
-import Graphics.LambdaCube.TextureUnitState
-
-toGLMatrix :: Matrix4 -> IO (GL.GLmatrix GL.GLfloat)
-toGLMatrix m = GL.newMatrix GL.ColumnMajor $ unsafeCoerce $ toListsMatrix4 m
-
-getGLUsage :: Usage -> GL.BufferUsage
-getGLUsage usage = case usage of
- { HBU_STATIC -> GL.StaticDraw
- ; HBU_STATIC_WRITE_ONLY -> GL.StaticDraw
- ; HBU_DYNAMIC -> GL.DynamicDraw
- ; HBU_DYNAMIC_WRITE_ONLY -> GL.DynamicDraw
- ; HBU_DYNAMIC_WRITE_ONLY_DISCARDABLE -> GL.StreamDraw
- ; _ -> GL.DynamicDraw
- }
-
-getGLType :: VertexElementType -> GL.DataType
-getGLType t = case t of
- { VET_FLOAT1 -> GL.Float
- ; VET_FLOAT2 -> GL.Float
- ; VET_FLOAT3 -> GL.Float
- ; VET_FLOAT4 -> GL.Float
- ; VET_SHORT1 -> GL.Short
- ; VET_SHORT2 -> GL.Short
- ; VET_SHORT3 -> GL.Short
- ; VET_SHORT4 -> GL.Short
- ; VET_COLOUR_ABGR -> GL.UnsignedByte
- ; VET_COLOUR_ARGB -> GL.UnsignedByte
- ; VET_UBYTE4 -> GL.UnsignedByte
- }
-
-getGLTextureTarget :: TextureType -> GL.TextureTarget
-getGLTextureTarget textureType = case textureType of
- { TEX_TYPE_1D -> GL.Texture1D
- ; TEX_TYPE_2D -> GL.Texture2D
- ; TEX_TYPE_3D -> GL.Texture3D
- ; TEX_TYPE_CUBE_MAP -> GL.TextureCubeMap
- }
-
-
-optionalPO2 :: RenderSystemCapabilities -> Int -> Int
-optionalPO2 rcaps value = case Set.member RSC_NON_POWER_OF_2_TEXTURES (rscCapabilities rcaps) of
- { True -> value
- ; False -> 2 ^ ( 1 + log2 (value-1) )
- }
- where
- log2 n = case n of
- 0 -> -1
- _ -> 1 + log2 (shiftR n 1)
-
-getMaxMipmaps :: Int -> Int -> Int -> PixelFormat -> Int
-getMaxMipmaps width height depth format = maximum [f width, f height, f depth]
- where
- f x = floor $ logBase 2 $ fromIntegral x
-{-
- size_t GLPixelUtil::getMaxMipmaps(size_t width, size_t height, size_t depth, PixelFormat format)
- {
- size_t count = 0;
- do {
- if(width>1) width = width/2;
- if(height>1) height = height/2;
- if(depth>1) depth = depth/2;
-
- count ++;
- } while(!(width == 1 && height == 1 && depth == 1));
-
- return count;
- }
--}
--- TODO
-getNativeFormat :: TextureType -> PixelFormat -> Bool -> PixelFormat
-getNativeFormat ttype format isTarget = PF_R8G8B8
-{-
- PixelFormat GLTextureManager::getNativeFormat(TextureType ttype, PixelFormat format, int usage)
- {
- // Adjust requested parameters to capabilities
- const RenderSystemCapabilities *caps = Root::getSingleton().getRenderSystem()->getCapabilities();
-
- // Check compressed texture support
- // if a compressed format not supported, revert to PF_A8R8G8B8
- if(PixelUtil::isCompressed(format) &&
- !caps->hasCapability( RSC_TEXTURE_COMPRESSION_DXT ))
- {
- return PF_A8R8G8B8;
- }
- // if floating point textures not supported, revert to PF_A8R8G8B8
- if(PixelUtil::isFloatingPoint(format) &&
- !caps->hasCapability( RSC_TEXTURE_FLOAT ))
- {
- return PF_A8R8G8B8;
- }
-
- // Check if this is a valid rendertarget format
- if( usage & TU_RENDERTARGET )
- {
- /// Get closest supported alternative
- /// If mFormat is supported it's returned
- return GLRTTManager::getSingleton().getSupportedAlternative(format);
- }
-
- // Supported
- return format;
- }
-
- PixelFormat GLRTTManager::getSupportedAlternative(PixelFormat format)
- {
- if(checkFormat(format))
- return format;
- /// Find first alternative
- PixelComponentType pct = PixelUtil::getComponentType(format);
- switch(pct)
- {
- case PCT_BYTE: format = PF_A8R8G8B8; break;
- case PCT_SHORT: format = PF_SHORT_RGBA; break;
- case PCT_FLOAT16: format = PF_FLOAT16_RGBA; break;
- case PCT_FLOAT32: format = PF_FLOAT32_RGBA; break;
- case PCT_COUNT: break;
- }
- if(checkFormat(format))
- return format;
- /// If none at all, return to default
- return PF_A8R8G8B8;
- }
--}
-getGLInternalFormat :: PixelFormat -> Bool -> GL.PixelInternalFormat
-getGLInternalFormat mFormat hwGamma = case mFormat of
- { PF_L8 -> GL.Luminance8
- ; PF_L16 -> GL.Luminance16
- ; PF_A8 -> GL.Alpha8
- ; PF_A4L4 -> GL.Luminance4Alpha4
- ; PF_BYTE_LA -> GL.Luminance8Alpha8
- ; PF_R3G3B2 -> GL.R3G3B2
- ; PF_A1R5G5B5 -> GL.RGB5A1
- ; PF_R5G6B5 -> GL.RGB5
- ; PF_B5G6R5 -> GL.RGB5
- ; PF_A4R4G4B4 -> GL.RGBA4
- ; PF_R8G8B8 -> if hwGamma then GL.SRGB8 else GL.RGB8
- ; PF_B8G8R8 -> if hwGamma then GL.SRGB8 else GL.RGB8
- ; PF_X8B8G8R8 -> if hwGamma then GL.SRGB8 else GL.RGB8
- ; PF_X8R8G8B8 -> if hwGamma then GL.SRGB8 else GL.RGB8
- ; PF_A8R8G8B8 -> if hwGamma then GL.SRGB8Alpha8 else GL.RGBA8
- ; PF_B8G8R8A8 -> if hwGamma then GL.SRGB8Alpha8 else GL.RGBA8
- ; PF_A2R10G10B10 -> GL.RGB10A2
- ; PF_A2B10G10R10 -> GL.RGB10A2
---FIXME ; PF_FLOAT16_R -> GL_LUMINANCE16F_ARB
---FIXME ; PF_FLOAT16_RGB -> GL_RGB16F_ARB
---FIXME ; PF_FLOAT16_GR -> GL_LUMINANCE_ALPHA16F_ARB
---FIXME ; PF_FLOAT16_RGBA -> GL_RGBA16F_ARB
---FIXME ; PF_FLOAT32_R -> GL_LUMINANCE32F_ARB
---FIXME ; PF_FLOAT32_GR -> GL_LUMINANCE_ALPHA32F_ARB
---FIXME ; PF_FLOAT32_RGB -> GL_RGB32F_ARB
---FIXME ; PF_FLOAT32_RGBA -> GL_RGBA32F_ARB
- ; PF_SHORT_RGBA -> GL.RGBA16
- ; PF_SHORT_RGB -> GL.RGB16
- ; PF_SHORT_GR -> GL.Luminance16Alpha16
--- case PF_DXT1:
--- if (hwGamma)
--- return GL_COMPRESSED_SRGB_ALPHA_S3TC_DXT1_EXT;
--- else
--- return GL_COMPRESSED_RGBA_S3TC_DXT1_EXT;
--- case PF_DXT3:
--- if (hwGamma)
--- return GL_COMPRESSED_SRGB_ALPHA_S3TC_DXT3_EXT;
--- else
--- return GL_COMPRESSED_RGBA_S3TC_DXT3_EXT;
--- case PF_DXT5:
--- if (hwGamma)
--- return GL_COMPRESSED_SRGB_ALPHA_S3TC_DXT5_EXT;
--- else
--- return GL_COMPRESSED_RGBA_S3TC_DXT5_EXT;
- ; _ -> error "Unsupported pixel format"
- }
-{-
- GLenum GLPixelUtil::getGLInternalFormat(PixelFormat mFormat, bool hwGamma)
- {
- switch(mFormat) {
- default:
- return GL_NONE;
- }
- }
- GLenum GLPixelUtil::getClosestGLInternalFormat(PixelFormat mFormat, bool hwGamma)
- {
- GLenum format = getGLInternalFormat(mFormat, hwGamma);
- if(format==GL_NONE)
- {
- if (hwGamma)
- return GL_SRGB8;
- else
- return GL_RGBA8;
- }
- else
- return format;
- }
--}
-getClosestGLInternalFormat :: PixelFormat -> Bool -> GL.PixelInternalFormat
-getClosestGLInternalFormat mFormat hwGamma = case mFormat of
- { PF_L8 -> GL.Luminance8
- ; PF_L16 -> GL.Luminance16
- ; PF_A8 -> GL.Alpha8
- ; PF_A4L4 -> GL.Luminance4Alpha4
- ; PF_BYTE_LA -> GL.Luminance8Alpha8
- ; PF_R3G3B2 -> GL.R3G3B2
- ; PF_A1R5G5B5 -> GL.RGB5A1
- ; PF_R5G6B5 -> GL.RGB5
- ; PF_B5G6R5 -> GL.RGB5
- ; PF_A4R4G4B4 -> GL.RGBA4
- ; PF_R8G8B8 -> if hwGamma then GL.SRGB8 else GL.RGB8
- ; PF_B8G8R8 -> if hwGamma then GL.SRGB8 else GL.RGB8
- ; PF_X8B8G8R8 -> if hwGamma then GL.SRGB8 else GL.RGB8
- ; PF_X8R8G8B8 -> if hwGamma then GL.SRGB8 else GL.RGB8
- ; PF_A8R8G8B8 -> if hwGamma then GL.SRGB8Alpha8 else GL.RGBA8
- ; PF_B8G8R8A8 -> if hwGamma then GL.SRGB8Alpha8 else GL.RGBA8
- ; PF_A2R10G10B10 -> GL.RGB10A2
- ; PF_A2B10G10R10 -> GL.RGB10A2
---FIXME ; PF_FLOAT16_R -> GL_LUMINANCE16F_ARB
---FIXME ; PF_FLOAT16_RGB -> GL_RGB16F_ARB
---FIXME ; PF_FLOAT16_GR -> GL_LUMINANCE_ALPHA16F_ARB
---FIXME ; PF_FLOAT16_RGBA -> GL_RGBA16F_ARB
---FIXME ; PF_FLOAT32_R -> GL_LUMINANCE32F_ARB
---FIXME ; PF_FLOAT32_GR -> GL_LUMINANCE_ALPHA32F_ARB
---FIXME ; PF_FLOAT32_RGB -> GL_RGB32F_ARB
---FIXME ; PF_FLOAT32_RGBA -> GL_RGBA32F_ARB
- ; PF_SHORT_RGBA -> GL.RGBA16
- ; PF_SHORT_RGB -> GL.RGB16
- ; PF_SHORT_GR -> GL.Luminance16Alpha16
--- FIXME
--- case PF_DXT1:
--- if (hwGamma)
--- return GL_COMPRESSED_SRGB_ALPHA_S3TC_DXT1_EXT;
--- else
--- return GL_COMPRESSED_RGBA_S3TC_DXT1_EXT;
--- case PF_DXT3:
--- if (hwGamma)
--- return GL_COMPRESSED_SRGB_ALPHA_S3TC_DXT3_EXT;
--- else
--- return GL_COMPRESSED_RGBA_S3TC_DXT3_EXT;
--- case PF_DXT5:
--- if (hwGamma)
--- return GL_COMPRESSED_SRGB_ALPHA_S3TC_DXT5_EXT;
--- else
--- return GL_COMPRESSED_RGBA_S3TC_DXT5_EXT;
- ; _ -> if hwGamma then GL.SRGB8 else GL.RGBA8
- }
-
-getBlendMode :: SceneBlendFactor -> GL.BlendingFactor
-getBlendMode blend = case blend of
- { SBF_ONE -> GL.One
- ; SBF_ZERO -> GL.Zero
- ; SBF_DEST_COLOUR -> GL.DstColor
- ; SBF_SOURCE_COLOUR -> GL.SrcColor
- ; SBF_ONE_MINUS_DEST_COLOUR -> GL.OneMinusDstColor
- ; SBF_ONE_MINUS_SOURCE_COLOUR -> GL.OneMinusSrcColor
- ; SBF_DEST_ALPHA -> GL.DstAlpha
- ; SBF_SOURCE_ALPHA -> GL.SrcAlpha
- ; SBF_ONE_MINUS_DEST_ALPHA -> GL.OneMinusDstAlpha
- ; SBF_ONE_MINUS_SOURCE_ALPHA -> GL.OneMinusSrcAlpha
- }
-
-getBlendEquation op = case op of
- { SBO_ADD -> GL.FuncAdd
- ; SBO_SUBTRACT -> GL.FuncSubtract
- ; SBO_REVERSE_SUBTRACT -> GL.FuncReverseSubtract
- ; SBO_MIN -> GL.Min
- ; SBO_MAX -> GL.Max
- }
-
-getTextureAddressingMode tam = case tam of
- { TAM_WRAP -> (GL.Repeated, GL.Repeat)
- ; TAM_MIRROR -> (GL.Mirrored, GL.Repeat)
- ; TAM_CLAMP -> (GL.Repeated, GL.ClampToEdge)
- ; TAM_BORDER -> (GL.Repeated, GL.ClampToBorder)
- }
-
-getLayerBlendSource src = case src of
- { LBS_CURRENT -> GL.Previous
- ; LBS_TEXTURE -> GL.CurrentUnit
- ; LBS_MANUAL -> GL.Constant
- ; LBS_DIFFUSE -> GL.PrimaryColor
- ; LBS_SPECULAR -> GL.PrimaryColor
- }
-
-getTextureCombineFunction hasDot3 op = case op of
- { LBX_SOURCE1 -> GL.Replace'
- ; LBX_SOURCE2 -> GL.Replace'
- ; LBX_MODULATE -> GL.Modulate'
- ; LBX_MODULATE_X2 -> GL.Modulate'
- ; LBX_MODULATE_X4 -> GL.Modulate'
- ; LBX_ADD -> GL.AddUnsigned'
- ; LBX_ADD_SIGNED -> GL.AddSigned
- ; LBX_ADD_SMOOTH -> GL.Interpolate
- ; LBX_SUBTRACT -> GL.Subtract
- ; LBX_BLEND_DIFFUSE_COLOUR -> GL.Interpolate
- ; LBX_BLEND_DIFFUSE_ALPHA -> GL.Interpolate
- ; LBX_BLEND_TEXTURE_ALPHA -> GL.Interpolate
- ; LBX_BLEND_CURRENT_ALPHA -> GL.Interpolate
- ; LBX_BLEND_MANUAL -> GL.Interpolate
- ; LBX_DOTPRODUCT -> if hasDot3 then GL.Dot3RGB else GL.Modulate'
- }
-
-convertCompareFunction f = case f of
- { CMPF_ALWAYS_FAIL -> GL.Never
- ; CMPF_ALWAYS_PASS -> GL.Always
- ; CMPF_LESS -> GL.Less
- ; CMPF_LESS_EQUAL -> GL.Lequal
- ; CMPF_EQUAL -> GL.Equal
- ; CMPF_NOT_EQUAL -> GL.Notequal
- ; CMPF_GREATER_EQUAL -> GL.Gequal
- ; CMPF_GREATER -> GL.Greater
- }
diff --git a/Graphics/LambdaCube/RenderSystem/GL/GLVertexBuffer.hs b/Graphics/LambdaCube/RenderSystem/GL/GLVertexBuffer.hs
deleted file mode 100644
--- a/Graphics/LambdaCube/RenderSystem/GL/GLVertexBuffer.hs
+++ /dev/null
@@ -1,133 +0,0 @@
-module Graphics.LambdaCube.RenderSystem.GL.GLVertexBuffer where
-
-import Data.Word
-import Data.Maybe
-import Foreign.Marshal.Alloc
-import Foreign.Marshal.Utils
-import Foreign.Storable
-import Foreign.C.Types
-import Foreign.Ptr
-import Data.IORef
-import Control.Monad
-
-import Graphics.Rendering.OpenGL (($=))
-import qualified Graphics.Rendering.OpenGL as GL
-
-import Graphics.LambdaCube.RenderSystem
-import Graphics.LambdaCube.HardwareBuffer
-import Graphics.LambdaCube.HardwareVertexBuffer
-import Graphics.LambdaCube.RenderSystem.GL.GLUtils
-
--- | Specialisation of HardwareVertexBuffer for GL
-data GLVertexBuffer
- = GLVertexBuffer
- { glvbNumVertices :: Int
- , glvbVertexSize :: Int
-
- , glvbUsage :: Usage
- , glvbLockInfo :: IORef (Maybe (Int,Int,Bool)) -- LockStart LockSize RequireUpdate
-
- , glvbShadowBuffer :: Maybe (Ptr Word8)
- , glvbBufferObject :: Maybe GL.BufferObject
- }
- deriving Eq
-
-instance HardwareVertexBuffer GLVertexBuffer where
- getVertexSize = glvbVertexSize
- getNumVertices = glvbNumVertices
-
-instance HardwareBuffer GLVertexBuffer where
- getSizeInBytes b = glvbVertexSize b * glvbNumVertices b
- isSystemMemory = isNothing . glvbBufferObject
- hasShadowBuffer b = (isJust $ glvbShadowBuffer b) && (isJust $ glvbBufferObject b)
- getUsage = glvbUsage
- isLocked = glvbIsLocked
- unlock = glvbUnlock
- lock = glvbLock
-
-glvbIsLocked b = do
- i <- readIORef $ glvbLockInfo b
- return $ isJust i
-
-glvbLock a offs len opts = do
- lockinfo <- readIORef (glvbLockInfo a)
- when (isJust lockinfo) $ error "Cannot lock this buffer, it is already locked!"
- writeIORef (glvbLockInfo a) $ Just (offs,len,opts /= HBL_READ_ONLY)
- case glvbShadowBuffer a of
- { Just b -> return $ plusPtr b offs
- ; Nothing -> do
- GL.bindBuffer GL.ArrayBuffer $= (glvbBufferObject a)
- -- Discard if required
- when (opts == HBL_DISCARD) $ GL.bufferData GL.ArrayBuffer $= (fromIntegral $ getSizeInBytes a, nullPtr, getGLUsage $ getUsage a)
- let isWriteOnly = case getUsage a of
- { HBU_WRITE_ONLY -> True
- ; HBU_STATIC_WRITE_ONLY -> True
- ; HBU_DYNAMIC_WRITE_ONLY -> True
- ; HBU_DYNAMIC_WRITE_ONLY_DISCARDABLE -> True
- ; _ -> False
- }
- access = case (isWriteOnly,opts == HBL_READ_ONLY) of
- { (False,False) -> GL.ReadWrite
- ; (False,True) -> GL.ReadOnly
- ; (True,_) -> GL.WriteOnly
- }
- mb <- GL.mapBuffer GL.ArrayBuffer access
- case mb of
- { Just b -> return $ plusPtr b offs
- ; Nothing -> error "Vertex Buffer: Out of memory"
- }
- }
-
-glvbUnlock a = do
- lockinfo <- readIORef (glvbLockInfo a)
- let (lockStart,lockSize,reqUpdate) = case lockinfo of
- { Just li -> li
- ; Nothing -> error "Cannot unlock this buffer, it is not locked!"
- }
- writeIORef (glvbLockInfo a) Nothing
- case glvbShadowBuffer a of
- { Just b -> when reqUpdate $ do -- If we used the shadow buffer this time...
- GL.bindBuffer GL.ArrayBuffer $= (glvbBufferObject a)
- case lockStart == 0 && lockSize == getSizeInBytes a of
- { True -> GL.bufferData GL.ArrayBuffer $= (fromIntegral lockSize, b, getGLUsage $ getUsage a)
- ; False -> GL.bufferSubData GL.ArrayBuffer GL.WriteToBuffer (fromIntegral lockStart) (fromIntegral lockSize) b
- }
- ; Nothing -> do
- GL.bindBuffer GL.ArrayBuffer $= (glvbBufferObject a)
- ok <- GL.unmapBuffer GL.ArrayBuffer
- unless ok $ error "Buffer data corrupted, please reload"
- }
-
---mkGLVertexBuffer :: RenderSystem rs => rs -> Int -> Int -> Usage -> Bool -> IO GLVertexBuffer
-mkGLVertexBuffer rs vertexSize numVerts usage useShadowBuffer = do
- lockinfo <- newIORef Nothing
- [bufferObject] <- GL.genObjectNames 1
- GL.bindBuffer GL.ArrayBuffer $= Just bufferObject
- GL.bufferData GL.ArrayBuffer $= (fromIntegral $ numVerts * vertexSize, nullPtr, getGLUsage usage)
- shadowBuffer <- case useShadowBuffer of
- { True -> do
- b <- mallocBytes $ numVerts * vertexSize
- return $ Just b
- ; False -> return Nothing
- }
- return $ GLVertexBuffer
- { glvbNumVertices = numVerts
- , glvbVertexSize = vertexSize
-
- , glvbUsage = usage
- , glvbLockInfo = lockinfo
-
- , glvbShadowBuffer = shadowBuffer
- , glvbBufferObject = Just bufferObject
- }
-
-rmGLVertexBuffer :: GLVertexBuffer -> IO ()
-rmGLVertexBuffer a = do
- case glvbBufferObject a of
- { Just b -> GL.deleteObjectNames [b]
- ; Nothing -> return ()
- }
- case glvbShadowBuffer a of
- { Just b -> free b
- ; Nothing -> return ()
- }
diff --git a/Graphics/LambdaCube/RenderSystem/GL/GpuProgram.hs b/Graphics/LambdaCube/RenderSystem/GL/GpuProgram.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/LambdaCube/RenderSystem/GL/GpuProgram.hs
@@ -0,0 +1,147 @@
+module Graphics.LambdaCube.RenderSystem.GL.GpuProgram where
+
+import Data.List
+import Control.Monad
+import Foreign
+import Foreign.C.String
+
+import Graphics.Rendering.OpenGL.Raw.Core31
+import qualified Graphics.Rendering.OpenGL.Raw.EXT as EXT
+
+import Graphics.LambdaCube.GpuProgram
+import Graphics.LambdaCube.HardwareVertexBuffer
+
+-- Some drivers (e.g. OS X on nvidia) incorrectly determine the attribute binding automatically
+-- and end up aliasing existing built-ins. So avoid! Fixed builtins are:
+
+-- a builtin custom attrib name
+-- ----------------------------------------------
+-- 0 gl_Vertex vertex
+-- 1 n/a blendWeights
+-- 2 gl_Normal normal
+-- 3 gl_Color colour
+-- 4 gl_SecondaryColor secondary_colour
+-- 5 gl_FogCoord fog_coord
+-- 7 n/a blendIndices
+-- 8 gl_MultiTexCoord0 uv0
+-- 9 gl_MultiTexCoord1 uv1
+-- 10 gl_MultiTexCoord2 uv2
+-- 11 gl_MultiTexCoord3 uv3
+-- 12 gl_MultiTexCoord4 uv4
+-- 13 gl_MultiTexCoord5 uv5
+-- 14 gl_MultiTexCoord6 uv6, tangent
+-- 15 gl_MultiTexCoord7 uv7, binormal
+getFixedAttributeIndex :: VertexElementSemantic -> Int -> Int
+getFixedAttributeIndex semantic index = case semantic of
+ VES_POSITION -> 0
+ VES_BLEND_WEIGHTS -> 1
+ VES_NORMAL -> 2
+ VES_DIFFUSE -> 3
+ VES_SPECULAR -> 4
+ VES_BLEND_INDICES -> 7
+ VES_TEXTURE_COORDINATES -> 8 + index
+ VES_TANGENT -> 14
+ VES_BINORMAL -> 15
+
+isAttributeValid :: VertexElementSemantic -> Int -> Bool
+isAttributeValid semantic _ = case semantic of
+ VES_POSITION -> False
+ VES_NORMAL -> False
+ VES_DIFFUSE -> False
+ VES_SPECULAR -> False
+ VES_TEXTURE_COORDINATES -> False
+ VES_BLEND_WEIGHTS -> True
+ VES_BLEND_INDICES -> True
+ VES_BINORMAL -> True
+ VES_TANGENT -> True
+
+data GLGpuProgram
+ = GLGpuProgram
+ { glgpShaderObject :: GLuint
+ }
+ deriving (Eq,Ord)
+
+data GLLinkedGpuProgram
+ = GLLinkedGpuProgram
+ { gllgpProgramObject :: GLuint
+ }
+ deriving (Eq,Ord)
+
+instance LinkedGpuProgram GLLinkedGpuProgram
+
+instance GpuProgram GLGpuProgram
+
+withGLStringLen :: String -> ((Ptr b, Int) -> IO a) -> IO a
+withGLStringLen s act =
+ withCAStringLen s $ \(p,len) ->
+ act (castPtr p, fromIntegral len)
+
+setShaderSource :: GLuint -> [String] -> IO ()
+setShaderSource shader srcs = do
+ let len = genericLength srcs
+ withMany withGLStringLen srcs $ \charBufsAndLengths -> do
+ let (charBufs, lengths) = unzip charBufsAndLengths
+ withArray charBufs $ \charBufsBuf ->
+ withArray (map fromIntegral lengths) $ \lengthsBuf ->
+ glShaderSource shader len charBufsBuf lengthsBuf
+
+shaderInfoLog :: GLuint -> IO String
+shaderInfoLog a = allocaArray maxLen $ \s -> alloca $ \l -> do
+ glGetShaderInfoLog a (fromIntegral maxLen) l s
+ len <- peek l
+ peekCStringLen (castPtr s, fromIntegral len)
+ where
+ maxLen = 256
+
+programInfoLog :: GLuint -> IO String
+programInfoLog a = allocaArray maxLen $ \s -> alloca $ \l -> do
+ glGetProgramInfoLog a (fromIntegral maxLen) l s
+ len <- peek l
+ peekCStringLen (castPtr s, fromIntegral len)
+ where
+ maxLen = 256
+
+--compileShader :: GpuProgramType -> String -> IO (Either a String)
+compileShader :: Integral a => a -> String -> IO (Either GLuint [Char])
+compileShader ptype src = do
+ shader <- glCreateShader $ fromIntegral ptype
+ setShaderSource shader [src]
+ glCompileShader shader
+
+ -- TEMP CODE
+ infoLog <- shaderInfoLog shader
+ --infoM "ResourceLibrary" $ "shader infoLog cmp " ++ infoLog
+ ok <- alloca $ \buf -> glGetShaderiv shader gl_COMPILE_STATUS buf >> peek buf
+ case ok == fromIntegral gl_TRUE of
+ False -> do
+ glDeleteShader shader
+ --errl <- GL.get GL.errors
+ return $ Right $ "shader compilation failed: " ++ infoLog -- ++ concat [show c ++ " - " ++ m ++ "\n" | GL.Error c m <- errl]
+ True -> return $ Left shader
+
+mkGLGpuProgram :: GpuProgramType -> String -> IO (Either GLGpuProgram String)
+mkGLGpuProgram ptype src = do
+ let stype = case ptype of
+ GPT_VERTEX_PROGRAM -> gl_VERTEX_SHADER
+ GPT_FRAGMENT_PROGRAM -> gl_FRAGMENT_SHADER
+ GPT_GEOMETRY_PROGRAM -> EXT.gl_GEOMETRY_SHADER
+ s <- compileShader stype src
+ case s of
+ Right m -> return $ Right m
+ Left sh -> return $ Left $ GLGpuProgram sh
+
+mkGLLinkedGpuProgram :: [GLGpuProgram] -> IO (Either GLLinkedGpuProgram String)
+mkGLLinkedGpuProgram pl = do
+ p <- glCreateProgram
+ forM_ (map glgpShaderObject pl) $ \sh -> glAttachShader p sh
+ glLinkProgram p
+
+ infoLog <- programInfoLog p
+ -- infoM "ResourceLibrary" $ "program infoLog cmp " ++ infoLog
+ ok <- alloca $ \buf -> glGetProgramiv p gl_LINK_STATUS buf >> peek buf
+ case ok == fromIntegral gl_TRUE of
+ False -> do
+ glDeleteProgram p
+ --errl <- GL.get GL.errors
+ return $ Right $ "GpuProgram linking failed: " ++ infoLog -- ++ concat [show c ++ " - " ++ m ++ "\n" | GL.Error c m <- errl]
+ True -> return $ Left $ GLLinkedGpuProgram p
diff --git a/Graphics/LambdaCube/RenderSystem/GL/IndexBuffer.hs b/Graphics/LambdaCube/RenderSystem/GL/IndexBuffer.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/LambdaCube/RenderSystem/GL/IndexBuffer.hs
@@ -0,0 +1,137 @@
+module Graphics.LambdaCube.RenderSystem.GL.IndexBuffer where
+
+import Control.Applicative
+import Control.Monad
+import Data.IORef
+import Data.Maybe
+import Data.Ord
+import Data.Word
+import Foreign
+
+import Graphics.Rendering.OpenGL.Raw.Core31
+
+import Graphics.LambdaCube.HardwareBuffer
+import Graphics.LambdaCube.HardwareIndexBuffer
+import Graphics.LambdaCube.RenderSystem.GL.Utils
+
+-- | Specialisation of HardwareIndexBuffer for GL
+data GLIndexBuffer
+ = GLIndexBuffer
+ { glibType :: IndexType
+ , glibNumIndexes :: Int
+
+ , glibUsage :: Usage
+ , glibLockInfo :: IORef (Maybe (Int,Int,Bool)) -- LockStart LockSize RequireUpdate
+
+ , glibShadowBuffer :: Maybe (Ptr Word8)
+ , glibBufferObject :: GLuint
+ }
+ deriving Eq
+
+-- TODO: inconsistent Eq vs. Ord!
+instance Ord GLIndexBuffer where
+ compare = comparing glibBufferObject
+
+instance HardwareIndexBuffer GLIndexBuffer where
+ getIndexType = glibType
+ getNumIndexes = glibNumIndexes
+ getIndexSize b = case getIndexType b of
+ IT_16BIT -> 2
+ IT_32BIT -> 4
+
+instance HardwareBuffer GLIndexBuffer where
+ getSizeInBytes b = getIndexSize b * glibNumIndexes b
+ isSystemMemory b = 0 == glibBufferObject b
+ hasShadowBuffer b = (isJust $ glibShadowBuffer b) && (0 /= glibBufferObject b)
+ getUsage = glibUsage
+ isLocked = glibIsLocked
+ unlock = glibUnlock
+ lock = glibLock
+
+glibIsLocked :: GLIndexBuffer -> IO Bool
+glibIsLocked b = do
+ i <- readIORef $ glibLockInfo b
+ return $ isJust i
+
+glibLock :: GLIndexBuffer -> Int -> Int -> LockOptions -> IO (Ptr Word8)
+glibLock a offs len opts = do
+ lockinfo <- readIORef (glibLockInfo a)
+ when (isJust lockinfo) $ error "Cannot lock this buffer, it is already locked!"
+ writeIORef (glibLockInfo a) $ Just (offs,len,opts /= HBL_READ_ONLY)
+ case glibShadowBuffer a of
+ Just b -> do
+ --putStrLn "lock shadow IBO buffer"
+ return $ plusPtr b offs
+ Nothing -> do
+ --putStrLn "lock IBO buffer"
+ glBindBuffer gl_ELEMENT_ARRAY_BUFFER $ glibBufferObject a
+ -- Discard if required
+ when (opts == HBL_DISCARD) $ glBufferData gl_ELEMENT_ARRAY_BUFFER (fromIntegral $ getSizeInBytes a) nullPtr (getGLUsage $ getUsage a)
+ let isWriteOnly = case getUsage a of
+ HBU_WRITE_ONLY -> True
+ HBU_STATIC_WRITE_ONLY -> True
+ HBU_DYNAMIC_WRITE_ONLY -> True
+ HBU_DYNAMIC_WRITE_ONLY_DISCARDABLE -> True
+ _ -> False
+ access = case (isWriteOnly,opts == HBL_READ_ONLY) of
+ (False,False) -> gl_READ_WRITE
+ (False,True) -> gl_READ_ONLY
+ (True,_) -> gl_WRITE_ONLY
+ b <- glMapBuffer gl_ELEMENT_ARRAY_BUFFER access
+ case b == nullPtr of
+ True -> error "Index Buffer: Out of memory"
+ False -> return $ plusPtr b offs
+
+glibUnlock :: GLIndexBuffer -> IO ()
+glibUnlock a = do
+ lockinfo <- readIORef (glibLockInfo a)
+ let (lockStart,lockSize,reqUpdate) = case lockinfo of
+ Just li -> li
+ Nothing -> error "Cannot unlock this buffer, it is not locked!"
+ writeIORef (glibLockInfo a) Nothing
+ case glibShadowBuffer a of
+ Just b -> when reqUpdate $ do -- If we used the shadow buffer this time...
+ --putStrLn "unlock shadow IBO buffer"
+ glBindBuffer gl_ELEMENT_ARRAY_BUFFER $ glibBufferObject a
+ case lockStart == 0 && lockSize == getSizeInBytes a of
+ True -> glBufferData gl_ELEMENT_ARRAY_BUFFER (fromIntegral lockSize) b (getGLUsage $ getUsage a)
+ False -> glBufferSubData gl_ELEMENT_ARRAY_BUFFER (fromIntegral lockStart) (fromIntegral lockSize) b
+ Nothing -> do
+ --putStrLn "unlock IBO buffer"
+ glBindBuffer gl_ELEMENT_ARRAY_BUFFER $ glibBufferObject a
+ ok <- glUnmapBuffer gl_ELEMENT_ARRAY_BUFFER
+ unless (ok /= (fromIntegral gl_FALSE)) $ error "Buffer data corrupted, please reload"
+
+mkGLIndexBuffer :: IndexType -> Int -> Usage -> Bool -> IO GLIndexBuffer
+mkGLIndexBuffer itype numIndexes usage useShadowBuffer = do
+ let isize = case itype of
+ IT_16BIT -> 2
+ IT_32BIT -> 4
+ bufferSize = numIndexes * isize
+ bufferObject <- alloca $ \buf -> glGenBuffers 1 buf >> peek buf
+ --putStrLn $ "IBO ID: " ++ show bufferObject
+ lockinfo <- newIORef Nothing
+ glBindBuffer gl_ELEMENT_ARRAY_BUFFER bufferObject
+ glBufferData gl_ELEMENT_ARRAY_BUFFER (fromIntegral bufferSize) nullPtr (getGLUsage usage)
+ shadowBuffer <- case useShadowBuffer of
+ True -> Just <$> mallocBytes bufferSize
+ False -> return Nothing
+ return $ GLIndexBuffer
+ { glibType = itype
+ , glibNumIndexes = numIndexes
+
+ , glibUsage = usage
+ , glibLockInfo = lockinfo
+
+ , glibShadowBuffer = shadowBuffer
+ , glibBufferObject = bufferObject
+ }
+
+rmGLIndexBuffer :: GLIndexBuffer -> IO ()
+rmGLIndexBuffer a = do
+ case glibBufferObject a of
+ 0 -> return ()
+ b -> with b $ \buf -> glDeleteBuffers 1 buf
+ case glibShadowBuffer a of
+ Just b -> free b
+ Nothing -> return ()
diff --git a/Graphics/LambdaCube/RenderSystem/GL/OcclusionQuery.hs b/Graphics/LambdaCube/RenderSystem/GL/OcclusionQuery.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/LambdaCube/RenderSystem/GL/OcclusionQuery.hs
@@ -0,0 +1,43 @@
+module Graphics.LambdaCube.RenderSystem.GL.OcclusionQuery where
+
+import Foreign
+import Graphics.Rendering.OpenGL.Raw.Core31
+
+import Graphics.LambdaCube.HardwareOcclusionQuery
+
+data GLOcclusionQuery
+ = GLOcclusionQuery
+ { gloqQueryObject :: GLuint
+ }
+
+instance HardwareOcclusionQuery GLOcclusionQuery where
+ beginOcclusionQuery = glBeginOcclusionQuery
+ endOcclusionQuery = glEndOcclusionQuery
+ pullOcclusionQuery = glPullOcclusionQuery
+ isStillOutstanding = glStillOutstanding
+
+mkGLOcclusionQuery :: IO GLOcclusionQuery
+mkGLOcclusionQuery = do
+ q <- alloca $ \buf -> glGenQueries 1 buf >> peek buf
+ return $ GLOcclusionQuery q
+
+rmGLOcclusionQuery :: GLOcclusionQuery -> IO ()
+rmGLOcclusionQuery o = case gloqQueryObject o of
+ 0 -> return ()
+ b -> with b $ \buf -> glDeleteQueries 1 buf
+
+glBeginOcclusionQuery :: GLOcclusionQuery -> IO ()
+glBeginOcclusionQuery o = glBeginQuery gl_SAMPLES_PASSED $ gloqQueryObject o
+
+glEndOcclusionQuery :: GLOcclusionQuery -> IO ()
+glEndOcclusionQuery _ = glEndQuery gl_SAMPLES_PASSED
+
+glPullOcclusionQuery :: GLOcclusionQuery -> IO Int
+glPullOcclusionQuery o = do
+ n <- alloca $ \buf -> glGetQueryObjectuiv (gloqQueryObject o) gl_QUERY_RESULT buf >> peek buf
+ return $ fromIntegral n
+
+glStillOutstanding :: GLOcclusionQuery -> IO Bool
+glStillOutstanding o = do
+ b <- alloca $ \buf -> glGetQueryObjectuiv (gloqQueryObject o) gl_QUERY_RESULT_AVAILABLE buf >> peek buf
+ return $ b == fromIntegral gl_FALSE
diff --git a/Graphics/LambdaCube/RenderSystem/GL/RenderSystem.hs b/Graphics/LambdaCube/RenderSystem/GL/RenderSystem.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/LambdaCube/RenderSystem/GL/RenderSystem.hs
@@ -0,0 +1,885 @@
+{-# LANGUAGE MultiParamTypeClasses, NamedFieldPuns #-}
+module Graphics.LambdaCube.RenderSystem.GL.RenderSystem where
+
+import Control.Monad
+import Data.IORef
+import Data.IntMap ((!))
+import Data.Maybe
+import Data.Word
+import Foreign
+import Foreign.C.String
+import qualified Data.IntMap as IntMap
+import qualified Data.Set as Set
+
+import Graphics.Rendering.OpenGL.Raw.Core31
+import qualified Graphics.Rendering.OpenGL.Raw.ARB as ARB
+import qualified Graphics.Rendering.OpenGL.Raw.EXT as EXT
+import qualified Graphics.Rendering.OpenGL.Raw.ARB.Compatibility as Compat
+
+import Graphics.LambdaCube.BlendMode
+import Graphics.LambdaCube.Common
+import Graphics.LambdaCube.HardwareIndexBuffer
+import Graphics.LambdaCube.HardwareVertexBuffer
+import Graphics.LambdaCube.Light
+import Graphics.LambdaCube.RenderOperation
+import Graphics.LambdaCube.RenderSystem
+import Graphics.LambdaCube.RenderSystem.GL.Capabilities
+import Graphics.LambdaCube.RenderSystem.GL.GpuProgram
+import Graphics.LambdaCube.RenderSystem.GL.IndexBuffer
+import Graphics.LambdaCube.RenderSystem.GL.OcclusionQuery
+import Graphics.LambdaCube.RenderSystem.GL.Texture
+import Graphics.LambdaCube.RenderSystem.GL.Utils
+import Graphics.LambdaCube.RenderSystem.GL.VertexBuffer
+import Graphics.LambdaCube.RenderSystemCapabilities
+import Graphics.LambdaCube.Texture
+import Graphics.LambdaCube.TextureUnitState
+import Graphics.LambdaCube.Types
+import Graphics.LambdaCube.VertexIndexData
+
+data GLState
+ = GLState
+ { stLight :: (Proj4,[(Proj4,Light)])
+ , stSurface :: (FloatType4,FloatType4,FloatType4,FloatType4,FloatType,TrackVertexColourType)
+ }
+
+mkGLState :: IO (IORef GLState)
+mkGLState = do
+ let st = GLState
+ { stLight = (idmtx,[])
+ , stSurface = (c,c,c,c,0,TrackVertexColourType False False False False)
+ }
+ c = (0,0,0,0)
+ newIORef st
+
+instance Eq Proj4 where
+ a == b = fromProjective a == fromProjective b
+
+data GLRenderSystem
+ = GLRenderSystem
+ { glrsWorldMatrix :: IORef Proj4
+ , glrsViewMatrix :: IORef Proj4
+ , glrsCapabilities :: RenderSystemCapabilities
+ , glrsState :: IORef GLState
+ }
+
+mkGLRenderSystem :: IO GLRenderSystem
+mkGLRenderSystem = do
+ worldMat <- newIORef $ idmtx
+ viewMat <- newIORef $ idmtx
+ cap <- mkGLCapabilities
+ glState <- mkGLState
+
+ -- Initialize OpenGL
+ {-
+ glExtensions :: GettableStateVar [String]
+ glExtensions = makeGettableStateVar (fmap words $ getString gl_EXTENSIONS)
+
+ getString :: GLenum -> IO String
+ getString n = glGetString n >>= maybeNullPtr (return "") (peekCString . castPtr)
+
+ maybeNullPtr :: b -> (Ptr a -> b) -> Ptr a -> b
+ maybeNullPtr n f ptr | ptr == nullPtr = n
+ | otherwise = f ptr
+ -}
+ (major,minor) <- getGLVersion
+ extSList <- getGLExtensions
+ -- setup capabilities
+ let ext = Set.fromList extSList
+ glVer a b = major > a || (major >= a && minor >= b)
+ supports s = Set.member s ext
+ f = fromIntegral
+
+ when (glVer 1 2) $ do
+ -- Set nicer lighting model -- d3d9 has this by default
+ Compat.glLightModeli Compat.gl_LIGHT_MODEL_COLOR_CONTROL $ f Compat.gl_SEPARATE_SPECULAR_COLOR
+ Compat.glLightModeli Compat.gl_LIGHT_MODEL_LOCAL_VIEWER 1
+
+ when (glVer 1 4) $ do
+ glEnable Compat.gl_COLOR_SUM
+ glDisable gl_DITHER
+
+ -- Check for FSAA
+ when (supports "GL_ARB_multisample") $ do
+ fsaa <- getInteger ARB.gl_SAMPLE_BUFFERS
+ when (fsaa > 0) $ do
+ glEnable ARB.gl_MULTISAMPLE
+ putStrLn $ "Render System " ++ "Using FSAA from GL_ARB_multisample extension."
+
+ return $ GLRenderSystem
+ { glrsWorldMatrix = worldMat
+ , glrsViewMatrix = viewMat
+ , glrsCapabilities = cap
+ , glrsState = glState
+ }
+
+glWithFrameBuffer :: Int -> Int -> Int -> Int -> (Ptr Word8 -> IO ()) -> IO ()
+glWithFrameBuffer x y w h fn = allocaBytes (w*h*4) $ \p -> do
+ glReadPixels (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) gl_RGBA gl_UNSIGNED_BYTE $ castPtr p
+ fn p
+{-
+copyTexImage2D :: Maybe CubeMapTarget -> Level -> PixelInternalFormat -> Position -> TextureSize2D -> Border -> IO ()
+copyTexImage2D mbCubeMap level int (Position x y) (TextureSize2D w h) border =
+ glCopyTexImage2D
+ (maybe (marshalTextureTarget Texture2D) marshalCubeMapTarget mbCubeMap) level
+ (marshalPixelInternalFormat' int) x y w h border
+-}
+glDirtyHackCopyTexImage :: GLTexture -> Int -> Int -> Int -> Int -> IO ()
+glDirtyHackCopyTexImage tex x y w h = do
+ {-
+ GL.textureBinding GL.Texture2D $= (Just $ gltxTextureObject tex)
+ -- only hint code: glCopyTexImage2D(GL_TEXTURE_2D, 0, GL_LUMINANCE, 0, 0, 128, 128, 0);
+ GL.copyTexImage2D Nothing 0 GL.RGBA' (GL.Position (fromIntegral x) (fromIntegral y)) (GL.TextureSize2D (fromIntegral w) (fromIntegral h)) 0
+ -}
+ glActiveTexture $ fromIntegral gl_TEXTURE0
+ --glEnable gl_TEXTURE_2D
+ glBindTexture gl_TEXTURE_2D $ gltxTextureObject tex
+ -- only hint code: glCopyTexImage2D(GL_TEXTURE_2D, 0, GL_LUMINANCE, 0, 0, 128, 128, 0);
+ glCopyTexImage2D gl_TEXTURE_2D 0 gl_RGBA (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) 0
+
+instance RenderSystem GLRenderSystem GLVertexBuffer GLIndexBuffer GLOcclusionQuery GLTexture GLGpuProgram GLLinkedGpuProgram where
+ withFrameBuffer _ = glWithFrameBuffer
+ dirtyHackCopyTexImage _ = glDirtyHackCopyTexImage
+ getName _ = "OpenGL Rendering Subsystem"
+ getCapabilities = glrsCapabilities
+ createVertexBuffer _ = mkGLVertexBuffer
+ createIndexBuffer _ = mkGLIndexBuffer
+ createOcclusionQuery _ = mkGLOcclusionQuery
+ createTexture rs = mkGLTexture (glrsCapabilities rs)
+ createGpuProgram _ = mkGLGpuProgram
+ createLinkedGpuProgram _ = mkGLLinkedGpuProgram
+ bindLinkedGpuProgram _ = glBindLinkedGpuProgram
+ unbindLinkedGpuProgram _ = glUnBindLinkedGpuProgram
+ render _ = glRender
+ bindGeometry _ = glBindGeometry
+ unbindGeometry rs = glUnBindGeometry (glrsCapabilities rs)
+ setViewport _ x y w h = glSetViewport x y w h
+ setPolygonMode _ pm = glSetPolygonMode pm
+ setWorldMatrix = glSetWorldMatrix
+ setViewMatrix = glSetViewMatrix
+ setProjectionMatrix _ m = glSetProjectionMatrix m
+ clearFrameBuffer _ b c d s = glClearFrameBuffer b c d s
+ setShadingType _ = glSetShadingType
+ setCullingMode _ = glSetCullingMode
+ setAlphaRejectSettings rs = glSetAlphaRejectSettings (glrsCapabilities rs)
+ setDepthBias _ = glSetDepthBias
+ setDepthBufferCheckEnabled _ = glSetDepthBufferCheckEnabled
+ setDepthBufferWriteEnabled _ = glSetDepthBufferWriteEnabled
+ setDepthBufferFunction _ = glSetDepthBufferFunction --FIXME
+ setColourBufferWriteEnabled _ = glSetColourBufferWriteEnabled
+ setSurfaceParams = glSetSurfaceParams
+ setLightingEnabled _ = glSetLightingEnabled
+ useLights = glUseLights
+ setFog _ = glSetFog
+ setSceneBlending _ = glSetSceneBlending
+ setSeparateSceneBlending _ = glSetSeparateSceneBlending
+ setPointParameters = glSetPointParameters
+ setPointSpritesEnabled rs = glSetPointSpritesEnabled (glrsCapabilities rs)
+ setActiveTextureUnit _ = glSetActiveTextureUnit
+ setTexture _ = glSetTexture
+ setTextureAddressingMode _ = glSetTextureAddressingMode
+ setTextureUnitFiltering _ = glSetTextureUnitFiltering
+ setTextureLayerAnisotropy _ = glSetTextureLayerAnisotropy
+ setTextureMipmapBias _ = glSetTextureMipmapBias
+ setTextureMatrix _ = glSetTextureMatrix
+ setTextureBorderColour _ = glSetTextureBorderColour
+ setTextureCoordCalculation _ = glSetTextureCoordCalculation
+ setTextureBlendMode rs = glSetTextureBlendMode (glrsCapabilities rs)
+ getMinimumDepthInputValue _ = -1
+ getMaximumDepthInputValue _ = 1
+ prepareRender _ = glPrepareRender
+ finishRender _ = glFinishRender
+
+glPrepareRender :: IO ()
+glPrepareRender = do
+ Compat.glColor3f 1 1 1
+ glEnable gl_SCISSOR_TEST
+
+glFinishRender :: IO ()
+glFinishRender = do
+ Compat.glColor3f 1 1 1
+ glDisable gl_SCISSOR_TEST
+
+glSetDepthBias :: FloatType -> FloatType -> IO ()
+glSetDepthBias constantBias slopeScaleBias = case constantBias /= 0 || slopeScaleBias /= 0 of
+ True -> do
+ glEnable gl_POLYGON_OFFSET_FILL
+ glEnable gl_POLYGON_OFFSET_POINT
+ glEnable gl_POLYGON_OFFSET_LINE
+ glPolygonOffset (realToFrac (-slopeScaleBias)) (realToFrac (-constantBias))
+ False -> do
+ glDisable gl_POLYGON_OFFSET_FILL
+ glDisable gl_POLYGON_OFFSET_POINT
+ glDisable gl_POLYGON_OFFSET_LINE
+
+glSetViewport :: Int -> Int -> Int -> Int -> IO ()
+glSetViewport x y w h = do
+ let x' = fromIntegral x
+ y' = fromIntegral y
+ w' = fromIntegral w
+ h' = fromIntegral h
+ glViewport x' y' w' h'
+ glScissor x' y' w' h' -- Configure the viewport clipping
+
+glSetPolygonMode :: PolygonMode -> IO ()
+glSetPolygonMode pm = case pm of
+ PM_POINTS -> polygonMode gl_POINT
+ PM_WIREFRAME -> polygonMode gl_LINE
+ PM_SOLID -> polygonMode gl_FILL
+ where
+ polygonMode m = do
+ glPolygonMode gl_FRONT m
+ glPolygonMode gl_BACK m
+
+-- TODO: handle double type, currently it supports Float only
+glSetupMatrix :: Proj4 -> Proj4 -> IO ()
+glSetupMatrix vm wm = do
+ Compat.glMatrixMode Compat.gl_MODELVIEW
+ with (wm .*. vm) $ \mp -> do
+ Compat.glLoadMatrixf $ castPtr mp
+
+glSetWorldMatrix :: GLRenderSystem -> Proj4 -> IO ()
+glSetWorldMatrix rs wm = do
+ writeIORef (glrsWorldMatrix rs) wm
+ viewMat <- readIORef $ glrsViewMatrix rs
+ glSetupMatrix viewMat wm
+
+glSetViewMatrix :: GLRenderSystem -> Proj4 -> IO ()
+glSetViewMatrix rs vm = do
+ writeIORef (glrsViewMatrix rs) vm
+ worldMat <- readIORef $ glrsWorldMatrix rs
+ glSetupMatrix vm worldMat
+
+glSetProjectionMatrix :: Mat4 -> IO ()
+glSetProjectionMatrix pm = do
+ Compat.glMatrixMode Compat.gl_PROJECTION
+ with pm $ \pp -> do
+ Compat.glLoadMatrixf $ castPtr pp
+
+glClearFrameBuffer :: FrameBufferType -> FloatType4 -> FloatType -> Word16 -> IO ()
+glClearFrameBuffer buffers colour depth stencil = do
+ tmpColorMask <- getBoolean4 gl_COLOR_WRITEMASK
+ tmpDepthMask <- getBoolean gl_DEPTH_WRITEMASK
+ tmpStencilMask <- getInteger gl_STENCIL_WRITEMASK
+ tmpScissor <- getInteger4 gl_SCISSOR_BOX
+
+ when (fbtColour buffers) $ do
+ let (r',g',b',a') = colour
+ (r,g,b,a) = (f r',f g',f b',f a')
+ f :: FloatType -> GLclampf
+ f = realToFrac
+ glColorMask 1 1 1 1
+ glClearColor r g b a
+
+ when (fbtDepth buffers) $ do
+ let f :: FloatType -> GLclampd
+ f = realToFrac
+ glDepthMask $ fromIntegral gl_TRUE
+ glClearDepth $ f depth
+
+ when (fbtStencil buffers) $ do
+ let f :: Word16 -> GLint
+ f = fromIntegral
+ glStencilMask 0xFFFFFFFF
+ glClearStencil $ f stencil
+
+ let f = fromIntegral
+ (x,y,w,h) <- getInteger4 gl_VIEWPORT
+ glScissor x y (f w) (f h)
+
+ -- HINT: workaround for a mesa gma bug
+ when (fbtColour buffers) $ glClear $ fromIntegral gl_COLOR_BUFFER_BIT
+ when (fbtDepth buffers) $ glClear $ fromIntegral gl_DEPTH_BUFFER_BIT
+ when (fbtStencil buffers) $ glClear $ fromIntegral gl_STENCIL_BUFFER_BIT
+ --GL.clear $ map fst $ filter (\(_,b) -> b) $ zip [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer] [fbtColour buffers, fbtDepth buffers, fbtStencil buffers]
+
+ let uncurry4 mf (a,b,c,d) = mf (fromIntegral a) (fromIntegral b) (fromIntegral c) (fromIntegral d)
+ uncurry4b mf (a,b,c,d) = mf (a) (b) (c) (d)
+ uncurry4 glScissor tmpScissor
+ glDepthMask $ fromIntegral tmpDepthMask
+ uncurry4b glColorMask tmpColorMask
+ glStencilMask $ fromIntegral tmpStencilMask
+
+glBindGeometry :: (Texture t) => RenderOperation GLVertexBuffer GLIndexBuffer -> [TextureUnitState t] -> IO ()
+glBindGeometry ro tl = do
+ let multitexturing = True -- 1 < (rscNumTextureUnits rcap)
+ vertexData = roVertexData ro
+ decl = vdVertexDeclaration vertexData
+ checkBinding e = case vdVertexBufferBinding vertexData of
+ VertexBufferBinding bm -> veSource e `IntMap.member` bm
+ -- bind vertex elements
+ mapM_ (bindElement ro tl) $ filter checkBinding $ vdElementList decl
+
+ when multitexturing $ Compat.glClientActiveTexture gl_TEXTURE0
+ -- bind index data and call draw operation
+ case roIndexData ro of
+ Just indexData -> glBindBuffer gl_ELEMENT_ARRAY_BUFFER $ glibBufferObject $ idIndexBuffer indexData
+ Nothing -> return ()
+
+ return ()
+
+glUnBindGeometry :: RenderSystemCapabilities -> RenderOperation GLVertexBuffer GLIndexBuffer -> IO ()
+glUnBindGeometry rsc _ro = do
+ let multitexturing = True -- 1 < (rscNumTextureUnits rcap)
+ f = fromIntegral
+
+ Compat.glDisableClientState Compat.gl_VERTEX_ARRAY
+ -- only valid up to GL_MAX_TEXTURE_UNITS, which is recorded in mFixedFunctionTextureUnits
+ case multitexturing of
+ True -> do
+ forM_ [0..(rscNumTextureUnits rsc - 1)] $ \stage -> do
+ Compat.glClientActiveTexture $ fromIntegral gl_TEXTURE0 + f stage
+ Compat.glDisableClientState Compat.gl_TEXTURE_COORD_ARRAY
+ Compat.glClientActiveTexture gl_TEXTURE0
+ False -> Compat.glDisableClientState Compat.gl_TEXTURE_COORD_ARRAY
+ Compat.glDisableClientState Compat.gl_NORMAL_ARRAY
+ Compat.glDisableClientState Compat.gl_COLOR_ARRAY
+ Compat.glDisableClientState Compat.gl_SECONDARY_COLOR_ARRAY
+
+ -- unbind any custom attributes
+
+ -- unbind buffers
+ glBindBuffer gl_ELEMENT_ARRAY_BUFFER 0
+ glBindBuffer gl_ARRAY_BUFFER 0
+ return ()
+
+-- _render :: RenderSystemCapabilities -> RenderOperation -> IO ()
+--glRender :: Int -> GLRenderState -> RenderOperation -> IO GLRenderState
+--glRender :: (HardwareVertexBuffer vb, HardwareIndexBuffer ib) => Int -> RenderOperation vb ib -> IO ()
+glRender :: RenderOperation GLVertexBuffer GLIndexBuffer -> IO ()
+glRender ro = do
+ -- TODO:
+ let vertexData = roVertexData ro
+ --multitexturing = True -- 1 < (rscNumTextureUnits rcap)
+ --Use adjacency if there is a geometry program and it requested adjacency info
+ -- TODO
+ --bool useAdjacency = (mGeometryProgramBound && mCurrentGeometryProgram->isAdjacencyInfoRequired());
+ primType = case roOperationType ro of -- Find the correct type to render
+ OT_POINT_LIST -> gl_POINTS
+ OT_LINE_LIST -> gl_LINES
+ OT_LINE_STRIP -> gl_LINE_STRIP
+ OT_TRIANGLE_LIST -> gl_TRIANGLES
+ OT_TRIANGLE_STRIP -> gl_TRIANGLE_STRIP
+ OT_TRIANGLE_FAN -> gl_TRIANGLE_FAN
+
+ -- bind index data and call draw operation
+ case roIndexData ro of
+ Just indexData -> do
+ let indexBuffer = idIndexBuffer indexData
+ dp = if 0 /= glibBufferObject indexBuffer then nullPtr else fromMaybe (error "fromJust 7") $ glibShadowBuffer indexBuffer
+ pBufferData = plusPtr dp $ idIndexStart indexData * getIndexSize indexBuffer
+ indexType = if getIndexType indexBuffer == IT_16BIT then gl_UNSIGNED_SHORT else gl_UNSIGNED_INT
+ --putStrLn $ "glDrawElements (VBI) buf ptr: " ++ show dp ++ " data ptr: " ++ show pBufferData
+ glDrawElements primType (fromIntegral (idIndexCount indexData)) indexType pBufferData
+ Nothing -> do
+ --putStrLn $ "glDrawArrays (VBI)"
+ glDrawArrays primType 0 (fromIntegral (vdVertexCount vertexData))
+
+bindElement :: (Texture t, HardwareIndexBuffer ib) => RenderOperation GLVertexBuffer ib -> [TextureUnitState t] -> VertexElement -> IO ()
+bindElement rop tl elem = do
+ let vertexData = roVertexData $ rop
+
+ case vdVertexBufferBinding vertexData of
+ VertexBufferBinding bm -> let vertexBuffer = bm ! (veSource elem) in do
+ dp <- case glvbBufferObject vertexBuffer of
+ 0 -> do
+ return $ fromMaybe (error "fromJust 8") $ glvbShadowBuffer vertexBuffer
+ b -> do
+ glBindBuffer gl_ARRAY_BUFFER b
+ return nullPtr
+
+ let pBufferData = plusPtr dp $ vdVertexStart vertexData * getVertexSize vertexBuffer + veOffset elem
+ sem = veSemantic elem
+ isCustomAttrib = False
+ bindWith t = t (fromIntegral . getTypeCount . veType $ elem) (getGLType . veType $ elem) (fromIntegral . getVertexSize $ vertexBuffer) pBufferData
+ bindWith' t = t (getGLType . veType $ elem) (fromIntegral . getVertexSize $ vertexBuffer) pBufferData
+ --putStrLn $ show sem ++ " (VBO) buf ptr: " ++ show dp ++ " data ptr: " ++ show pBufferData
+ --bind vertexBuffer
+ case isCustomAttrib of
+ True -> do
+ -- Custom attribute support
+ -- tangents, binormals, blendweights etc always via this route
+ -- builtins may be done this way too
+ let attrib = fromIntegral . getFixedAttributeIndex sem $ veIndex elem
+ normalised = case veType elem of
+ VET_COLOUR_ABGR -> gl_TRUE
+ VET_COLOUR_ARGB -> gl_TRUE
+ _ -> gl_FALSE
+ glVertexAttribPointer attrib (fromIntegral . getTypeCount . veType $ elem) (getGLType . veType $ elem) (fromIntegral normalised) (fromIntegral . getVertexSize $ vertexBuffer) pBufferData
+ glEnableVertexAttribArray attrib
+ --attribsBound.push_back(attrib);
+ False -> case sem of -- fixed-function & builtin attribute support
+ VES_POSITION -> bindWith Compat.glVertexPointer >> Compat.glEnableClientState Compat.gl_VERTEX_ARRAY
+ VES_NORMAL -> bindWith' Compat.glNormalPointer >> Compat.glEnableClientState Compat.gl_NORMAL_ARRAY
+ VES_DIFFUSE -> bindWith Compat.glColorPointer >> Compat.glEnableClientState Compat.gl_COLOR_ARRAY
+ VES_SPECULAR -> bindWith Compat.glSecondaryColorPointer >> Compat.glEnableClientState Compat.gl_SECONDARY_COLOR_ARRAY
+ VES_TEXTURE_COORDINATES -> do
+ -- TODO
+ let idx = veIndex elem
+ tus = map fst $ filter (\(_,a)-> idx==a) $ zip [0 :: Int ..] $ map tusTextureCoordSetIndex tl
+ forM_ tus $ \tidx -> do
+ --print $ "bind stage="++show tidx ++ " texcoord="++show idx
+ Compat.glClientActiveTexture $ fromIntegral gl_TEXTURE0 + fromIntegral tidx
+ bindWith Compat.glTexCoordPointer >> Compat.glEnableClientState Compat.gl_TEXTURE_COORD_ARRAY
+ _ -> error "bindElement"
+
+glSetShadingType :: ShadeOptions -> IO ()
+glSetShadingType so = case so of
+ SO_FLAT -> Compat.glShadeModel Compat.gl_FLAT
+ _ -> Compat.glShadeModel Compat.gl_SMOOTH
+
+glSetAlphaRejectSettings :: RenderSystemCapabilities -> CompareFunction -> Int -> Bool -> IO ()
+glSetAlphaRejectSettings rsc func value alphaToCoverage = do
+ let caps = rscCapabilities rsc
+ f = fromIntegral :: Int -> GLclampf
+ case func == CMPF_ALWAYS_PASS of
+ { True -> do
+ glDisable Compat.gl_ALPHA_TEST
+ when (Set.member RSC_ALPHA_TO_COVERAGE caps) $ glDisable gl_SAMPLE_ALPHA_TO_COVERAGE
+ ; False -> do
+ glEnable Compat.gl_ALPHA_TEST
+ Compat.glAlphaFunc (convertCompareFunction func) (f value / 255)
+ when (Set.member RSC_ALPHA_TO_COVERAGE caps) $ case alphaToCoverage of
+ True -> glEnable gl_SAMPLE_ALPHA_TO_COVERAGE
+ False -> glDisable gl_SAMPLE_ALPHA_TO_COVERAGE
+ }
+
+glSetDepthBufferCheckEnabled :: Bool -> IO ()
+glSetDepthBufferCheckEnabled enabled = case enabled of
+ { True -> glClearDepth 1 >> glEnable gl_DEPTH_TEST
+ ; False -> glDisable gl_DEPTH_TEST
+ }
+
+glSetDepthBufferWriteEnabled :: Bool -> IO ()
+glSetDepthBufferWriteEnabled enabled = case enabled of
+ { True -> glDepthMask $ fromIntegral gl_TRUE
+ ; False -> glDepthMask $ fromIntegral gl_FALSE
+ }
+
+glSetDepthBufferFunction :: CompareFunction -> IO ()
+glSetDepthBufferFunction func = glDepthFunc $ convertCompareFunction func
+
+glSetPointSpritesEnabled :: RenderSystemCapabilities -> Bool -> IO ()
+glSetPointSpritesEnabled rsc enabled = when (Set.member RSC_POINT_SPRITES $ rscCapabilities rsc) $ do
+ case enabled of
+ { True -> glEnable Compat.gl_POINT_SPRITE
+ ; False -> glDisable Compat.gl_POINT_SPRITE
+ }
+ let en = if enabled then gl_TRUE else gl_FALSE
+ -- Set sprite texture coord generation
+ -- Don't offer this as an option since D3D links it to sprite enabled
+ forM_ [0..rscNumTextureUnits rsc] $ \i -> do
+ glActiveTexture $ fromIntegral gl_TEXTURE0 + fromIntegral i
+ Compat.glTexEnvi Compat.gl_POINT_SPRITE Compat.gl_COORD_REPLACE $ fromIntegral en
+ glActiveTexture $ fromIntegral gl_TEXTURE0
+
+glSetSceneBlending :: SceneBlendFactor -> SceneBlendFactor -> SceneBlendOperation -> IO ()
+glSetSceneBlending sourceFactor destFactor op = do
+ case sourceFactor == SBF_ONE && destFactor == SBF_ZERO of
+ { True -> glDisable gl_BLEND
+ ; False -> do
+ glEnable gl_BLEND
+ glBlendFunc (getBlendMode sourceFactor) (getBlendMode destFactor)
+ }
+ glBlendEquation $ getBlendEquation op
+
+glSetSurfaceParams :: GLRenderSystem -> FloatType4 -> FloatType4 -> FloatType4 -> FloatType4 -> FloatType -> TrackVertexColourType -> IO ()
+glSetSurfaceParams rs ambient diffuse specular emissive shininess tc@(TrackVertexColourType a d s e) = do
+ st@GLState { stSurface } <- readIORef $ glrsState rs
+ let newSt = (ambient, diffuse, specular, emissive, shininess, tc)
+ when (stSurface /= newSt) $ do
+ writeIORef (glrsState rs) $ st { stSurface = newSt }
+ -- Track vertex colour
+ -- There are actually 15 different combinations for tracking, of which
+ -- GL only supports the most used 5. This means that we have to do some
+ -- magic to find the best match. NOTE:
+ -- GL_AMBIENT_AND_DIFFUSE != GL_AMBIENT | GL__DIFFUSE
+ case (a,d,s,e) of
+ (False,False,False,False) -> glDisable Compat.gl_COLOR_MATERIAL
+ (True,True,_,_) -> glEnable Compat.gl_COLOR_MATERIAL >> Compat.glColorMaterial gl_FRONT_AND_BACK Compat.gl_AMBIENT_AND_DIFFUSE
+ (True,False,_,_) -> glEnable Compat.gl_COLOR_MATERIAL >> Compat.glColorMaterial gl_FRONT_AND_BACK Compat.gl_AMBIENT
+ (_,True,_,_) -> glEnable Compat.gl_COLOR_MATERIAL >> Compat.glColorMaterial gl_FRONT_AND_BACK Compat.gl_DIFFUSE
+ (_,_,True,_) -> glEnable Compat.gl_COLOR_MATERIAL >> Compat.glColorMaterial gl_FRONT_AND_BACK Compat.gl_SPECULAR
+ (_,_,_,True) -> glEnable Compat.gl_COLOR_MATERIAL >> Compat.glColorMaterial gl_FRONT_AND_BACK Compat.gl_EMISSION
+ let f = realToFrac
+ c (r,g,b,a') = [f r, f g, f b, f a']
+ withArray (c diffuse) $ \p -> Compat.glMaterialfv gl_FRONT_AND_BACK Compat.gl_DIFFUSE p
+ withArray (c ambient) $ \p -> Compat.glMaterialfv gl_FRONT_AND_BACK Compat.gl_AMBIENT p
+ withArray (c specular) $ \p -> Compat.glMaterialfv gl_FRONT_AND_BACK Compat.gl_SPECULAR p
+ withArray (c emissive) $ \p -> Compat.glMaterialfv gl_FRONT_AND_BACK Compat.gl_EMISSION p
+ Compat.glMaterialf gl_FRONT_AND_BACK Compat.gl_SHININESS $ f shininess
+
+glSetLightingEnabled :: Bool -> IO ()
+glSetLightingEnabled enabled = case enabled of
+ True -> glEnable Compat.gl_LIGHTING
+ False -> glDisable Compat.gl_LIGHTING
+
+glSetFog :: FogMode -> FloatType4 -> FloatType -> FloatType -> FloatType -> IO ()
+glSetFog mode (r,g,b,a) density start end = case mode of
+ FOG_NONE -> glDisable Compat.gl_FOG
+ FOG_EXP -> setFog $ fromIntegral Compat.gl_EXP
+ FOG_EXP2 -> setFog $ fromIntegral Compat.gl_EXP2
+ FOG_LINEAR-> setFog $ fromIntegral gl_LINEAR
+ where
+ f = realToFrac
+ setFog fm = withArray [r,g,b,a] $ \p -> do
+ glEnable Compat.gl_FOG
+ Compat.glFogi Compat.gl_FOG_MODE fm
+ Compat.glFogfv Compat.gl_FOG_COLOR $ castPtr p
+ Compat.glFogf Compat.gl_FOG_DENSITY $ f density
+ Compat.glFogf Compat.gl_FOG_START $ f start
+ Compat.glFogf Compat.gl_FOG_END $ f end
+
+glSetSeparateSceneBlending :: SceneBlendFactor -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendOperation -> SceneBlendOperation -> IO ()
+glSetSeparateSceneBlending sourceFactor destFactor sourceFactorAlpha destFactorAlpha op alphaOp = do
+ case sourceFactor == SBF_ONE && destFactor == SBF_ZERO &&
+ sourceFactorAlpha == SBF_ONE && destFactorAlpha == SBF_ZERO of
+ True -> glDisable gl_BLEND
+ False -> do
+ let f = getBlendMode
+ glEnable gl_BLEND
+ glBlendFuncSeparate (f sourceFactor) (f sourceFactorAlpha) (f destFactor) (f destFactorAlpha)
+ glBlendEquationSeparate (getBlendEquation op) (getBlendEquation alphaOp)
+
+glSetPointParameters :: (RenderSystem rs vb ib q t p lp) => rs -> FloatType -> Bool -> FloatType -> FloatType -> FloatType -> FloatType -> FloatType -> IO ()
+glSetPointParameters rs size attenuationEnabled constant linear quadratic minSize maxSize = do
+ let rsc = getCapabilities rs
+ caps = rscCapabilities rsc
+ f = realToFrac
+ (size',_minSize',_maxSize',val') <- case attenuationEnabled of
+ True -> do
+ when (Set.member RSC_VERTEX_PROGRAM caps) $
+ glEnable gl_VERTEX_PROGRAM_POINT_SIZE
+ let correction = 0.005
+ return (size,minSize,if maxSize == 0 then rscMaxPointSize rsc else maxSize,[f $ constant,f $ linear * correction,f $ quadratic * correction,1])
+ False -> do
+ when (Set.member RSC_VERTEX_PROGRAM caps) $
+ glDisable gl_VERTEX_PROGRAM_POINT_SIZE
+ return (size,minSize,if maxSize == 0 then rscMaxPointSize rsc else maxSize,[1,0,0,1])
+ --no scaling required
+ -- GL has no disabled flag for this so just set to constant
+ glPointSize $ f size'
+ withArray val' $ \val -> case Set.member RSC_POINT_EXTENDED_PARAMETERS caps of
+ True -> do
+ glPointParameterfv Compat.gl_POINT_DISTANCE_ATTENUATION val
+ glPointParameterf Compat.gl_POINT_SIZE_MIN $ f minSize
+ glPointParameterf Compat.gl_POINT_SIZE_MAX $ f maxSize
+ False -> case Set.member RSC_POINT_EXTENDED_PARAMETERS_ARB caps of
+ True -> do
+ ARB.glPointParameterfv Compat.gl_POINT_DISTANCE_ATTENUATION val
+ ARB.glPointParameterf Compat.gl_POINT_SIZE_MIN $ f minSize
+ ARB.glPointParameterf Compat.gl_POINT_SIZE_MAX $ f maxSize
+ False -> case Set.member RSC_POINT_EXTENDED_PARAMETERS_EXT caps of
+ True -> do
+ EXT.glPointParameterfv Compat.gl_POINT_DISTANCE_ATTENUATION val
+ EXT.glPointParameterf Compat.gl_POINT_SIZE_MIN $ f minSize
+ EXT.glPointParameterf Compat.gl_POINT_SIZE_MAX $ f maxSize
+ False -> return ()
+
+glSetActiveTextureUnit :: Int -> IO ()
+glSetActiveTextureUnit stage = do
+ let f = fromIntegral
+ glActiveTexture $ fromIntegral $ gl_TEXTURE0 + f stage
+
+glSetTexture :: Maybe GLTexture -> IO ()
+glSetTexture tex = do
+ glDisable gl_TEXTURE_1D
+ glBindTexture gl_TEXTURE_1D 0
+
+ glDisable gl_TEXTURE_2D
+ glBindTexture gl_TEXTURE_2D 0
+
+ glDisable gl_TEXTURE_3D
+ glBindTexture gl_TEXTURE_3D 0
+
+ glDisable gl_TEXTURE_CUBE_MAP
+ glBindTexture gl_TEXTURE_CUBE_MAP 0
+ case tex of
+ Just t -> do
+ --TEMP CODE
+ let target = getGLTextureTarget $ txTextureType t
+ glEnable target
+ glBindTexture target $ gltxTextureObject t
+ Nothing -> return ()
+ --TODO
+
+glUseLights :: GLRenderSystem -> [(Proj4,Light)] -> IO ()
+glUseLights rs lights = do
+ viewMat <- readIORef $ glrsViewMatrix rs
+ worldMat <- readIORef $ glrsWorldMatrix rs
+ st@GLState { stLight } <- readIORef $ glrsState rs
+ when (stLight /= (worldMat, lights)) $ do
+ writeIORef (glrsState rs) $ st { stLight = (worldMat,lights) }
+ glSetupMatrix viewMat idmtx
+
+ -- disable unused lights
+ forM_ [length lights..7] $ \i -> glDisable $ Compat.gl_LIGHT0 + fromIntegral i
+
+ forM_ (zip [0..] $ take 8 lights) $ \(i,(mt,lt)) -> do
+ let gl_index = Compat.gl_LIGHT0 + i
+ rad2deg = 180 / pi
+ f = realToFrac
+ c (r,g,b,a) = [f r, f g, f b, f a]
+ pos1 = _4 $ fromProjective mt
+ --pos0 = extendZero $ (trim pos1 :: Vec3) :: Vec4
+
+ case lgType lt of
+ LT_SPOTLIGHT -> do
+ Compat.glLightf gl_index Compat.gl_SPOT_CUTOFF $ realToFrac $ 0.5 * rad2deg * lgSpotOuter lt
+ Compat.glLightf gl_index Compat.gl_SPOT_EXPONENT $ realToFrac $ lgSpotFalloff lt
+ _ -> Compat.glLightf gl_index Compat.gl_SPOT_CUTOFF 180
+
+ withArray (c $ lgDiffuse lt) $ \p ->
+ Compat.glLightfv gl_index Compat.gl_DIFFUSE p
+
+ withArray (c $ lgSpecular lt) $ \p ->
+ Compat.glLightfv gl_index Compat.gl_SPECULAR p
+
+ -- Disable ambient light for movables
+ withArray [0,0,0,1] $ \p ->
+ Compat.glLightfv gl_index Compat.gl_AMBIENT p
+
+ -- Set position / direction
+ let pos = if lgType lt == LT_DIRECTIONAL then neg dir4 else pos1
+ dir4 = (extendZero $ lgDirection lt :: Vec4) .* (fromProjective mt)
+ --putStrLn $ show (lgType lt) ++ " glPos: " ++ show pos
+ --putStrLn $ " glMat: " ++ show mt
+ with pos $ \p ->
+ Compat.glLightfv gl_index Compat.gl_POSITION $ castPtr p
+
+ -- Set spotlight direction
+ when (lgType lt == LT_SPOTLIGHT) $ with dir4 $ \p ->
+ Compat.glLightfv gl_index Compat.gl_SPOT_DIRECTION $ castPtr p
+
+ -- Attenuation
+ Compat.glLightf gl_index Compat.gl_CONSTANT_ATTENUATION $ realToFrac $ lgAttenuationConst lt
+ Compat.glLightf gl_index Compat.gl_LINEAR_ATTENUATION $ realToFrac $ lgAttenuationLinear lt
+ Compat.glLightf gl_index Compat.gl_QUADRATIC_ATTENUATION $ realToFrac $ lgAttenuationQuad lt
+ -- Enable in the scene
+ --putStrLn $ "setup light " ++ show i ++ " pos: " ++ show pos
+ glEnable gl_index
+ glSetupMatrix viewMat worldMat
+
+glSetTextureAddressingMode :: TextureType -> UVWAddressingMode -> IO ()
+glSetTextureAddressingMode texTarget (UVWAddressingMode u v w) = do
+ let target = getGLTextureTarget texTarget
+ glTexParameteri target gl_TEXTURE_WRAP_S $ fromIntegral $ getTextureAddressingMode u
+ glTexParameteri target gl_TEXTURE_WRAP_T $ fromIntegral $ getTextureAddressingMode v
+ glTexParameteri target gl_TEXTURE_WRAP_R $ fromIntegral $ getTextureAddressingMode w
+
+glSetTextureBorderColour :: TextureType -> FloatType4 -> IO ()
+glSetTextureBorderColour texTarget (r,g,b,a) = withArray [r,g,b,a] $ \p -> do
+ let target = getGLTextureTarget texTarget
+ glTexParameterfv target gl_TEXTURE_BORDER_COLOR $ castPtr p
+
+glSetTextureUnitFiltering :: TextureType -> FilterOptions -> FilterOptions -> FilterOptions -> IO ()
+glSetTextureUnitFiltering texTarget minFilter magFilter mipFilter = do
+ let target = getGLTextureTarget texTarget
+ mag = case magFilter of
+ FO_ANISOTROPIC -> gl_LINEAR
+ FO_LINEAR -> gl_LINEAR
+ FO_POINT -> gl_NEAREST
+ FO_NONE -> gl_NEAREST
+ min' = case minFilter of
+ FO_ANISOTROPIC -> FO_LINEAR
+ FO_LINEAR -> FO_LINEAR
+ FO_POINT -> FO_POINT
+ FO_NONE -> FO_POINT
+ mip = case mipFilter of
+ FO_ANISOTROPIC -> Just FO_LINEAR
+ FO_LINEAR -> Just FO_LINEAR
+ FO_POINT -> Just FO_POINT
+ FO_NONE -> Nothing
+ min'' = case (min',mip) of
+ (FO_POINT, Nothing) -> gl_NEAREST
+ (FO_LINEAR, Nothing) -> gl_LINEAR
+ (FO_POINT, Just FO_POINT) -> gl_NEAREST_MIPMAP_NEAREST
+ (FO_LINEAR, Just FO_POINT) -> gl_LINEAR_MIPMAP_NEAREST
+ (FO_POINT, Just FO_LINEAR) -> gl_NEAREST_MIPMAP_LINEAR
+ (FO_LINEAR, Just FO_LINEAR) -> gl_LINEAR_MIPMAP_LINEAR
+ _ -> error "glSetTextureUnitFiltering"
+ glTexParameteri target gl_TEXTURE_MAG_FILTER $ fromIntegral mag
+ glTexParameteri target gl_TEXTURE_MIN_FILTER $ fromIntegral min''
+
+glSetTextureLayerAnisotropy :: TextureType -> Int -> IO ()
+glSetTextureLayerAnisotropy texTarget maxAnisotropy = do
+ largest_supported_anisotropy <- alloca $ \p-> do
+ glGetFloatv EXT.gl_MAX_TEXTURE_MAX_ANISOTROPY p
+ peek p
+ let target = getGLTextureTarget texTarget
+ maxAnisotropy' = if fromIntegral maxAnisotropy > largest_supported_anisotropy then largest_supported_anisotropy else fromIntegral maxAnisotropy
+ glTexParameterf target EXT.gl_TEXTURE_MAX_ANISOTROPY maxAnisotropy'
+
+glSetTextureMipmapBias :: FloatType -> IO ()
+glSetTextureMipmapBias bias = do
+ Compat.glTexEnvf EXT.gl_TEXTURE_FILTER_CONTROL EXT.gl_TEXTURE_LOD_BIAS $ realToFrac bias
+
+{-
+doc: http://www.informit.com/articles/article.aspx?p=770639&seqNum=6
+FIXME: Test this code
+-}
+
+glSetTextureBlendMode :: RenderSystemCapabilities -> LayerBlendModeEx -> LayerBlendModeEx -> IO ()
+glSetTextureBlendMode rsc colorbm alphabm = do
+ let caps = rscCapabilities rsc
+ hasDot3 = Set.member RSC_DOT3 caps
+ csrc1op = getLayerBlendSource $ lbSource1 colorbm
+ csrc2op = getLayerBlendSource $ lbSource2 colorbm
+ ccmd = getTextureCombineFunction hasDot3 $ lbOperation colorbm
+ asrc1op = getLayerBlendSource $ lbSource1 alphabm
+ asrc2op = getLayerBlendSource $ lbSource2 alphabm
+ acmd = getTextureCombineFunction hasDot3 $ lbOperation alphabm
+ f = realToFrac
+ src2Fun m = do
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE2_RGB m
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE2_ALPHA m
+ cf (r,g,b,a) = [f r, f g, f b, f a]
+ alphaCol (r,g,b,_) a = cf (r, g, b, a)
+
+ -- Color blending
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_MODE $ fromIntegral Compat.gl_COMBINE
+
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_COMBINE_RGB $ fromIntegral ccmd
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE0_RGB $ fromIntegral csrc1op
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE1_RGB $ fromIntegral csrc2op
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE2_RGB $ fromIntegral Compat.gl_CONSTANT
+
+ case lbOperation colorbm of
+ LBX_BLEND_DIFFUSE_COLOUR -> src2Fun $ fromIntegral Compat.gl_PRIMARY_COLOR
+ LBX_BLEND_DIFFUSE_ALPHA -> src2Fun $ fromIntegral Compat.gl_PRIMARY_COLOR
+ LBX_BLEND_TEXTURE_ALPHA -> src2Fun $ fromIntegral gl_TEXTURE
+ LBX_BLEND_CURRENT_ALPHA -> src2Fun $ fromIntegral Compat.gl_PREVIOUS
+ LBX_BLEND_MANUAL -> withArray [0, 0, 0, realToFrac $ lbFactor colorbm] $ \p ->
+ Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p
+ LBX_MODULATE_X2 -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_RGB_SCALE 2
+ LBX_MODULATE_X4 -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_RGB_SCALE 4
+ _ -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_RGB_SCALE 1
+
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND0_RGB $ fromIntegral gl_SRC_COLOR
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND1_RGB $ fromIntegral gl_SRC_COLOR
+ case lbOperation colorbm of
+ LBX_BLEND_DIFFUSE_COLOUR -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND2_RGB $ fromIntegral gl_SRC_COLOR
+ _ -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND2_RGB $ fromIntegral gl_SRC_ALPHA
+
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND0_ALPHA $ fromIntegral gl_SRC_ALPHA
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND1_ALPHA $ fromIntegral gl_SRC_ALPHA
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND2_ALPHA $ fromIntegral gl_SRC_ALPHA
+ when (lbSource1 colorbm == LBS_MANUAL) $ withArray (cf $ lbColourArg1 colorbm) $ \p -> Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p
+ when (lbSource2 colorbm == LBS_MANUAL) $ withArray (cf $ lbColourArg2 colorbm) $ \p -> Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p
+
+ -- Alpha blending
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_MODE $ fromIntegral Compat.gl_COMBINE
+
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_COMBINE_ALPHA $ fromIntegral acmd
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE0_ALPHA $ fromIntegral asrc1op
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE1_ALPHA $ fromIntegral asrc2op
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE2_ALPHA $ fromIntegral Compat.gl_CONSTANT
+
+ case lbOperation alphabm of
+ LBX_BLEND_DIFFUSE_COLOUR -> src2Fun $ fromIntegral Compat.gl_PRIMARY_COLOR
+ LBX_BLEND_DIFFUSE_ALPHA -> src2Fun $ fromIntegral Compat.gl_PRIMARY_COLOR
+ LBX_BLEND_TEXTURE_ALPHA -> src2Fun $ fromIntegral gl_TEXTURE
+ LBX_BLEND_CURRENT_ALPHA -> src2Fun $ fromIntegral Compat.gl_PREVIOUS
+ LBX_BLEND_MANUAL -> withArray [0, 0, 0, realToFrac $ lbFactor alphabm] $ \p ->
+ Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p
+ LBX_MODULATE_X2 -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_ALPHA_SCALE 2
+ LBX_MODULATE_X4 -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_ALPHA_SCALE 4
+ _ -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_ALPHA_SCALE 1
+
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND0_ALPHA $ fromIntegral gl_SRC_ALPHA
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND1_ALPHA $ fromIntegral gl_SRC_ALPHA
+ Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND2_ALPHA $ fromIntegral gl_SRC_ALPHA
+ when (lbSource1 alphabm == LBS_MANUAL) $ withArray (alphaCol (lbColourArg1 colorbm) (lbAlphaArg1 alphabm)) $ \p -> Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p
+ when (lbSource2 alphabm == LBS_MANUAL) $ withArray (alphaCol (lbColourArg2 colorbm) (lbAlphaArg2 alphabm)) $ \p -> Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p
+
+glSetCullingMode :: CullingMode -> IO ()
+glSetCullingMode mode = case mode of
+ CULL_NONE -> glDisable gl_CULL_FACE
+ CULL_CLOCKWISE -> glEnable gl_CULL_FACE >> glCullFace gl_BACK
+ CULL_ANTICLOCKWISE -> glEnable gl_CULL_FACE >> glCullFace gl_FRONT
+
+glSetColourBufferWriteEnabled :: Bool -> Bool -> Bool -> Bool -> IO ()
+glSetColourBufferWriteEnabled r g b a = do
+ let f = fromBool
+ glColorMask (f r) (f g) (f b) (f a)
+
+glBindLinkedGpuProgram :: GLLinkedGpuProgram -> IO ()
+glBindLinkedGpuProgram lp = do
+ let p = gllgpProgramObject lp
+ withGLString :: String -> (Ptr GLchar -> IO a) -> IO a
+ withGLString s act = withCAString s $ act . castPtr
+ glUseProgram p
+ --TEMP CODE
+
+ loc_tex0 <- withGLString "tex0" $ glGetUniformLocation p
+ loc_tex1 <- withGLString "tex1" $ glGetUniformLocation p
+ glUniform1i loc_tex0 0
+ glUniform1i loc_tex1 1
+
+glUnBindLinkedGpuProgram :: IO ()
+glUnBindLinkedGpuProgram = glUseProgram 0
+
+glSetTextureMatrix :: Proj4 -> IO ()
+glSetTextureMatrix xform = do
+ Compat.glMatrixMode gl_TEXTURE
+ with xform $ \p -> do
+ Compat.glLoadMatrixf $ castPtr p
+
+glSetTextureCoordCalculation :: TexCoordCalcMethod -> IO ()
+glSetTextureCoordCalculation m = case m of
+ TEXCALC_NONE -> do
+ glDisable Compat.gl_TEXTURE_GEN_S
+ glDisable Compat.gl_TEXTURE_GEN_T
+ glDisable Compat.gl_TEXTURE_GEN_R
+ glDisable Compat.gl_TEXTURE_GEN_Q
+
+ TEXCALC_ENVIRONMENT_MAP -> do
+ Compat.glTexGeni Compat.gl_S Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_SPHERE_MAP
+ Compat.glTexGeni Compat.gl_T Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_SPHERE_MAP
+
+ glEnable Compat.gl_TEXTURE_GEN_S
+ glEnable Compat.gl_TEXTURE_GEN_T
+ glDisable Compat.gl_TEXTURE_GEN_R
+ glDisable Compat.gl_TEXTURE_GEN_Q
+
+ TEXCALC_ENVIRONMENT_MAP_PLANAR -> do
+ Compat.glTexGeni Compat.gl_S Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_SPHERE_MAP
+ Compat.glTexGeni Compat.gl_T Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_SPHERE_MAP
+
+ glEnable Compat.gl_TEXTURE_GEN_S
+ glEnable Compat.gl_TEXTURE_GEN_T
+ glDisable Compat.gl_TEXTURE_GEN_R
+ glDisable Compat.gl_TEXTURE_GEN_Q
+
+ TEXCALC_ENVIRONMENT_MAP_REFLECTION -> do
+ Compat.glTexGeni Compat.gl_S Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_REFLECTION_MAP
+ Compat.glTexGeni Compat.gl_T Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_REFLECTION_MAP
+ Compat.glTexGeni Compat.gl_R Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_REFLECTION_MAP
+
+ glEnable Compat.gl_TEXTURE_GEN_S
+ glEnable Compat.gl_TEXTURE_GEN_T
+ glEnable Compat.gl_TEXTURE_GEN_R
+ glDisable Compat.gl_TEXTURE_GEN_Q
+
+ TEXCALC_ENVIRONMENT_MAP_NORMAL -> do
+ Compat.glTexGeni Compat.gl_S Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_NORMAL_MAP
+ Compat.glTexGeni Compat.gl_T Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_NORMAL_MAP
+ Compat.glTexGeni Compat.gl_R Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_NORMAL_MAP
+ glEnable Compat.gl_TEXTURE_GEN_S
+ glEnable Compat.gl_TEXTURE_GEN_T
+ glEnable Compat.gl_TEXTURE_GEN_R
+ glDisable Compat.gl_TEXTURE_GEN_Q
+
+ TEXCALC_PROJECTIVE_TEXTURE -> do
+ Compat.glTexGeni Compat.gl_S Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_EYE_LINEAR
+ Compat.glTexGeni Compat.gl_T Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_EYE_LINEAR
+ Compat.glTexGeni Compat.gl_R Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_EYE_LINEAR
+ Compat.glTexGeni Compat.gl_Q Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_EYE_LINEAR
+ withArray [1, 0, 0, 0] $ \p -> Compat.glTexGenfv Compat.gl_S Compat.gl_EYE_PLANE p
+ withArray [0, 1, 0, 0] $ \p -> Compat.glTexGenfv Compat.gl_T Compat.gl_EYE_PLANE p
+ withArray [0, 0, 1, 0] $ \p -> Compat.glTexGenfv Compat.gl_R Compat.gl_EYE_PLANE p
+ withArray [0, 0, 0, 1] $ \p -> Compat.glTexGenfv Compat.gl_Q Compat.gl_EYE_PLANE p
+ glEnable Compat.gl_TEXTURE_GEN_S
+ glEnable Compat.gl_TEXTURE_GEN_T
+ glEnable Compat.gl_TEXTURE_GEN_R
+ glEnable Compat.gl_TEXTURE_GEN_Q
+
diff --git a/Graphics/LambdaCube/RenderSystem/GL/Texture.hs b/Graphics/LambdaCube/RenderSystem/GL/Texture.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/LambdaCube/RenderSystem/GL/Texture.hs
@@ -0,0 +1,220 @@
+module Graphics.LambdaCube.RenderSystem.GL.Texture where
+
+import Control.Monad
+import Data.Maybe
+import Data.Ord
+import Foreign
+import qualified Data.Set as Set
+
+import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility
+import Graphics.Rendering.OpenGL.Raw.Core31
+
+import Graphics.LambdaCube.HardwareBuffer
+import Graphics.LambdaCube.Image
+import Graphics.LambdaCube.PixelFormat
+import Graphics.LambdaCube.RenderSystem.GL.Utils
+import Graphics.LambdaCube.RenderSystemCapabilities
+import Graphics.LambdaCube.Texture
+import Graphics.LambdaCube.Types
+
+data GLTexture
+ = GLTexture
+ { gltxName :: String
+ , gltxWidth :: Int
+ , gltxHeight :: Int
+ , gltxDepth :: Int
+ , gltxNumRequestedMipmaps :: TextureMipmap
+ , gltxNumMipmaps :: Int
+ , gltxMipmapsHardwareGenerated :: Bool
+ , gltxGamma :: FloatType
+ , gltxHwGamma :: Bool
+ , gltxFSAA :: Int
+ , gltxFSAAHint :: String
+ , gltxTextureType :: TextureType
+ , gltxFormat :: PixelFormat
+ , gltxUsage :: TextureUsage
+ , gltxSrcFormat :: PixelFormat
+ , gltxSrcWidth :: Int
+ , gltxSrcHeight :: Int
+ , gltxSrcDepth :: Int
+
+ , gltxDesiredFormat :: PixelFormat
+ , gltxDesiredIntegerBitDepth :: Int
+ , gltxDesiredFloatBitDepth :: Int
+ , gltxTreatLuminanceAsAlpha :: Bool
+
+ , gltxTextureObject :: GLuint
+ }
+
+instance Eq GLTexture where
+ x == y = compare x y == EQ
+
+instance Ord GLTexture where
+ compare = comparing gltxTextureObject
+
+instance HardwareBuffer GLTexture
+
+instance Texture GLTexture where
+ txName = gltxName
+ txWidth = gltxWidth
+ txHeight = gltxHeight
+ txDepth = gltxDepth
+ txNumRequestedMipmaps = gltxNumRequestedMipmaps
+ txNumMipmaps = gltxNumMipmaps
+ txMipmapsHardwareGenerated = gltxMipmapsHardwareGenerated
+ txGamma = gltxGamma
+ txHwGamma = gltxHwGamma
+ txFSAA = gltxFSAA
+ txFSAAHint = gltxFSAAHint
+ txTextureType = gltxTextureType
+ txFormat = gltxFormat
+ txSrcFormat = gltxSrcFormat
+ txSrcWidth = gltxSrcWidth
+ txSrcHeight = gltxSrcHeight
+ txSrcDepth = gltxSrcDepth
+
+ txDesiredFormat = gltxDesiredFormat
+ txDesiredIntegerBitDepth = gltxDesiredIntegerBitDepth
+ txDesiredFloatBitDepth = gltxDesiredFloatBitDepth
+ txTreatLuminanceAsAlpha = gltxTreatLuminanceAsAlpha
+
+mkGLTexture :: RenderSystemCapabilities -> String -> TextureType -> Int -> Int -> Int -> TextureMipmap -> PixelFormat -> TextureUsage -> Bool -> Int -> String -> Maybe [Image] -> IO GLTexture
+--FIXME: image parameter is temporary!!!!
+mkGLTexture rcaps name texType width height depth numMips format usage hwGammaCorrection _fsaa _fsaaHint mimage = do
+ let caps = rscCapabilities rcaps
+ putStrLn $ "createTexture " ++ "create " ++ show texType ++ " texture: " ++ name
+
+ when (texType == TEX_TYPE_3D && Set.notMember RSC_TEXTURE_3D caps) $ error "3D Textures not supported before OpenGL 1.2"
+
+ (major,minor) <- getGLVersion
+
+ let glVer a b = major > a || (major >= a && minor >= b)
+ texTarget = (getGLTextureTarget texType)
+ -- Convert to nearest power-of-two size if required
+ mWidth = optionalPO2 rcaps width
+ mHeight = optionalPO2 rcaps height
+ mDepth = optionalPO2 rcaps depth
+
+ -- Adjust format if required
+ mFormat = getNativeFormat texType format False -- TODO
+
+ -- Check requested number of mipmaps
+ maxMips = getMaxMipmaps mWidth mHeight mDepth mFormat
+ mNumMipmaps = maxMips -- TODO min maxMips numMips
+
+ -- Generate texture name
+ mTextureID <- alloca $ \buf -> glGenTextures 1 buf >> peek buf
+
+ -- Set texture type
+ glBindTexture texTarget mTextureID
+
+ -- This needs to be set otherwise the texture doesn't get rendered
+ when (glVer 1 2) $ glTexParameteri texTarget gl_TEXTURE_MAX_LEVEL mNumMipmaps
+
+ -- Set some misc default parameters so NVidia won't complain, these can of course be changed later
+ glTexParameteri texTarget gl_TEXTURE_MIN_FILTER $ fromIntegral gl_NEAREST
+ glTexParameteri texTarget gl_TEXTURE_MAG_FILTER $ fromIntegral gl_NEAREST
+
+ when (glVer 1 2) $ do
+ glTexParameteri texTarget gl_TEXTURE_WRAP_S $ fromIntegral gl_CLAMP_TO_EDGE
+ glTexParameteri texTarget gl_TEXTURE_WRAP_T $ fromIntegral gl_CLAMP_TO_EDGE
+
+ -- If we can do automip generation and the user desires this, do so
+ let mMipmapsHardwareGenerated = Set.member RSC_AUTOMIPMAP caps
+
+ let moreMips = case numMips of
+ MIP_UNLIMITED -> True
+ MIP_DEFAULT -> True -- TODO
+ MIP_NUMBER n -> n > 0
+
+ when (tuAutoMipmap usage && moreMips && mMipmapsHardwareGenerated) $ glTexParameteri texTarget gl_GENERATE_MIPMAP $ fromIntegral gl_TRUE
+
+ -- Allocate internal buffer so that glTexSubImageXD can be used
+ -- Internal format
+ let format' = getClosestGLInternalFormat mFormat hwGammaCorrection
+ isCompressed _ = False -- TODO
+ case isCompressed mFormat of
+ True -> do
+ putStrLn "compressed format is not implemented!"
+ False -> do
+ let setMip (w,h,d) mip = do
+ -- Normal formats
+ case texType of
+ TEX_TYPE_1D -> glTexImage1D gl_TEXTURE_1D mip format' w 0 gl_RGBA gl_UNSIGNED_BYTE nullPtr
+ TEX_TYPE_2D -> glTexImage2D gl_TEXTURE_2D mip format' w h 0 gl_RGBA gl_UNSIGNED_BYTE nullPtr
+ TEX_TYPE_3D -> glTexImage3D gl_TEXTURE_3D mip format' w h d 0 gl_RGBA gl_UNSIGNED_BYTE nullPtr
+ TEX_TYPE_CUBE_MAP -> forM_ [0..5] $ \face ->
+ glTexImage2D (gl_TEXTURE_CUBE_MAP_POSITIVE_X + face) mip format' w h 0 gl_RGBA gl_UNSIGNED_BYTE nullPtr
+ return (max 1 (w `div` 2), max 1 (h `div` 2), max 1 (d `div` 2))
+ f = fromIntegral
+ -- Run through this process to pregenerate mipmap piramid
+ foldM_ setMip (f mWidth,f mHeight,f mDepth) [0..(fromIntegral mNumMipmaps)]
+
+ -- TODO
+ -- TEMP CODE
+ when (isJust mimage) $ do
+ let images = fromJust mimage
+ imInfo i = (fmt,f w,f h)
+ where
+ f = fromIntegral
+ fmt = case imFormat i of
+ PF_L8 -> gl_LUMINANCE
+ PF_BYTE_LA -> gl_LUMINANCE_ALPHA
+ PF_R8G8B8 -> gl_RGB
+ PF_R8G8B8A8 -> gl_RGBA
+ _ -> error "mkGLTexture"
+ w = imWidth i
+ h = imHeight i
+ upload2D target i = do
+ let (fmt,w,h) = imInfo i
+ putStrLn $ "createTexture " ++ "upload2d: " ++ imName i
+ glTexImage2D target 0 format' w h 0 fmt gl_UNSIGNED_BYTE $ imDataPtr i
+
+ case texType of
+ TEX_TYPE_1D -> do
+ let (fmt,w,_h) = imInfo image
+ image = head images
+ glTexImage1D gl_TEXTURE_1D 0 format' w 0 fmt gl_UNSIGNED_BYTE $ imDataPtr image
+ TEX_TYPE_2D -> upload2D gl_TEXTURE_2D $ head images
+ TEX_TYPE_CUBE_MAP -> mapM_ (uncurry upload2D) $ zip [ gl_TEXTURE_CUBE_MAP_POSITIVE_Z -- front
+ , gl_TEXTURE_CUBE_MAP_NEGATIVE_Z -- back
+ , gl_TEXTURE_CUBE_MAP_POSITIVE_Y -- up
+ , gl_TEXTURE_CUBE_MAP_NEGATIVE_Y -- down
+ , gl_TEXTURE_CUBE_MAP_NEGATIVE_X -- left
+ , gl_TEXTURE_CUBE_MAP_POSITIVE_X -- right
+ ] images
+ _ -> return ()
+
+ --_createSurfaceList();
+
+ -- Get final internal format
+ -- TODO
+ --mFormat = getBuffer(0,0)->getFormat();
+ putStrLn $ "createTexture " ++ "created texture: " ++ name
+ return GLTexture
+ { gltxName = name
+ , gltxWidth = 0 --TODO
+ , gltxHeight = 0 --TODO
+ , gltxDepth = 0 --TODO
+ , gltxNumRequestedMipmaps = MIP_DEFAULT --TODO
+ , gltxNumMipmaps = 0 --TODO
+ , gltxMipmapsHardwareGenerated = True --TODO
+ , gltxGamma = 0 --TODO
+ , gltxHwGamma = True --TODO
+ , gltxFSAA = 0 --TODO
+ , gltxFSAAHint = "" --TODO
+ , gltxTextureType = texType
+ , gltxFormat = PF_R8G8B8 -- TODO
+ , gltxUsage = TextureUsage HBU_WRITE_ONLY False False-- TODO
+ , gltxSrcFormat = PF_R8G8B8 -- TODO
+ , gltxSrcWidth = 0 --TODO
+ , gltxSrcHeight = 0 --TODO
+ , gltxSrcDepth = 0 --TODO
+
+ , gltxDesiredFormat = PF_R8G8B8 --TODO
+ , gltxDesiredIntegerBitDepth = 0 --TODO
+ , gltxDesiredFloatBitDepth = 0 --TODO
+ , gltxTreatLuminanceAsAlpha = True --TODO
+
+ , gltxTextureObject = mTextureID
+ }
diff --git a/Graphics/LambdaCube/RenderSystem/GL/Utils.hs b/Graphics/LambdaCube/RenderSystem/GL/Utils.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/LambdaCube/RenderSystem/GL/Utils.hs
@@ -0,0 +1,271 @@
+module Graphics.LambdaCube.RenderSystem.GL.Utils where
+
+import Data.Bits
+import Data.Char
+import qualified Data.Set as Set
+import Foreign
+import Foreign.C.String
+
+import Graphics.Rendering.OpenGL.Raw.Core31
+import qualified Graphics.Rendering.OpenGL.Raw.ARB.Compatibility as Compat
+import qualified Graphics.Rendering.OpenGL.Raw.ARB as ARB
+import qualified Graphics.Rendering.OpenGL.Raw.EXT as EXT
+
+import Graphics.LambdaCube.BlendMode
+import Graphics.LambdaCube.Common
+import Graphics.LambdaCube.HardwareBuffer
+import Graphics.LambdaCube.HardwareVertexBuffer
+import Graphics.LambdaCube.PixelFormat
+import Graphics.LambdaCube.RenderSystemCapabilities
+import Graphics.LambdaCube.Texture
+import Graphics.LambdaCube.TextureUnitState
+
+{-# 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 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
+
+getFloat :: GLenum -> IO GLfloat
+getFloat n = alloca $ \i -> do
+ glGetFloatv n i
+ peek i
+
+getInteger :: GLenum -> IO GLint
+getInteger n = alloca $ \i -> do
+ glGetIntegerv n i
+ peek i
+
+getBoolean :: GLenum -> IO GLboolean
+getBoolean n = alloca $ \i -> do
+ glGetBooleanv n i
+ peek i
+
+getBoolean4 :: GLenum -> IO (GLboolean, GLboolean, GLboolean, GLboolean)
+getBoolean4 n = allocaArray 4 $ \buf -> do
+ glGetBooleanv n buf
+ peek4 (,,,) buf
+
+getInteger4 :: GLenum -> IO (GLint, GLint, GLint, GLint)
+getInteger4 n = allocaArray 4 $ \buf -> do
+ glGetIntegerv n buf
+ peek4 (,,,) buf
+
+getString :: GLenum -> IO String
+getString n = glGetString n >>= maybeNullPtr (return "") (peekCString . castPtr)
+ where
+ maybeNullPtr :: b -> (Ptr a -> b) -> Ptr a -> b
+ maybeNullPtr n f ptr | ptr == nullPtr = n
+ | otherwise = f ptr
+
+getGLExtensions :: IO [String]
+getGLExtensions = fmap words $ getString gl_EXTENSIONS
+
+getGLVersion :: IO (Int, Int)
+getGLVersion = fmap parse $ getString gl_VERSION
+ 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
+
+getGLUsage :: Usage -> GLenum
+getGLUsage usage = case usage of
+ HBU_STATIC -> gl_STATIC_DRAW
+ HBU_STATIC_WRITE_ONLY -> gl_STATIC_DRAW
+ HBU_DYNAMIC -> gl_DYNAMIC_DRAW
+ HBU_DYNAMIC_WRITE_ONLY -> gl_DYNAMIC_DRAW
+ HBU_DYNAMIC_WRITE_ONLY_DISCARDABLE -> gl_STREAM_DRAW
+ _ -> gl_DYNAMIC_DRAW
+
+getGLType :: VertexElementType -> GLenum
+getGLType t = case t of
+ VET_FLOAT1 -> gl_FLOAT
+ VET_FLOAT2 -> gl_FLOAT
+ VET_FLOAT3 -> gl_FLOAT
+ VET_FLOAT4 -> gl_FLOAT
+ VET_SHORT1 -> gl_SHORT
+ VET_SHORT2 -> gl_SHORT
+ VET_SHORT3 -> gl_SHORT
+ VET_SHORT4 -> gl_SHORT
+ VET_COLOUR_ABGR -> gl_UNSIGNED_BYTE
+ VET_COLOUR_ARGB -> gl_UNSIGNED_BYTE
+ VET_UBYTE4 -> gl_UNSIGNED_BYTE
+
+getGLTextureTarget :: TextureType -> GLenum
+getGLTextureTarget textureType = case textureType of
+ TEX_TYPE_1D -> gl_TEXTURE_1D
+ TEX_TYPE_2D -> gl_TEXTURE_2D
+ TEX_TYPE_3D -> gl_TEXTURE_3D
+ TEX_TYPE_CUBE_MAP -> gl_TEXTURE_CUBE_MAP
+
+optionalPO2 :: RenderSystemCapabilities -> Int -> Int
+optionalPO2 rcaps value = case Set.member RSC_NON_POWER_OF_2_TEXTURES (rscCapabilities rcaps) of
+ True -> value
+ False -> 2 ^ (1 + log2 (value-1))
+ where
+ log2 :: Int -> Int
+ log2 n = case n of
+ 0 -> -1
+ _ -> 1 + log2 (shiftR n 1)
+
+getMaxMipmaps :: Int -> Int -> Int -> PixelFormat -> GLint
+getMaxMipmaps width height depth _format = maximum [f width, f height, f depth]
+ where
+ bits :: Double -> Double
+ bits = logBase 2
+ f x = floor $ bits $ fromIntegral x
+
+-- TODO
+getNativeFormat :: TextureType -> PixelFormat -> Bool -> PixelFormat
+getNativeFormat _ttype _format _isTarget = PF_R8G8B8
+
+getClosestGLInternalFormat :: PixelFormat -> Bool -> GLint
+getClosestGLInternalFormat mFormat hwGamma = fromIntegral $ case mFormat of
+ PF_L8 -> Compat.gl_LUMINANCE8
+ PF_L16 -> Compat.gl_LUMINANCE16
+ PF_A8 -> Compat.gl_ALPHA8
+ PF_A4L4 -> Compat.gl_LUMINANCE4_ALPHA4
+ PF_BYTE_LA -> Compat.gl_LUMINANCE8_ALPHA8
+ PF_R3G3B2 -> gl_R3_G3_B2
+ PF_A1R5G5B5 -> gl_RGB5_A1
+ PF_R5G6B5 -> gl_RGB5
+ PF_B5G6R5 -> gl_RGB5
+ PF_A4R4G4B4 -> gl_RGBA4
+ PF_R8G8B8 -> if hwGamma then gl_SRGB8 else gl_RGB8
+ PF_B8G8R8 -> if hwGamma then gl_SRGB8 else gl_RGB8
+ PF_X8B8G8R8 -> if hwGamma then gl_SRGB8 else gl_RGB8
+ PF_X8R8G8B8 -> if hwGamma then gl_SRGB8 else gl_RGB8
+ PF_A8R8G8B8 -> if hwGamma then gl_SRGB8_ALPHA8 else gl_RGBA8
+ PF_B8G8R8A8 -> if hwGamma then gl_SRGB8_ALPHA8 else gl_RGBA8
+ PF_A2R10G10B10 -> gl_RGB10_A2
+ PF_A2B10G10R10 -> gl_RGB10_A2
+ PF_FLOAT16_R -> ARB.gl_LUMINANCE16F
+ PF_FLOAT16_RGB -> ARB.gl_RGB16F
+ PF_FLOAT16_GR -> ARB.gl_LUMINANCE_ALPHA16F
+ PF_FLOAT16_RGBA -> ARB.gl_RGBA16F
+ PF_FLOAT32_R -> ARB.gl_LUMINANCE32F
+ PF_FLOAT32_GR -> ARB.gl_LUMINANCE_ALPHA32F
+ PF_FLOAT32_RGB -> ARB.gl_RGB32F
+ PF_FLOAT32_RGBA -> ARB.gl_RGBA32F
+ PF_SHORT_RGBA -> gl_RGBA16
+ PF_SHORT_RGB -> gl_RGB16
+ PF_SHORT_GR -> Compat.gl_LUMINANCE16_ALPHA16
+ PF_DXT1 -> if hwGamma then EXT.gl_COMPRESSED_SRGB_ALPHA_S3TC_DXT1 else EXT.gl_COMPRESSED_RGBA_S3TC_DXT1
+ PF_DXT3 -> if hwGamma then EXT.gl_COMPRESSED_SRGB_ALPHA_S3TC_DXT3 else EXT.gl_COMPRESSED_RGBA_S3TC_DXT3
+ PF_DXT5 -> if hwGamma then EXT.gl_COMPRESSED_SRGB_ALPHA_S3TC_DXT5 else EXT.gl_COMPRESSED_RGBA_S3TC_DXT5
+ _ -> if hwGamma then gl_SRGB8 else gl_RGBA8
+
+{-
+getClosestPixelFormat :: GLenum -> PixelFormat
+getClosestPixelFormat fmt = case fmt of
+ gl_LUMINANCE8 -> PF_L8
+ gl_LUMINANCE16 -> PF_L16
+ gl_ALPHA8 -> PF_A8
+ gl_LUMINANCE4_ALPHA4 -> PF_BYTE_LA
+ gl_LUMINANCE8_ALPHA8 -> PF_BYTE_LA
+ gl_R3_G3_B2 -> PF_R3G3B2
+ gl_RGB5_A1 -> PF_A1R5G5B5
+ gl_RGB5 -> PF_R5G6B5
+ gl_RGBA4 -> PF_A4R4G4B4
+ gl_RGB8 -> PF_X8R8G8B8
+ gl_SRGB8 -> PF_X8R8G8B8
+ gl_RGBA8 -> PF_A8R8G8B8
+ gl_SRGB8_ALPHA8 -> PF_A8R8G8B8
+ gl_RGB10_A2 -> PF_A2R10G10B10
+ gl_RGBA16 -> PF_SHORT_RGBA
+ gl_RGB16 -> PF_SHORT_RGB
+ gl_LUMINANCE16_ALPHA16 -> PF_SHORT_GR
+ gl_LUMINANCE_FLOAT16_ATI -> PF_FLOAT16_R
+ gl_LUMINANCE_ALPHA_FLOAT16_ATI -> PF_FLOAT16_GR
+ gl_LUMINANCE_ALPHA_FLOAT32_ATI -> PF_FLOAT32_GR
+ gl_LUMINANCE_FLOAT32_ATI -> PF_FLOAT32_R
+ gl_RGB_FLOAT16_ATI -> PF_FLOAT16_RGB
+ gl_RGBA_FLOAT16_ATI -> PF_FLOAT16_RGBA
+ gl_RGB_FLOAT32_ATI -> PF_FLOAT32_RGB
+ gl_RGBA_FLOAT32_ATI -> PF_FLOAT32_RGBA
+ gl_COMPRESSED_RGB_S3TC_DXT1_EXT -> PF_DXT1
+ gl_COMPRESSED_RGBA_S3TC_DXT1_EXT -> PF_DXT1
+ gl_COMPRESSED_SRGB_S3TC_DXT1_EXT -> PF_DXT1
+ gl_COMPRESSED_SRGB_ALPHA_S3TC_DXT1_EXT -> PF_DXT1
+ gl_COMPRESSED_RGBA_S3TC_DXT3_EXT -> PF_DXT3
+ gl_COMPRESSED_SRGB_ALPHA_S3TC_DXT3_EXT -> PF_DXT3
+ gl_COMPRESSED_RGBA_S3TC_DXT5_EXT -> PF_DXT5
+ gl_COMPRESSED_SRGB_ALPHA_S3TC_DXT5_EXT -> PF_DXT5
+ _ -> PF_A8R8G8B8
+-}
+
+getBlendMode :: SceneBlendFactor -> GLenum
+getBlendMode blend = case blend of
+ SBF_ONE -> gl_ONE
+ SBF_ZERO -> gl_ZERO
+ SBF_DEST_COLOUR -> gl_DST_COLOR
+ SBF_SOURCE_COLOUR -> gl_SRC_COLOR
+ SBF_ONE_MINUS_DEST_COLOUR -> gl_ONE_MINUS_DST_COLOR
+ SBF_ONE_MINUS_SOURCE_COLOUR -> gl_ONE_MINUS_SRC_COLOR
+ SBF_DEST_ALPHA -> gl_DST_ALPHA
+ SBF_SOURCE_ALPHA -> gl_SRC_ALPHA
+ SBF_ONE_MINUS_DEST_ALPHA -> gl_ONE_MINUS_DST_ALPHA
+ SBF_ONE_MINUS_SOURCE_ALPHA -> gl_ONE_MINUS_SRC_ALPHA
+
+getBlendEquation :: SceneBlendOperation -> GLenum
+getBlendEquation op = case op of
+ SBO_ADD -> gl_FUNC_ADD
+ SBO_SUBTRACT -> gl_FUNC_SUBTRACT
+ SBO_REVERSE_SUBTRACT -> gl_FUNC_REVERSE_SUBTRACT
+ SBO_MIN -> gl_MIN
+ SBO_MAX -> gl_MAX
+
+getTextureAddressingMode :: TextureAddressingMode -> GLenum
+getTextureAddressingMode tam = case tam of
+ TAM_WRAP -> gl_REPEAT
+ TAM_MIRROR -> gl_MIRRORED_REPEAT
+ TAM_CLAMP -> gl_CLAMP_TO_EDGE
+ TAM_BORDER -> gl_CLAMP_TO_BORDER
+
+getLayerBlendSource :: LayerBlendSource -> GLenum
+getLayerBlendSource src = case src of
+ LBS_CURRENT -> Compat.gl_PREVIOUS
+ LBS_TEXTURE -> gl_TEXTURE
+ LBS_MANUAL -> Compat.gl_CONSTANT
+ LBS_DIFFUSE -> Compat.gl_PRIMARY_COLOR
+ LBS_SPECULAR -> Compat.gl_PRIMARY_COLOR
+
+getTextureCombineFunction :: Bool -> LayerBlendOperationEx -> GLenum
+getTextureCombineFunction hasDot3 op = case op of
+ LBX_SOURCE1 -> gl_REPLACE
+ LBX_SOURCE2 -> gl_REPLACE
+ LBX_MODULATE -> Compat.gl_MODULATE
+ LBX_MODULATE_X2 -> Compat.gl_MODULATE
+ LBX_MODULATE_X4 -> Compat.gl_MODULATE
+ LBX_ADD -> Compat.gl_ADD
+ LBX_ADD_SIGNED -> Compat.gl_ADD_SIGNED
+ LBX_ADD_SMOOTH -> Compat.gl_INTERPOLATE
+ LBX_SUBTRACT -> Compat.gl_SUBTRACT
+ LBX_BLEND_DIFFUSE_COLOUR -> Compat.gl_INTERPOLATE
+ LBX_BLEND_DIFFUSE_ALPHA -> Compat.gl_INTERPOLATE
+ LBX_BLEND_TEXTURE_ALPHA -> Compat.gl_INTERPOLATE
+ LBX_BLEND_CURRENT_ALPHA -> Compat.gl_INTERPOLATE
+ LBX_BLEND_MANUAL -> Compat.gl_INTERPOLATE
+ LBX_DOTPRODUCT -> if hasDot3 then Compat.gl_DOT3_RGB else Compat.gl_MODULATE
+
+convertCompareFunction :: CompareFunction -> GLenum
+convertCompareFunction f = case f of
+ CMPF_ALWAYS_FAIL -> gl_NEVER
+ CMPF_ALWAYS_PASS -> gl_ALWAYS
+ CMPF_LESS -> gl_LESS
+ CMPF_LESS_EQUAL -> gl_LEQUAL
+ CMPF_EQUAL -> gl_EQUAL
+ CMPF_NOT_EQUAL -> gl_NOTEQUAL
+ CMPF_GREATER_EQUAL -> gl_GEQUAL
+ CMPF_GREATER -> gl_GREATER
diff --git a/Graphics/LambdaCube/RenderSystem/GL/VertexBuffer.hs b/Graphics/LambdaCube/RenderSystem/GL/VertexBuffer.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/LambdaCube/RenderSystem/GL/VertexBuffer.hs
@@ -0,0 +1,131 @@
+module Graphics.LambdaCube.RenderSystem.GL.VertexBuffer where
+
+import Control.Monad
+import Control.Applicative
+import Data.IORef
+import Data.Maybe
+import Data.Ord
+import Data.Word
+import Foreign
+
+import Graphics.Rendering.OpenGL.Raw.Core31
+
+import Graphics.LambdaCube.HardwareBuffer
+import Graphics.LambdaCube.HardwareVertexBuffer
+import Graphics.LambdaCube.RenderSystem.GL.Utils
+
+-- | Specialisation of HardwareVertexBuffer for GL
+data GLVertexBuffer
+ = GLVertexBuffer
+ { glvbNumVertices :: Int
+ , glvbVertexSize :: Int
+
+ , glvbUsage :: Usage
+ , glvbLockInfo :: IORef (Maybe (Int,Int,Bool)) -- LockStart LockSize RequireUpdate
+
+ , glvbShadowBuffer :: Maybe (Ptr Word8)
+ , glvbBufferObject :: GLuint
+ }
+ deriving Eq
+
+-- TODO: inconsistent Eq vs. Ord!
+instance Ord GLVertexBuffer where
+ compare = comparing glvbBufferObject
+
+instance HardwareVertexBuffer GLVertexBuffer where
+ getVertexSize = glvbVertexSize
+ getNumVertices = glvbNumVertices
+
+instance HardwareBuffer GLVertexBuffer where
+ getSizeInBytes b = glvbVertexSize b * glvbNumVertices b
+ isSystemMemory b = 0 == glvbBufferObject b
+ hasShadowBuffer b = (isJust $ glvbShadowBuffer b) && (glvbBufferObject b /= 0)
+ getUsage = glvbUsage
+ isLocked = glvbIsLocked
+ unlock = glvbUnlock
+ lock = glvbLock
+
+glvbIsLocked :: GLVertexBuffer -> IO Bool
+glvbIsLocked b = do
+ i <- readIORef $ glvbLockInfo b
+ return $ isJust i
+
+glvbLock :: GLVertexBuffer -> Int -> Int -> LockOptions -> IO (Ptr Word8)
+glvbLock a offs len opts = do
+ lockinfo <- readIORef (glvbLockInfo a)
+ when (isJust lockinfo) $ error "Cannot lock this buffer, it is already locked!"
+ writeIORef (glvbLockInfo a) $ Just (offs,len,opts /= HBL_READ_ONLY)
+ case glvbShadowBuffer a of
+ Just b -> do
+ --putStrLn "lock shadow VBO buffer"
+ return $ plusPtr b offs
+ Nothing -> do
+ --putStrLn "lock VBO buffer"
+ glBindBuffer gl_ARRAY_BUFFER $ glvbBufferObject a
+ -- Discard if required
+ when (opts == HBL_DISCARD) $ glBufferData gl_ARRAY_BUFFER (fromIntegral $ getSizeInBytes a) nullPtr (getGLUsage $ getUsage a)
+ let isWriteOnly = case getUsage a of
+ HBU_WRITE_ONLY -> True
+ HBU_STATIC_WRITE_ONLY -> True
+ HBU_DYNAMIC_WRITE_ONLY -> True
+ HBU_DYNAMIC_WRITE_ONLY_DISCARDABLE -> True
+ _ -> False
+ access = case (isWriteOnly,opts == HBL_READ_ONLY) of
+ (False,False) -> gl_READ_WRITE
+ (False,True) -> gl_READ_ONLY
+ (True,_) -> gl_WRITE_ONLY
+ b <- glMapBuffer gl_ARRAY_BUFFER access
+ case b == nullPtr of
+ True -> error "Vertex Buffer: Out of memory"
+ False -> return $ plusPtr b offs
+
+glvbUnlock :: GLVertexBuffer -> IO ()
+glvbUnlock a = do
+ lockinfo <- readIORef (glvbLockInfo a)
+ let (lockStart,lockSize,reqUpdate) = case lockinfo of
+ Just li -> li
+ Nothing -> error "Cannot unlock this buffer, it is not locked!"
+ writeIORef (glvbLockInfo a) Nothing
+ case glvbShadowBuffer a of
+ Just b -> when reqUpdate $ do -- If we used the shadow buffer this time...
+ --putStrLn "unlock shadow VBO buffer"
+ glBindBuffer gl_ARRAY_BUFFER $ glvbBufferObject a
+ case lockStart == 0 && lockSize == getSizeInBytes a of
+ True -> glBufferData gl_ARRAY_BUFFER (fromIntegral lockSize) b (getGLUsage $ getUsage a)
+ False -> glBufferSubData gl_ARRAY_BUFFER (fromIntegral lockStart) (fromIntegral lockSize) b
+ Nothing -> do
+ --putStrLn "unlock VBO buffer"
+ glBindBuffer gl_ARRAY_BUFFER $ glvbBufferObject a
+ ok <- glUnmapBuffer gl_ARRAY_BUFFER
+ unless (ok /= (fromIntegral gl_FALSE)) $ error "Buffer data corrupted, please reload"
+
+mkGLVertexBuffer :: Int -> Int -> Usage -> Bool -> IO GLVertexBuffer
+mkGLVertexBuffer vertexSize numVerts usage useShadowBuffer = do
+ let bufferSize = numVerts * vertexSize
+ bufferObject <- alloca $ \buf -> glGenBuffers 1 buf >> peek buf
+ --putStrLn $ "VBO ID: " ++ show bufferObject
+ lockinfo <- newIORef Nothing
+ glBindBuffer gl_ARRAY_BUFFER bufferObject
+ glBufferData gl_ARRAY_BUFFER (fromIntegral bufferSize) nullPtr (getGLUsage usage)
+ shadowBuffer <- case useShadowBuffer of
+ True -> Just <$> mallocBytes bufferSize
+ False -> return Nothing
+ return $ GLVertexBuffer
+ { glvbNumVertices = numVerts
+ , glvbVertexSize = vertexSize
+
+ , glvbUsage = usage
+ , glvbLockInfo = lockinfo
+
+ , glvbShadowBuffer = shadowBuffer
+ , glvbBufferObject = bufferObject
+ }
+
+rmGLVertexBuffer :: GLVertexBuffer -> IO ()
+rmGLVertexBuffer a = do
+ case glvbBufferObject a of
+ 0 -> return ()
+ b -> with b $ \buf -> glDeleteBuffers 1 buf
+ case glvbShadowBuffer a of
+ Just b -> free b
+ Nothing -> return ()
diff --git a/Graphics/LambdaCube/RenderSystemCapabilities.hs b/Graphics/LambdaCube/RenderSystemCapabilities.hs
--- a/Graphics/LambdaCube/RenderSystemCapabilities.hs
+++ b/Graphics/LambdaCube/RenderSystemCapabilities.hs
@@ -4,7 +4,6 @@
import Graphics.LambdaCube.Types
--- | Enum describing the different hardware capabilities we want to check for
data Capabilities
= RSC_AUTOMIPMAP -- ^ Supports generating mipmaps in hardware
| RSC_BLENDING
@@ -42,10 +41,8 @@
| RSC_ALPHA_TO_COVERAGE -- ^ Supports Alpha to Coverage (A2C)
| RSC_ADVANCED_BLEND_OPERATIONS -- ^ Supports Blending operations other than +
- -- * DirectX specific caps
| RSC_PERSTAGECONSTANT -- ^ Is DirectX feature "per stage constants" supported
- -- * GL Specific Caps
| RSC_GL1_5_NOVBO -- ^ Supports openGL GLEW version 1.5
| RSC_FBO -- ^ Support for Frame Buffer Objects (FBOs)
| RSC_FBO_ARB -- ^ Support for Frame Buffer Objects ARB implementation (regular FBO is higher precedence)
@@ -56,8 +53,8 @@
| RSC_POINT_EXTENDED_PARAMETERS_EXT -- ^ Support for point parameters EXT implementation
deriving (Eq,Ord)
-data DriverVersion
- = DriverVersion
+data DriverVersion
+ = DriverVersion
{ dvMajor :: Int
, dvMinor :: Int
, dvRelease :: Int
@@ -79,20 +76,13 @@
| GPU_APPLE -- ^ Apple Software Renderer
deriving Eq
-{-| singleton class for storing the capabilities of the graphics card.
-@remarks
-This class stores the capabilities of the graphics card. This
-information is set by the individual render systems.
--}
data RenderSystemCapabilities
= RenderSystemCapabilities
{ rscDriverVersion :: DriverVersion
, rscVendor :: GPUVendor -- ^ GPU Vendor
--- , rscNumWorldMatrices :: Int -- ^ The number of world matrices available
, rscNumTextureUnits :: Int -- ^ The number of texture units available
, rscStencilBufferBitDepth :: Int -- ^ The stencil buffer bit depth
--- , rscNumVertexBlendMatrices :: Int -- ^ The number of matrices available for hardware blending
, rscCapabilities :: Set Capabilities -- ^ Stores the capabilities flags.
, rscDeviceName :: String -- ^ The name of the device as reported by the render system
@@ -116,4 +106,3 @@
, rscSupportedShaderProfiles :: Set String -- ^ The list of supported shader profiles
}
-
diff --git a/Graphics/LambdaCube/Resource.hs b/Graphics/LambdaCube/Resource.hs
--- a/Graphics/LambdaCube/Resource.hs
+++ b/Graphics/LambdaCube/Resource.hs
@@ -1,25 +1,27 @@
module Graphics.LambdaCube.Resource where
-import qualified Data.List as List
-import Data.Map (Map)
-import qualified Data.Map as Map
import Control.Monad
+import Control.Monad.Trans
import System.Directory
import System.FilePath
+import Data.List
+import qualified Data.Map as Map
+import Data.Maybe
+import Control.Applicative
-import qualified Data.ByteString.Lazy as B
-import qualified Data.ByteString as SB
-import Data.ByteString.Internal as B
import Codec.Archive.Zip
-import System.Log.Logger
+import qualified Data.ByteString.Internal as SB
+import qualified Data.ByteString.Lazy as LB
+import Graphics.LambdaCube.Compositor
+import Graphics.LambdaCube.GpuProgram
import Graphics.LambdaCube.Loader.CompositorScript
import Graphics.LambdaCube.Loader.MaterialScript
import Graphics.LambdaCube.Loader.ResourceScript
-import Graphics.LambdaCube.Compositor
import Graphics.LambdaCube.Material
+import Graphics.LambdaCube.RenderSystem
import Graphics.LambdaCube.Texture
-import Graphics.LambdaCube.GpuProgram
+import Graphics.LambdaCube.Utility
import Graphics.LambdaCube.World
-- load resources into resource library (initResources :: [ResourceGroup] -> ResourceLibrary)
@@ -36,110 +38,69 @@
= RI_Material (String,Material t lp)
| RI_GpuProgram (String,GpuProgramDescriptor p)
| RI_Compositor (String,Compositor t lp)
-
-addConfig cfgFile world = do
- Just rp <- loadResourcesCfg cfgFile
- addResourceLibrary rp world
-addResourceLibrary resPath w@World { wrResource = res } = do
- -- fold on every group and path
- -- getDirectoryContents :: FilePath -> IO [FilePath]
- -- doesDirectoryExist :: FilePath -> IO Bool
- -- takeExtension :: FilePath -> String
- -- TODO:
- -- scan whole resource path searching for resource files and load them:
- -- .material
- -- .program
- -- add normal (uncompiled) materials to material library
- let loadResGrp s (_,l) = foldM loadRes s l
- loadRes l (PathZip,n) = return l
- loadRes l p@(PathDir,n) = do
+addConfig :: RenderSystem r vb ib q t p lp => FilePath -> LCM (World r vb ib q t p lp) e ()
+addConfig cfgFile = do
+ Just rp <- liftIO $ loadResourcesCfg cfgFile
+ addResourceLibrary rp
+
+-- TODO: LCMify
+
+-- | Add a resource library (essentially a collection of paths) to the
+-- current set of search paths stored in the world.
+addResourceLibrary :: RenderSystem r vb ib q t p lp => [ResourceGroup] -> LCM (World r vb ib q t p lp) e ()
+addResourceLibrary resPath = do
+ world <- peekLCM
+ let res = wrResource world
+ loadResGrp s (_,l) = foldM' loadRes s l
+ loadRes l (PathZip,n) = do
+ ok <- doesFileExist n
+ case ok of
+ True -> do
+ a <- toArchive <$> LB.readFile n
+ foldM' (loadItem (\fn -> return $ fromEntry $ fromJust $ findEntryByPath fn a)) l $ filesInArchive a
+ False -> return l
+ loadRes l (PathDir,n) = do
ok <- doesDirectoryExist n
case ok of
- { True -> do
+ True -> do
c <- getDirectoryContents n
- foldM (loadItem n) l c
- ; False -> return l
- }
- loadItem dn l n = do
+ foldM' (loadItem (\fn -> LB.readFile $ n ++ "/" ++ fn)) l c
+ False -> return l
+ loadItem loadFun l n = do
--parseMaterial -> Maybe (mats,verts,frags)
case takeExtension n of
- { ".material" -> do
- debugM "ResourceLibrary" $ "load: " ++ n
- f <- B.readFile $ dn ++ "/" ++ n -- FIXME: this is temporary solution
- mb <- parseMaterial n $ map B.w2c $ B.unpack f
+ ".material" -> do
+ putStrLn $ "ResourceLibrary " ++ "load: " ++ n
+ f <- loadFun n -- FIXME: this is temporary solution
+ mb <- parseMaterial n $ map SB.w2c $ LB.unpack f
case mb of
- { Nothing -> do
- errorM "ResourceLibrary" $ "Syntax error in file " ++ n
+ Nothing -> do
+ putStrLn $ "ResourceLibrary " ++ "Syntax error in file " ++ n
return l
- ; Just (ml,vpl,fpl) -> do
+ Just (ml,vpl,fpl) -> do
let ms = [RI_Material (mtName m,m) | m <- ml]
vs = [RI_GpuProgram (gpdName m,m) | m <- vpl]
fs = [RI_GpuProgram (gpdName m,m) | m <- fpl]
return $ l ++ ms ++ vs ++ fs
- }
- ; ".compositor" -> do
- debugM "ResourceLibrary" $ "load: " ++ n
- f <- B.readFile $ dn ++ "/" ++ n -- FIXME: this is temporary solution
- mb <- parseCompositor n $ map B.w2c $ B.unpack f
+ ".compositor" -> do
+ putStrLn $ "ResourceLibrary " ++ "load: " ++ n
+ f <- loadFun n -- FIXME: this is temporary solution
+ mb <- parseCompositor n $ map SB.w2c $ LB.unpack f
case mb of
- { Nothing -> do
- errorM "ResourceLibrary" $ "Syntax error in file " ++ n
+ Nothing -> do
+ putStrLn $ "ResourceLibrary " ++ "Syntax error in file " ++ n
return l
- ; Just cl -> do
+ Just cl -> do
return $ l ++ [RI_Compositor (cmpName m,m) | m <- cl]
- }
- ; _ -> return l
- }
- insertList = List.foldl' (flip (uncurry Map.insert))
- l <- foldM loadResGrp [] resPath
- return w { wrResource = res
- { rlResourceGroups = resPath ++ rlResourceGroups res
- , rlMaterialMap = insertList (rlMaterialMap res) [m | (RI_Material m) <- l]
- , rlGpuProgramMap = insertList (rlGpuProgramMap res) [m | (RI_GpuProgram m) <- l]
- , rlCompositorMap = insertList (rlCompositorMap res) [m | (RI_Compositor m) <- l]
- }
- }
- --ResourceLibrary (resPath++path) meshes (Map.union mats materialMap) texes (Map.union shads shaderMap) progs
-
-{-
-loadResourceGroup
-dropResourceGroup
--}
-
-{-
---compileMaterial
--- load textures from disk to opengl
--- drops unnecessary techniques (include,exlude rules)
-compileMaterial :: ResourceLibrary -> String -> IO (ResourceLibrary,Material)
-compileMaterial rlib m = do
- let mm = (rlMaterialMap rlib)
- if Map.notMember m mm then error ("Unknown material: " ++ m) else return ()
- let (mt,mcmt) = mm Map.! m
- (rlib',cmt) <- if isJust mcmt then return (rlib,fromMaybe (error "fromJust 0") mcmt) else compMat rlib mt -- copy original material data and load texture units
- return (rlib',cmt) where
- compMat rl mat@(Material {mtTechnique=techs}) = do
- debugM "ResourceLibrary" $ "compiling material: " ++ m
- (rl',techs') <- foldM compTechnique (rl,[]) techs
- let matmap' = insert m (mat,Just cmt') (rlMaterialMap rl)
- cmt' = mat{mtTechnique=techs'}
- return (rl'{rlMaterialMap=matmap'},cmt')
- compTechnique (rl,l) t@(Technique {tcPass=p}) = do
- excl <- excludeTechnique t
- if excl then return (rl, l) else do
- (rl',p') <- foldM compPass (rl,[]) p
- return (rl',(l ++ [t{tcPass=p'}]))
- compPass (rl,l) p = do
- (rl',tu') <- foldM compTexUnit (rl,[]) $ psTextureUnit p
- let (ProgRefName prog) = psShaderProgram p
- (rl'',prog') <- compileProgram rl' prog
- return (rl'',(l ++ [p{psTextureUnit=tu', psShaderProgram=(ProgRefObj prog')}]))
- compTexUnit (rl,l) tu = do
- (rl',texid) <- loadTexture rl $ head $ tuTexture tu
- return (rl',(l ++ [tu{tuTextureObject=Just [texid]}]))
- excludeTechnique t@(Technique {tcPass=p}) = do
- -- exclude if shaders are not supported
- version <- GL.get (GL.majorMinor GL.glVersion)
- let reqShaders = not $ null $ filter (\(Pass {psShaderProgram=(ProgRefName (vp,pp))})-> isJust vp || isJust pp) p
- if reqShaders && version < (2,0) then return True else return False
--}
+ _ -> return l
+ insertList = foldl' (flip (uncurry Map.insert))
+ l <- liftIO $ foldM' loadResGrp [] resPath
+ pokeLCM $ world
+ { wrResource = res
+ { rlResourceGroups = resPath ++ rlResourceGroups res
+ , rlMaterialMap = insertList (rlMaterialMap res) [m | (RI_Material m) <- l]
+ , rlGpuProgramMap = insertList (rlGpuProgramMap res) [m | (RI_GpuProgram m) <- l]
+ , rlCompositorMap = insertList (rlCompositorMap res) [m | (RI_Compositor m) <- l]
+ }
+ }
diff --git a/Graphics/LambdaCube/SceneGraph.hs b/Graphics/LambdaCube/SceneGraph.hs
--- a/Graphics/LambdaCube/SceneGraph.hs
+++ b/Graphics/LambdaCube/SceneGraph.hs
@@ -1,141 +1,148 @@
module Graphics.LambdaCube.SceneGraph where
-import Data.Maybe
-import Data.Map as Map hiding (map)
-import qualified Data.IntMap as IntMap
-import Data.List as List
-import Control.Monad
-import System.FilePath
-
-import Data.Graph.Inductive
+import Control.Applicative
+import Data.List (foldl')
-import Graphics.LambdaCube.Types
import Graphics.LambdaCube.Common
-import Graphics.LambdaCube.Math
-import Graphics.LambdaCube.Light
-import Graphics.LambdaCube.Material
import Graphics.LambdaCube.Entity
-import Graphics.LambdaCube.Resource
+import Graphics.LambdaCube.GpuProgram
+import Graphics.LambdaCube.HardwareIndexBuffer
+import Graphics.LambdaCube.HardwareVertexBuffer
+import Graphics.LambdaCube.Light
import Graphics.LambdaCube.RenderQueue
-import Graphics.LambdaCube.World
-import Graphics.LambdaCube.Texture
import Graphics.LambdaCube.RenderSystem
-
---type MkSceneObjectAction = World -> IO (World, SceneObject)
---type MkNodeAction = ResourceLibrary -> IO (ResourceLibrary,(String,String),SceneNode)
-
---simpleCamera :: String -> MkSceneObjectAction
-simpleCamera name w = return (w,cam)
- where
- cam = SO_Camera Camera
- { cmName = name
- , cmFov = 45
- , cmNear = 0.1
- , cmFar = 5000
- , cmAspectRatio = Nothing
- , cmPolygonMode = PM_SOLID
- }
+import Graphics.LambdaCube.Texture
+import Graphics.LambdaCube.Tree
+import Graphics.LambdaCube.Types
+import Graphics.LambdaCube.World
---wireCamera :: String -> MkSceneObjectAction
-wireCamera name w = return (w,cam)
- where
- cam = SO_Camera Camera
- { cmName = name
- , cmFov = 45
- , cmNear = 0.1
- , cmFar = 5000
- , cmAspectRatio = Nothing
- , cmPolygonMode = PM_WIREFRAME
- }
+type MkSceneObjectAction r vb ib q t p lp e = LCM (World r vb ib q t p lp) e (SceneObject vb ib t lp)
---light :: MkSceneObjectAction
-light w = return (w,SO_Light $ Light {})
+type MkNodeAction r vb ib q t p lp e = LCM (World r vb ib q t p lp) e ((String, String), SceneNode vb ib t lp)
---camera :: Camera -> MkSceneObjectAction
-camera cam w = return (w,SO_Camera cam)
+-- | Construct a scene object representing a camera with the given
+-- specification.
+camera :: RenderSystem r vb ib q t p lp => Camera -> MkSceneObjectAction r vb ib q t p lp e
+camera = return . SO_Camera
---mesh :: String -> MkSceneObjectAction
-mesh name w = do
- (w',e) <- createEntity w name name
- return (w', SO_Entity e)
+-- | Construct a scene object representing a basic camera with the
+-- given name.
+simpleCamera :: RenderSystem r vb ib q t p lp => String -> MkSceneObjectAction r vb ib q t p lp e
+simpleCamera name = return $ SO_Camera Camera
+ { cmName = name
+ , cmFov = 45
+ , cmNear = 0.1
+ , cmFar = 5000
+ , cmAspectRatio = Nothing
+ , cmPolygonMode = PM_SOLID
+ }
---meshMat :: String -> [String] -> MkSceneObjectAction
-meshMat name mats w0 = do
- (w1,e0) <- createEntity w0 name name
- (w2,e1) <- setEntityMaterial w1 mats e0
- return (w2, SO_Entity e1)
+-- | Construct a scene object representing a wireframe-mode camera
+-- with the given name.
+wireCamera :: RenderSystem r vb ib q t p lp => String -> MkSceneObjectAction r vb ib q t p lp e
+wireCamera name = return $ SO_Camera Camera
+ { cmName = name
+ , cmFov = 45
+ , cmNear = 0.1
+ , cmFar = 5000
+ , cmAspectRatio = Nothing
+ , cmPolygonMode = PM_WIREFRAME
+ }
---mkNode :: String -> String -> Matrix4 -> [MkSceneObjectAction] -> MkNodeAction
-mkNode parent name t objActs w = do
- (w',o) <- foldM mkObjs (w,[]) objActs
- return (w',(parent,name),SceneNode name o t)
- where
- mkObjs (w,l) a = do
- (w',so) <- a w
- return (w',so:l)
-{-
-addSkyBox :: String -> World -> IO World
-addSkyBox s w@World { wrResource = rl, wrScene = scene } = do
- (rl',mat) <- compileMaterial rl s
- return w { wrResource = rl', wrScene = scene{scSky = Just $ SkyBox mat} }
--}
+-- | Construct a scene object representing a light source with the
+-- given specification.
+light :: RenderSystem r vb ib q t p lp => Light -> MkSceneObjectAction r vb ib q t p lp e
+light = return . SO_Light
-{-
-data Scene = Scene
- { scGraph :: Gr String ()
- -- use: bytestring-trie (efficient ByteString map)
- , scMap :: Map String SceneNode
- , scSky :: Maybe Sky
- -- Fog settings
+-- | Construct a scene object representing a basic light source.
+defaultLight :: RenderSystem r vb ib q t p lp => MkSceneObjectAction r vb ib q t p lp e
+defaultLight = light $ Light
+ { lgType = LT_POINT
+ , lgDiffuse = (1,1,1,1)
+ , lgDirection = Vec3 0 0 1
+ , lgSpecular = (0,0,0,0)
+ , lgSpotOuter = pi / 180 * 40
+ , lgSpotFalloff = 1
+ , lgRange = 100000
+ , lgAttenuationConst = 1
+ , lgAttenuationLinear = 0
+ , lgAttenuationQuad = 0
}
--}
---addScene :: [MkNodeAction] -> World -> IO World
-addScene nodes w@World { wrResource = rl, wrScene = scene } = do
- -- done: create scene nodes
- let mkNodes (w,pl,nl) a = do
- (w',p,sn) <- a w
- return (w',p:pl,sn:nl)
- (w',p,nodel) <- foldM mkNodes (w,[],[]) nodes
- -- done: register node ids and names to bimap
- -- done: create graph nodes
- -- done: create graph edges
- let namel = map snName nodel
- nodeids = newNodes (length nodes) $ scGraph scene
- m' = (scMap scene) `Map.union` (Map.fromList $ zip namel $ zip nodeids nodel)
- g = insEdges (map fe p) $ insNodes (zip nodeids namel) $ scGraph scene
- fe (p,c) = (fst $ m' ! p, fst $ m' ! c,())
- scene' = scene
- { scGraph = g
- , scMap = m'
- --, scSky :: Maybe Sky
- }
- return w' { wrScene = scene' }
-
---updateTransforms :: [(String,Matrix4)] -> World -> IO World
-updateTransforms l = return . mapScene (\s -> foldr updateSceneNode s l)
+-- | Construct a scene object representing a polygon mesh.
+mesh :: (RenderSystem rs vb ib q t p lp, Enum rqp)
+ => Maybe rqp -- ^ Render queue priority (defaults to 'RQP_Main').
+ -> Maybe [String] -- ^ The list of materials to overried those supplied by the original mesh.
+ -> String -- ^ The name of the mesh to use as the source.
+ -> MkSceneObjectAction rs vb ib q t p lp e
+mesh renderQueueID materials name = do
+ e <- createEntity name name (maybe (fromEnum RQP_Main) fromEnum renderQueueID)
+ case materials of
+ Nothing -> return (SO_Entity e)
+ Just mats -> SO_Entity <$> setEntityMaterial mats e
+
+-- | Construct a scene graph node description.
+node :: RenderSystem r vb ib q t p lp
+ => String -- ^ The name of the parent node.
+ -> String -- ^ The name of the node.
+ -> Proj4 -- ^ The transformation to apply the subtree with the node in its root.
+ -> [MkSceneObjectAction r vb ib q t p lp e] -- ^ The scene objects that make up the node.
+ -> MkNodeAction r vb ib q t p lp e
+node parent name t objActs = do
+ o <- sequence objActs
+ return ((parent,name),SceneNode name o t)
+
+-- | Add a list of new nodes to the global scene.
+addScene :: RenderSystem r vb ib q t p lp => [MkNodeAction r vb ib q t p lp e] -> LCM (World r vb ib q t p lp) e ()
+addScene nodes = do
+ ns <- sequence nodes
+ graph <- scGraph . wrScene <$> peekLCM
+ let graph' = foldl' regNode graph ns
+ regNode g ((parent,name),node) = case addNode parent name node g of
+ Nothing -> error $ "Unknown parent node: " ++ parent
+ Just g' -> g'
+ updateWorld $ mapScene $ \s -> s { scGraph = graph' }
+
+-- | Update the transformation matrices of the given nodes.
+updateTransforms :: RenderSystem r vb ib q t p lp => [(String, Proj4)] -> LCM (World r vb ib q t p lp) e ()
+updateTransforms l = updateWorld $ mapScene $ \s -> s { scGraph = foldl' update (scGraph s) l }
where
- updateSceneNode (name,mat) scene = scene { scMap = Map.insert name (n,sn') m}
- where
- m = scMap scene
- (n,sn) = m ! name
- sn' = sn {snTransform = mat}
+ update g (name,mat) = updateNode (\sn -> sn { snTransform = mat }) name g
---flattenScene :: Scene -> FlattenScene
-flattenScene s = FlattenScene
- { fsCamera = [(m,c) | (m,SO_Camera c) <- fs]
- , fsRenderable = [(m,prepare m e,rq,pr) | (m,SO_Entity e) <- fs]
- , fsLight = [(m,l) | (m,SO_Light l) <- fs]
- }
+-- | Update the objects associated with the given nodes.
+updateObjects :: RenderSystem rs vb ib q t p lp => [(String, [MkSceneObjectAction rs vb ib q t p lp e])] -> LCM (World rs vb ib q t p lp) e ()
+updateObjects = mapM_ updateSceneNode
where
- rq = constRenderQueueMain
- pr = constRenderableDefaultPriority
- fs = visitNode s 0 $ transl 0 0 0
+ updateSceneNode (name,objActs) = do
+ o <- sequence objActs
+ updateWorld $ mapScene $ \s ->
+ s { scGraph = updateNode (\sn -> sn {snObject = o}) name (scGraph s) }
- --visitNode :: Scene -> Int -> Matrix4 -> [(Matrix4,SceneObject)]
- visitNode g n t = [(lt,e) | e <- snObject ln ] ++ (concat [ visitNode g sn lt | sn <- suc (scGraph g) n ])
+flattenScene :: (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => Scene vb ib t lp -> FlattenScene vb ib t lp
+flattenScene scene = FlattenScene
+ { fsCamera = cs
+ , fsRenderable = rs
+ , fsLight = ls
+ }
+ where
+ pr = renderableDefaultPriority
+ (cs,rs,ls) = foldr sep ([],[],[])
+ [(m,o) | (m,os) <- flattenTree trans getObj idmtx (scGraph scene)
+ , o <- os
+ ]
where
- Just name = lab (scGraph g) n
- ln = snd $ (scMap g) ! name
- lt = (snTransform ln) <> t
+ trans t sn = snTransform sn .*. t
+ getObj t sn = (trans t sn, snObject sn)
+ sep (m,SO_Camera c) (cs,rs,ls) = ((m,c):cs,rs,ls)
+ sep (m,SO_Entity e) (cs,rs,ls) = (cs,(m,prepare m e,enRenderQueue e,pr):rs,ls)
+ sep (m,SO_Light l) (cs,rs,ls) = (cs,rs,(m,l):ls)
+
+-- | Render the given target.
+renderWorld :: RenderSystem r vb ib q t p lp
+ => FloatType -- ^ The current time in seconds (needed for animation).
+ -> String -- ^ The target to render.
+ -> LCM (World r vb ib q t p lp) e ()
+renderWorld time target = do
+ flatScene <- flattenScene . wrScene <$> peekLCM
+ renderFlatScene time target flatScene
diff --git a/Graphics/LambdaCube/Skeleton.hs b/Graphics/LambdaCube/Skeleton.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/LambdaCube/Skeleton.hs
@@ -0,0 +1,68 @@
+module Graphics.LambdaCube.Skeleton where
+
+import Graphics.LambdaCube.Types
+
+import Data.Map (Map)
+import Data.Tree
+import qualified Data.Vector as V
+
+data Bone = Bone
+ { bnPosition :: Vec3
+ , bnRotation :: U
+ }
+ deriving Show
+
+data KeyFrame = KeyFrame
+ { kfPosition :: Vec3
+ , kfRotation :: U
+ , kfTime :: FloatType
+ }
+ deriving Show
+
+data Animation = Animation
+ { anTracks :: V.Vector [KeyFrame]
+ , anLength :: FloatType
+ , anName :: String
+ }
+ deriving Show
+
+data Skeleton = Skeleton
+ { skBones :: V.Vector Bone
+ , skBoneTree :: Tree Int
+ , skAnimations :: Map String Animation
+ }
+ deriving Show
+
+data PoseData = PoseData
+ { pdJointMatrix :: Proj4
+ , pdInverseBindMatrix :: Proj4
+ , pdWorldMatrix :: Proj4
+ , pdSkinningMatrix :: Proj4
+ }
+
+-- FIXME: remove Data.Vec.LinAlg.Transform3D dependency
+{-
+mat33ToMat44 (a:.b:.c:.()) = (h a):.(h b):.(h c):.(0:.0:.0:.1:.()):.()
+ where
+ h x = Vec.snoc 0 x
+
+poseData :: Skeleton -> Animation -> FloatType -> Vector PoseData
+poseData s a t = visit Nothing idPD $ skBoneTree s
+ where
+ bones = skBones s
+ idPD = V.replicate (V.length $ skBones s) $ PoseData idMat idMat idMat idMat
+ idMat = Vec.identity
+ visit p v (Node i []) = f p i v
+ visit p v (Node i l) = foldl' (visit $ Just i) (f p i v) l
+ f p i v = v // [(i,PoseData jm ibm wm sm)]
+ where
+ b = bones V.! i
+ rot = mat33ToMat44 $ quatToMat $ bnRotation b
+ trans = translation $ bnPosition b
+ jm = rot `multmm` trans
+ ibm = invertMat44 jm
+ wm = pwm `multmm` jm
+ sm = idMat
+ pwm = maybe idMat (\n -> pdWorldMatrix $ v V.! n) p
+
+-}
diff --git a/Graphics/LambdaCube/Technique.hs b/Graphics/LambdaCube/Technique.hs
--- a/Graphics/LambdaCube/Technique.hs
+++ b/Graphics/LambdaCube/Technique.hs
@@ -1,26 +1,21 @@
module Graphics.LambdaCube.Technique where
-import Graphics.LambdaCube.RenderSystemCapabilities
+import Graphics.LambdaCube.GpuProgram
import Graphics.LambdaCube.Pass
+import Graphics.LambdaCube.RenderSystemCapabilities
import Graphics.LambdaCube.Texture
-import Graphics.LambdaCube.GpuProgram
--- | illumination pass state type
data IlluminationPassesState
= IPS_COMPILE_DISABLED
| IPS_NOT_COMPILED
| IPS_COMPILED
deriving Eq
-{-| Directive used to manually control technique support based on the
- inclusion or exclusion of some factor.
--}
data IncludeOrExclude
= INCLUDE -- ^ Inclusive - only support if present
| EXCLUDE -- ^ Exclusive - do not support if present
deriving Eq
--- | Rule controlling whether technique is deemed supported based on GPU vendor
data GPUVendorRule
= GPUVendorRule
{ gvrVendor :: GPUVendor
@@ -28,7 +23,6 @@
}
deriving Eq
--- | Rule controlling whether technique is deemed supported based on GPU device name
data GPUDeviceNameRule
= GPUDeviceNameRule
{ gdrDevicePattern :: String
@@ -37,48 +31,12 @@
}
deriving Eq
-{-| Class representing an approach to rendering this particular Material.
-@remarks
- Ogre will attempt to use the best technique supported by the active hardware,
- unless you specifically request a lower detail technique (say for distant
- rendering).
--}
data (Texture t, LinkedGpuProgram lp) => Technique t lp
= Technique
{ tchPasses :: [Pass t lp] -- ^ List of primary passes
--- , tchIlluminationPasses :: [IlluminationPass] -- ^ List of derived passes, categorised into IlluminationStage (ordered)
-
--- , tchIsSupported :: Bool
--- IlluminationPassesState mIlluminationPassesCompilationPhase;
, tchLodIndex :: Int -- ^ LOD level
- {-| Scheme index, derived from scheme name but the names are held on
- MaterialManager, for speed an index is used here.
- -}
- , tchSchemeIndex :: Int
+ , tchSchemeIndex :: Int -- ^ Scheme index, derived from scheme name but the names are held on MaterialManager, for speed an index is used here.
, tchName :: String -- ^ optional name for the technique
-
- {-| When casting shadow, if not using default Ogre shadow casting material, or
- nor using fixed function casting, mShadowCasterMaterial let you customize per material
- shadow caster behavior
- -}
--- , tchShadowCasterMaterial :: Material
- {-| When casting shadow, if not using default Ogre shadow casting material, or
- nor using fixed function casting, mShadowCasterMaterial let you customize per material
- shadow caster behavior.There only material name is stored so that it can be loaded once all file parsed in a resource group.
- -}
--- , tchShadowCasterMaterialName :: String
- {-| When receiving shadow, if not using default Ogre shadow receiving material, or
- nor using fixed function texture projection receiving, mShadowReceiverMaterial let you customize per material
- shadow caster behavior
- -}
--- , tchShadowReceiverMaterial :: Material
- {-| When receiving shadow, if not using default Ogre shadow receiving material, or
- nor using fixed function texture projection receiving, mShadowReceiverMaterial let you customize per material
- shadow caster behavior. There only material name is stored so that it can be loaded once all file parsed in a resource group.
- -}
--- , tchShadowReceiverMaterialName :: String
-
, tchGPUVendorRules :: [GPUVendorRule]
, tchGPUDeviceNameRules :: [GPUDeviceNameRule]
}
-
diff --git a/Graphics/LambdaCube/Texture.hs b/Graphics/LambdaCube/Texture.hs
--- a/Graphics/LambdaCube/Texture.hs
+++ b/Graphics/LambdaCube/Texture.hs
@@ -1,54 +1,29 @@
module Graphics.LambdaCube.Texture where
-import Graphics.LambdaCube.Types
-import Graphics.LambdaCube.PixelFormat
import Graphics.LambdaCube.HardwareBuffer
-
+import Graphics.LambdaCube.PixelFormat
+import Graphics.LambdaCube.Types
--- | Enum identifying the texture usage
data TextureUsage
= TextureUsage
{ tuUsage :: Usage
, tuAutoMipmap :: Bool -- ^ mipmaps will be automatically generated for this texture
- , tuRenderTarget :: Bool -- ^ this texture will be a render target, i.e. used as a target for render to texture
- -- setting this flag will ignore all other texture usages except TU_AUTOMIPMAP
+ , tuRenderTarget :: Bool -- ^ this texture will be a render target, i.e. used as a target for render to texture setting this flag will ignore all other texture usages except TU_AUTOMIPMAP
}
- deriving Eq
-{-
-enum TextureUsage
-{
- /// @copydoc HardwareBuffer::Usage
- TU_STATIC = HardwareBuffer::HBU_STATIC,
- TU_DYNAMIC = HardwareBuffer::HBU_DYNAMIC,
- TU_WRITE_ONLY = HardwareBuffer::HBU_WRITE_ONLY,
- TU_STATIC_WRITE_ONLY = HardwareBuffer::HBU_STATIC_WRITE_ONLY,
- TU_DYNAMIC_WRITE_ONLY = HardwareBuffer::HBU_DYNAMIC_WRITE_ONLY,
- TU_DYNAMIC_WRITE_ONLY_DISCARDABLE = HardwareBuffer::HBU_DYNAMIC_WRITE_ONLY_DISCARDABLE,
- /// mipmaps will be automatically generated for this texture
- TU_AUTOMIPMAP = 0x100,
- /// this texture will be a render target, i.e. used as a target for render to texture
- /// setting this flag will ignore all other texture usages except TU_AUTOMIPMAP
- TU_RENDERTARGET = 0x200,
- /// default to automatic mipmap generation static textures
- TU_DEFAULT = TU_AUTOMIPMAP | TU_STATIC_WRITE_ONLY
-
-};
--}
+ deriving (Eq,Ord)
--- | Enum identifying the texture type
data TextureType
= TEX_TYPE_1D -- ^ 1D texture, used in combination with 1D texture coordinates
| TEX_TYPE_2D -- ^ 2D texture, used in combination with 2D texture coordinates (default)
| TEX_TYPE_3D -- ^ 3D volume texture, used in combination with 3D texture coordinates
| TEX_TYPE_CUBE_MAP -- ^ 3D cube map, used in combination with 3D texture coordinates
- deriving (Eq,Show)
+ deriving (Eq,Ord,Show)
--- | Enum identifying special mipmap numbers
data TextureMipmap
= MIP_UNLIMITED -- ^ Generate mipmaps up to 1x1
| MIP_DEFAULT -- ^ Use TextureManager default
| MIP_NUMBER Int
- deriving Eq
+ deriving (Eq,Ord)
class (Eq a, HardwareBuffer a) => Texture a where
txName :: a -> String
@@ -65,10 +40,9 @@
txTextureType :: a -> TextureType
txFormat :: a -> PixelFormat
- --txUsage :: a -> TextureUsage
- txAutoMipmap :: a -> Bool -- ^ mipmaps will be automatically generated for this texture
- txRenderTarget :: a -> Bool -- ^ this texture will be a render target, i.e. used as a target for render to texture
- -- setting this flag will ignore all other texture usages except TU_AUTOMIPMAP
+-- txUsage :: a -> TextureUsage
+-- txAutoMipmap :: a -> Bool -- ^ mipmaps will be automatically generated for this texture
+-- txRenderTarget :: a -> Bool -- ^ this texture will be a render target, i.e. used as a target for render to texture setting this flag will ignore all other texture usages except TU_AUTOMIPMAP
txSrcFormat :: a -> PixelFormat
txSrcWidth :: a -> Int
diff --git a/Graphics/LambdaCube/TextureUnitState.hs b/Graphics/LambdaCube/TextureUnitState.hs
--- a/Graphics/LambdaCube/TextureUnitState.hs
+++ b/Graphics/LambdaCube/TextureUnitState.hs
@@ -1,17 +1,11 @@
module Graphics.LambdaCube.TextureUnitState where
-import Graphics.LambdaCube.Types
-import Graphics.LambdaCube.Common
import Graphics.LambdaCube.BlendMode
+import Graphics.LambdaCube.Common
import Graphics.LambdaCube.PixelFormat
import Graphics.LambdaCube.Texture
-
+import Graphics.LambdaCube.Types
-{-| Definition of the broad types of texture effect you can apply to a texture unit.
-@note
- Note that these have no effect when using the programmable pipeline, since their
- effect is overridden by the vertex / fragment programs.
--}
data TextureEffectType
= ET_ENVIRONMENT_MAP -- ^ Generate all texture coords based on angle between camera and vertex
| ET_PROJECTIVE_TEXTURE -- ^ Generate texture coords based on a frustum
@@ -20,24 +14,14 @@
| ET_VSCROLL -- ^ Constant u/v scrolling effect
| ET_ROTATE -- ^ Constant rotation
| ET_TRANSFORM -- ^ More complex transform
- deriving Eq
+ deriving (Eq,Ord)
-{-| Enumeration to specify type of envmap.
-@note
- Note that these have no effect when using the programmable pipeline, since their
- effect is overridden by the vertex / fragment programs.
--}
data EnvMapType
= ENV_PLANAR -- ^ Envmap based on vector from camera to vertex position, good for planar geometry
| ENV_CURVED -- ^ Envmap based on dot of vector from camera to vertex and vertex normal, good for curves
| ENV_REFLECTION -- ^ Envmap intended to supply reflection vectors for cube mapping
| ENV_NORMAL -- ^ Envmap intended to supply normal vectors for cube mapping
-
-{-| Useful enumeration when dealing with procedural transforms.
-@note
- Note that these have no effect when using the programmable pipeline, since their
- effect is overridden by the vertex / fragment programs.
--}
+
data TextureTransformType
= TT_TRANSLATE_U
| TT_TRANSLATE_V
@@ -45,28 +29,21 @@
| TT_SCALE_V
| TT_ROTATE
-{-| Texture addressing modes - default is TAM_WRAP.
-@note
- These settings are relevant in both the fixed-function and the
- programmable pipeline.
--}
data TextureAddressingMode
= TAM_WRAP -- ^ Texture wraps at values over 1.0
| TAM_MIRROR -- ^ Texture mirrors (flips) at joins over 1.0
| TAM_CLAMP -- ^ Texture clamps at 1.0
| TAM_BORDER -- ^ Texture coordinates outside the range [0.0, 1.0] are set to the border colour
- deriving Eq
+ deriving (Eq,Ord)
--- | Texture addressing mode for each texture coordinate.
-data UVWAddressingMode
+data UVWAddressingMode
= UVWAddressingMode
{ amU :: TextureAddressingMode
, amV :: TextureAddressingMode
, amW :: TextureAddressingMode
}
- deriving Eq
+ deriving (Eq,Ord)
--- | Enum identifying the frame indexes for faces of a cube map (not the composite 3D type.
data TextureCubeFace
= CUBE_FRONT
| CUBE_BACK
@@ -86,14 +63,14 @@
| ET_TRANSFORM -- ^ More complex transform
xform info:
- - anim type (scroll,rotate,scale)
+ - anim type (scroll,rotate,scale)
- wave type (sine,triangle,square,sawtooth,inversesawtooth)
- base
- frequency
- phase
- amplitude
-}
--- | Internal structure defining a texture effect.
+
data TextureEffect
= TextureEffect
{ teType :: TextureEffectType
@@ -106,43 +83,24 @@
, tePhase :: FloatType
, teAmplitude :: FloatType
}
- deriving Eq
+ deriving (Eq,Ord)
--- | The type of unit to bind the texture settings to.
data BindingType
= BT_FRAGMENT -- ^ Regular fragment processing unit - the default.
- | BT_VERTEX -- ^ Vertex processing unit - indicates this unit will be used for
+ | BT_VERTEX -- ^ Vertex processing unit - indicates this unit will be used for
-- a vertex texture fetch.
- deriving Eq
-
--- | Enum identifying the type of content this texture unit contains.
+ deriving (Eq,Ord)
+
data ContentType
= CONTENT_NAMED -- ^ Normal texture identified by name
| CONTENT_SHADOW -- ^ A shadow texture, automatically bound by engine
- deriving Eq
-
--------------------------------------------------
+ deriving (Eq,Ord)
-{-| Class representing the state of a single texture unit during a Pass of a
- Technique, of a Material.
-@remarks
- Texture units are pipelines for retrieving texture data for rendering onto
- your objects in the world. Using them is common to both the fixed-function and
- the programmable (vertex and fragment program) pipeline, but some of the
- settings will only have an effect in the fixed-function pipeline (for example,
- setting a texture rotation will have no effect if you use the programmable
- pipeline, because this is overridden by the fragment program). The effect
- of each setting as regards the 2 pipelines is commented in each setting.
-@par
- When I use the term 'fixed-function pipeline' I mean traditional rendering
- where you do not use vertex or fragment programs (shaders). Programmable
- pipeline means that for this pass you are using vertex or fragment programs.
--}
data Texture t => TextureUnitState t
= TextureUnitState
{ tusAnimDuration :: Maybe FloatType -- ^ Duration of animation in seconds
, tusCubic :: Bool -- ^ is this a series of 6 2D textures to make up a cube?
-
+
, tusTextureType :: TextureType
, tusDesiredFormat :: PixelFormat
, tusTextureSrcMipmaps :: TextureMipmap -- ^ Request number of mipmaps
@@ -156,18 +114,15 @@
, tusColourBlendFallbackDest :: SceneBlendFactor
, tusAlphaBlendMode :: LayerBlendModeEx
--- mutable bool mTextureLoadFailed;
--- , tusTextureLoadFailed :: Bool
+
, tusIsAlpha :: Bool
, tusHwGamma :: Bool
--- mutable bool mRecalcTexMatrix;
, tusUMod :: FloatType
, tusVMod :: FloatType
, tusUScale :: FloatType
, tusVScale :: FloatType
, tusRotate :: FloatType
--- mutable Matrix4 mTexModMatrix;
, tusMinFilter :: FilterOptions -- ^ Texture filtering - minification
, tusMagFilter :: FilterOptions -- ^ Texture filtering - magnification
@@ -176,8 +131,6 @@
, tusMaxAniso :: Int -- ^ Texture anisotropy
, tusMipmapBias :: FloatType -- ^ Mipmap bias
--- bool mIsDefaultAniso;
--- bool mIsDefaultFiltering;
, tusBindingType :: BindingType -- ^ Binding type (fragment or vertex pipeline)
, tusContentType :: ContentType -- ^ Content type of texture (normal loaded texture, auto-texture)
@@ -186,10 +139,5 @@
, tusName :: String -- ^ optional name for the TUS
, tusTextureAlias :: String -- ^ optional alias for texture frames
, tusEffects :: [TextureEffect]
---------------------------------------
-
- -- typedef multimap::type EffectMap;
- -- EffectMap mEffects;
}
- deriving Eq
-
+ deriving (Eq,Ord)
diff --git a/Graphics/LambdaCube/Tree.hs b/Graphics/LambdaCube/Tree.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/LambdaCube/Tree.hs
@@ -0,0 +1,80 @@
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+
+module Graphics.LambdaCube.Tree where
+
+import Data.ByteString.Char8 (ByteString)
+import Data.Trie (Trie)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.Trie as T
+import qualified Data.Trie.Convenience as T
+
+-- Contains full paths mapped to data and node names mapped to full
+-- paths, where the path separator is NUL.
+data IndexedTree a = IT String (Trie a) (Trie ByteString) deriving Show
+
+separator :: ByteString
+separator = B.pack "\0"
+
+sep :: Char
+sep = B.head separator
+
+root :: String -> a -> IndexedTree a
+root name dat = IT "\1" (T.singleton nn dat) (T.singleton n nn)
+ where
+ n = B.pack name
+ nn = B.pack "\1"
+
+-- Returns Nothing if parent is not found. Ignores parent if the node
+-- already exists, and only replaces the data.
+addNode :: String -> String -> a -> IndexedTree a -> Maybe (IndexedTree a)
+addNode parent name dat it@(IT nn dm nm) = case T.member n nm of
+ True -> Just (updateNode (const dat) name it)
+ False -> fmap add (T.lookup p nm)
+ where
+ p = B.pack parent
+ n = B.pack name
+ nn' = nextName nn
+ add path = IT nn' (T.insert path' dat dm) (T.insert n path' nm)
+ where
+ path' = B.intercalate separator [path, B.pack nn']
+
+-- Deletes node with its whole subtree.
+deleteNode :: String -> IndexedTree a -> IndexedTree a
+deleteNode name it@(IT nn dm nm) = case T.lookup n nm of
+ Nothing -> it
+ Just path -> IT nn dm' nm'
+ where
+ subkeys = T.keys (T.submap path dm)
+ subnames = map (snd . B.breakEnd (==sep)) subkeys
+ dm' = T.disunion dm (T.fromListS (map (\k -> (k,undefined)) subkeys))
+ nm' = T.disunion nm (T.fromListS (map (\k -> (k,B.pack "")) subnames))
+ where
+ n = B.pack name
+
+updateNode :: (a -> a) -> String -> IndexedTree a -> IndexedTree a
+updateNode f name it@(IT nn dm nm) = case T.lookup n nm of
+ Nothing -> it
+ Just path -> IT nn (T.adjust f path dm) nm
+ where
+ n = B.pack name
+
+getDataAt :: String -> IndexedTree a -> Maybe a
+getDataAt name (IT _ dm nm) = flip T.lookup dm =<< T.lookup n nm
+ where
+ n = B.pack name
+
+flattenTree :: (a -> b -> a) -> (a -> b -> r) -> a -> IndexedTree b -> [r]
+flattenTree f g acc (IT _ dm _) = go (T.toList dm) [] [acc]
+ where
+ go [] _ _ = []
+ go ((path,dat):pds') [] as@(acc:_) = g acc dat : go pds' [path] (f acc dat:as)
+ go pds@((path,dat):pds') ps@(p:ps') as@(acc:as')
+ | prefix = g acc dat : go pds' (path:ps) (f acc dat:as)
+ | otherwise = go pds ps' as'
+ where
+ prefix = (p `B.isPrefixOf` path) && (B.index path (B.length p) == sep)
+
+nextName :: String -> String
+nextName "" = "\1"
+nextName ('\255':s) = '\1' : nextName s
+nextName (c:s) = succ c : s
diff --git a/Graphics/LambdaCube/Types.hs b/Graphics/LambdaCube/Types.hs
--- a/Graphics/LambdaCube/Types.hs
+++ b/Graphics/LambdaCube/Types.hs
@@ -1,22 +1,23 @@
-module Graphics.LambdaCube.Types where
+module Graphics.LambdaCube.Types (
+ FloatType, FloatType2, FloatType3, FloatType4,
+ RGB, ColourValue,
+ -- * Reexports
+ module Data.Vect.Float,
+ module Data.Vect.Float.Instances,
+ module Data.Vect.Float.Util.Quaternion
+) where
-import Foreign.C.Types
+import Data.Vect.Float
+import Data.Vect.Float.Instances
+import Data.Vect.Float.Util.Quaternion
+-- | The floating point type used throughout the engine. It is
+-- recommended to use this synonym ubiquitously in code interfacing
+-- with LambdaCube.
type FloatType = Float
--type FloatType = CFloat
--type FloatType = Double
--type FloatType = CDouble
-
-data Matrix4 = Matrix4
- !FloatType !FloatType !FloatType !FloatType
- !FloatType !FloatType !FloatType !FloatType
- !FloatType !FloatType !FloatType !FloatType
- !FloatType !FloatType !FloatType !FloatType
- deriving (Read, Show, Eq)
-
-data Vec4 = Vec4 !FloatType !FloatType !FloatType !FloatType
- deriving (Read, Show, Eq)
-
type FloatType2 = (FloatType,FloatType)
type FloatType3 = (FloatType,FloatType,FloatType)
diff --git a/Graphics/LambdaCube/Utility.hs b/Graphics/LambdaCube/Utility.hs
--- a/Graphics/LambdaCube/Utility.hs
+++ b/Graphics/LambdaCube/Utility.hs
@@ -1,7 +1,14 @@
module Graphics.LambdaCube.Utility where
-import Data.List
+import Data.List hiding (transpose)
+import Graphics.LambdaCube.Types
+
+groupSetBy :: (a -> a -> Ordering) -> [a] -> [[a]]
+groupSetBy f = groupBy (\x y -> f x y == EQ) . sortBy f
+
+{-
+groupSetBy :: (a -> a -> Bool) -> [a] -> [[a]]
groupSetBy f l = foldl' g [] l
where
g el e = case partition ((f e) . head) el of
@@ -9,3 +16,41 @@
; ([gl],el') -> (e:gl):el'
; _ -> error "Invalid case!"
}
+-}
+
+-- | Perspective transformation matrix.
+perspective :: FloatType -- ^ Near plane clipping distance (always positive).
+ -> FloatType -- ^ Far plane clipping distance (always positive).
+ -> FloatType -- ^ Field of view of the y axis, in radians.
+ -> FloatType -- ^ Aspect ratio, i.e. screen's width\/height.
+ -> Mat4
+perspective n f fovy aspect = transpose $
+ Mat4 (Vec4 (2*n/(r-l)) 0 (-(r+l)/(r-l)) 0)
+ (Vec4 0 (2*n/(t-b)) ((t+b)/(t-b)) 0)
+ (Vec4 0 0 (-(f+n)/(f-n)) (-2*f*n/(f-n)))
+ (Vec4 0 0 (-1) 0)
+ where
+ t = n*tan(fovy/2)
+ b = -t
+ r = aspect*t
+ l = -r
+
+-- | Pure orientation matrix defined by Euler angles.
+rotationEuler :: Vec3 -> Proj4
+rotationEuler (Vec3 a b c) = orthogonal $ toOrthoUnsafe $ rotMatrixY a .*. rotMatrixX b .*. rotMatrixZ c
+
+-- | Camera transformation matrix.
+lookat :: Vec3 -- ^ Camera position.
+ -> Vec3 -- ^ Target position.
+ -> Vec3 -- ^ Upward direction.
+ -> Proj4
+lookat pos target up = translateBefore4 (neg pos) (orthogonal $ toOrthoUnsafe r)
+ where
+ w = normalize $ pos &- target
+ u = normalize $ up &^ w
+ v = w &^ u
+ r = transpose $ Mat3 u v w
+
+foldM' :: Monad m => (a -> b -> m a) -> a -> [b] -> m a
+foldM' _ a [] = return a
+foldM' f a (x:xs) = f a x >>= \fax -> fax `seq` foldM' f fax xs
diff --git a/Graphics/LambdaCube/VertexBufferVector.hs b/Graphics/LambdaCube/VertexBufferVector.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/LambdaCube/VertexBufferVector.hs
@@ -0,0 +1,253 @@
+module Graphics.LambdaCube.VertexBufferVector where
+
+import Control.Applicative
+import Control.Monad
+import Data.List (foldl')
+import Data.Vector (Vector)
+import Data.Word
+import Foreign.Marshal.Array
+import Foreign.Ptr
+import Foreign.Storable
+import Graphics.LambdaCube.HardwareBuffer
+import Graphics.LambdaCube.HardwareIndexBuffer
+import Graphics.LambdaCube.HardwareVertexBuffer
+import Graphics.LambdaCube.Mesh
+import Graphics.LambdaCube.RenderOperation
+import Graphics.LambdaCube.RenderSystem
+import Graphics.LambdaCube.Types hiding (Vector)
+import Graphics.LambdaCube.VertexIndexData
+import qualified Data.IntMap as IntMap
+import qualified Data.Map as Map
+import qualified Data.Vector as V
+import qualified Data.Vector.Mutable as MV
+
+-- TODO: fix diffuse and specular types
+
+-- | The types of 'VectorVertexData' without the data.
+data VectorVertexType
+ = VVT_POSITION
+ | VVT_BLEND_WEIGHTS
+ | VVT_BLEND_INDICES
+ | VVT_NORMAL
+ | VVT_DIFFUSE
+ | VVT_SPECULAR
+ | VVT_TEXTURE_COORDINATES1
+ | VVT_TEXTURE_COORDINATES2
+ | VVT_TEXTURE_COORDINATES3
+ | VVT_BINORMAL
+ | VVT_TANGENT
+ deriving (Eq,Ord,Show)
+
+-- | Primitive buffer data
+data VectorVertexData
+ = VVD_POSITION (Vector Vec3)
+ | VVD_BLEND_WEIGHTS (Vector FloatType)
+ | VVD_BLEND_INDICES (Vector Int)
+ | VVD_NORMAL (Vector Vec3)
+ | VVD_DIFFUSE (Vector Vec4)
+ | VVD_SPECULAR (Vector Vec4)
+ | VVD_TEXTURE_COORDINATES1 (Vector FloatType)
+ | VVD_TEXTURE_COORDINATES2 (Vector Vec2)
+ | VVD_TEXTURE_COORDINATES3 (Vector Vec3)
+ | VVD_BINORMAL (Vector Vec3)
+ | VVD_TANGENT (Vector Vec3)
+ deriving (Show)
+
+type VVB = Vector VectorVertexData
+type VIB = Vector Int
+
+-- | Multimaterial geometry, including a default geometry for
+-- submeshes that don't provide their own.
+data VMesh
+ = VMesh
+ { vmSubMeshList :: [VSubMesh] -- ^ The collection of single-material submeshes making up the mesh.
+ , vmSharedVertexData :: Maybe VVB -- ^ Default geometry for submeshes.
+ }
+
+-- | Geometry with associated material.
+data VSubMesh
+ = VSubMesh
+ { vsmMaterialName :: String -- ^ The material associated with the submesh.
+ , vsmOperationType :: OperationType -- ^ The type of primitives making up the geometry.
+ , vsmVertexData :: Maybe VVB -- ^ Optional vertex buffer (supplied by the containing mesh if absent).
+ , vsmIndexData :: Maybe VIB -- ^ Optional index buffer.
+ }
+
+-- | Extract the type of the vertex data.
+vectorVertexType :: VectorVertexData -> VectorVertexType
+vectorVertexType v = case v of
+ VVD_POSITION _ -> VVT_POSITION
+ VVD_BLEND_WEIGHTS _ -> VVT_BLEND_WEIGHTS
+ VVD_BLEND_INDICES _ -> VVT_BLEND_INDICES
+ VVD_NORMAL _ -> VVT_NORMAL
+ VVD_DIFFUSE _ -> VVT_DIFFUSE
+ VVD_SPECULAR _ -> VVT_SPECULAR
+ VVD_TEXTURE_COORDINATES1 _ -> VVT_TEXTURE_COORDINATES1
+ VVD_TEXTURE_COORDINATES2 _ -> VVT_TEXTURE_COORDINATES2
+ VVD_TEXTURE_COORDINATES3 _ -> VVT_TEXTURE_COORDINATES3
+ VVD_BINORMAL _ -> VVT_BINORMAL
+ VVD_TANGENT _ -> VVT_TANGENT
+
+{-
+ TODO:
+ - implement interleaved to non-interleaved vertex buffer conversion function
+ - implement much faster VectorVertexData conversion via storable vector interface
+-}
+toVectorIndexData :: HardwareIndexBuffer ib => IndexData ib -> IO VIB
+toVectorIndexData idata = do
+ let ib = idIndexBuffer idata
+ n = idIndexCount idata
+ isize = getIndexSize ib
+ buf <- lock ib (idIndexStart idata * isize) (n * isize) HBL_READ_ONLY
+ v <- MV.new n
+ case getIndexType ib of
+ IT_16BIT -> forM [0..n-1] $ \i -> do
+ a <- peek $ plusPtr buf $ i*isize :: IO Word16
+ MV.write v i $ fromIntegral a
+ IT_32BIT -> forM [0..n-1] $ \i -> do
+ a <- peek $ plusPtr buf $ i*isize :: IO Word32
+ MV.write v i $ fromIntegral a
+ unlock ib
+ V.freeze v
+
+fromVectorIndexData :: (RenderSystem rs vb ib q t p lp) => rs -> VIB -> IO (IndexData ib)
+fromVectorIndexData rs vib = do
+ let indexCount = V.length vib
+ usage = HBU_STATIC -- TODO
+ -- create IndexData
+ ib <- createIndexBuffer rs IT_32BIT indexCount usage True
+ -- 1. lock buffer
+ ptr <- lock ib 0 (getSizeInBytes ib) HBL_NORMAL
+ -- 2. fill buffer
+ pokeArray (castPtr ptr) $ map (fromIntegral :: Int -> Word32) $ V.toList vib
+ -- 3. unlock buffer
+ unlock ib
+ return $ IndexData
+ { idIndexBuffer = ib
+ , idIndexStart = 0
+ , idIndexCount = indexCount
+ }
+
+toVectorVertexData :: HardwareVertexBuffer vb => VertexData vb -> IO (Vector VectorVertexData)
+toVectorVertexData vd = do
+ let n = vdVertexCount vd
+ vl = vdElementList $ vdVertexDeclaration vd
+ vbmap = vbbBindingMap $ vdVertexBufferBinding vd
+ g ve f = do
+ let vb = vbmap IntMap.! (veSource ve)
+ vsize = getVertexSize vb
+ buf <- lock vb 0 (getSizeInBytes vb) HBL_READ_ONLY
+ let p0 = plusPtr buf $ veOffset ve
+ v <- MV.new n
+ forM [0..n-1] $ \i -> do
+ a <- peek $ plusPtr p0 $ i*vsize
+ MV.write v i $ f a
+ unlock vb
+ V.freeze v
+ gv ve = g ve id
+ gs ve = g ve id
+ createVDVector ve = case (veSemantic ve, veType ve) of
+ (VES_POSITION,VET_FLOAT3) -> VVD_POSITION <$> gv ve
+ (VES_BLEND_WEIGHTS,VET_FLOAT1) -> VVD_BLEND_WEIGHTS <$> gs ve
+ (VES_BLEND_INDICES,VET_SHORT1) -> VVD_BLEND_INDICES <$> gs ve
+ (VES_NORMAL,VET_FLOAT3) -> VVD_NORMAL <$> gv ve
+ (VES_DIFFUSE,VET_COLOUR_ABGR) -> VVD_DIFFUSE <$> gv ve
+ (VES_SPECULAR,VET_COLOUR_ABGR) -> VVD_SPECULAR <$> gv ve
+ (VES_TEXTURE_COORDINATES,VET_FLOAT1) -> VVD_TEXTURE_COORDINATES1 <$> gs ve
+ (VES_TEXTURE_COORDINATES,VET_FLOAT2) -> VVD_TEXTURE_COORDINATES2 <$> gv ve
+ (VES_TEXTURE_COORDINATES,VET_FLOAT3) -> VVD_TEXTURE_COORDINATES3 <$> gv ve
+ (VES_BINORMAL,VET_FLOAT3) -> VVD_BINORMAL <$> gv ve
+ (VES_TANGENT,VET_FLOAT3) -> VVD_TANGENT <$> gv ve
+ _ -> error "Not supported vertex buffer format"
+ l <- mapM createVDVector vl
+ return $ V.fromList l
+
+fromVectorVertexData :: (RenderSystem rs vb ib q t p lp) => rs -> Vector VectorVertexData -> IO (VertexData vb)
+fromVectorVertexData rs vd = do
+ let -- aggregated type: offset, veIndex Map, [VertexElement], vertex count
+ (size,_,elems,vcount) = foldl' f (0,Map.empty,[],0) $ V.toList vd
+ f (o,m,ex,_) ve = (o + getTypeSize vt, Map.insert vs (i+1) m,(vf,VertexElement 0 o vt vs i):ex,vc)
+ where
+ i = (Map.findWithDefault 0 vs m)
+ (vs,vt,vf,vc) = cf ve
+ g a ptr vsize = V.foldM' (\p ed -> do poke (castPtr p) ed; return $ plusPtr p vsize) (plusPtr ptr o) a
+ g' a ptr vsize = V.foldM' (\p ed -> do poke (castPtr p) ed; return $ plusPtr p vsize) (plusPtr ptr o) a
+ cf t = case t of
+ VVD_POSITION a -> (VES_POSITION,VET_FLOAT3,g a,V.length a)
+ VVD_BLEND_WEIGHTS a -> (VES_BLEND_WEIGHTS,VET_FLOAT1,g' a,V.length a)
+ VVD_BLEND_INDICES a -> (VES_BLEND_INDICES,VET_SHORT1,g' a,V.length a)
+ VVD_NORMAL a -> (VES_NORMAL,VET_FLOAT3,g a,V.length a)
+ VVD_DIFFUSE a -> (VES_DIFFUSE,VET_COLOUR_ABGR,g a,V.length a)
+ VVD_SPECULAR a -> (VES_SPECULAR,VET_COLOUR_ABGR,g a,V.length a)
+ VVD_TEXTURE_COORDINATES1 a -> (VES_TEXTURE_COORDINATES,VET_FLOAT1,g' a,V.length a)
+ VVD_TEXTURE_COORDINATES2 a -> (VES_TEXTURE_COORDINATES,VET_FLOAT2,g a,V.length a)
+ VVD_TEXTURE_COORDINATES3 a -> (VES_TEXTURE_COORDINATES,VET_FLOAT3,g a,V.length a)
+ VVD_BINORMAL a -> (VES_BINORMAL,VET_FLOAT3,g a,V.length a)
+ VVD_TANGENT a -> (VES_TANGENT,VET_FLOAT3,g a,V.length a)
+ -- create VertexDeclaration
+ decl = VertexDeclaration $ map snd elems
+ -- create VertexBufferBinding
+ usage = HBU_STATIC -- TODO
+
+ --debugM "fromVectorVertexData" $ "gemetry declaration: " ++ show decl
+
+ bufs <- mapM (\s -> createVertexBuffer rs s vcount usage True) [size]
+ let binding = VertexBufferBinding $ IntMap.fromList $ zip [0..] bufs
+ fillBuffer (d,b) = do
+ -- 1. lock buffer
+ ptr <- lock b 0 (getSizeInBytes b) HBL_NORMAL
+ let vsize = getVertexSize b
+ fillAttribute (vf,_) = vf ptr vsize
+ -- 2. fill vertex attributes according declaration
+ mapM_ fillAttribute d
+ -- 3. unlock buffer
+ unlock b
+ -- end fillBuffer
+
+ -- fill buffers with data
+ mapM_ fillBuffer $ zip [elems] bufs
+
+ -- create VertexData
+ return $ VertexData decl binding 0 vcount
+
+-- utility functions
+meshFromV :: (RenderSystem rs vb ib q t p lp) => rs -> VMesh -> IO (Mesh vb ib)
+meshFromV rs vmesh = do
+ let convMVVD mvvd = case mvvd of
+ Nothing -> return Nothing
+ Just vvd -> Just <$> fromVectorVertexData rs vvd
+ convMVID mvid = case mvid of
+ Nothing -> return Nothing
+ Just vid -> Just <$> fromVectorIndexData rs vid
+ sm <- forM (vmSubMeshList vmesh) $ \vsm -> do
+ vdata <- convMVVD $ vsmVertexData vsm
+ idata <- convMVID $ vsmIndexData vsm
+ return $ SubMesh
+ { smOperationType = vsmOperationType vsm
+ , smVertexData = vdata
+ , smIndexData = idata
+ , smMaterialName = vsmMaterialName vsm
+ }
+ svd <- convMVVD $ vmSharedVertexData vmesh
+ let mesh = Mesh
+ { msSubMeshList = sm
+ , msSharedVertexData = svd
+ , msBoundRadius = undefined
+ }
+ r <- calculateBoundingRadius mesh
+ return mesh { msBoundRadius = r }
+
+vFromMesh :: (HardwareVertexBuffer vb, HardwareIndexBuffer ib) => Mesh vb ib -> IO VMesh
+vFromMesh mesh = do
+ let convMVD mvd = case mvd of
+ Nothing -> return Nothing
+ Just vd -> Just <$> toVectorVertexData vd
+ convMID mid = case mid of
+ Nothing -> return Nothing
+ Just ixd -> Just <$> toVectorIndexData ixd
+ vsm <- forM (msSubMeshList mesh) $ \sm -> do
+ vdata <- convMVD $ smVertexData sm
+ idata <- convMID $ smIndexData sm
+ return $ VSubMesh (smMaterialName sm) (smOperationType sm) vdata idata
+ vsvd <- convMVD $ msSharedVertexData mesh
+ return $ VMesh vsm vsvd
diff --git a/Graphics/LambdaCube/VertexIndexData.hs b/Graphics/LambdaCube/VertexIndexData.hs
--- a/Graphics/LambdaCube/VertexIndexData.hs
+++ b/Graphics/LambdaCube/VertexIndexData.hs
@@ -1,239 +1,21 @@
module Graphics.LambdaCube.VertexIndexData where
-import Graphics.LambdaCube.HardwareVertexBuffer
import Graphics.LambdaCube.HardwareIndexBuffer
+import Graphics.LambdaCube.HardwareVertexBuffer
--- | Summary class collecting together vertex source information.
data HardwareVertexBuffer vb => VertexData vb
= VertexData
- {
- {-| Declaration of the vertex to be used in this operation.
- @remarks Note that this is created for you on construction.
- -}
- vdVertexDeclaration :: VertexDeclaration
- {-| The vertex buffer bindings to be used.
- @remarks Note that this is created for you on construction.
- -}
- , vdVertexBufferBinding :: VertexBufferBinding vb
- ---- | Whether this class should delete the declaration and binding
- --bool mDeleteDclBinding;
- -- | The base vertex index to start from
- , vdVertexStart :: Int
- -- | The number of vertices used in this operation
- , vdVertexCount :: Int
+ { vdVertexDeclaration :: VertexDeclaration -- ^ Declaration of the vertex to be used in this operation. remarks Note that this is created for you on construction.
+ , vdVertexBufferBinding :: VertexBufferBinding vb -- ^ The vertex buffer bindings to be used. remarks Note that this is created for you on construction.
+ , vdVertexStart :: Int -- ^ The base vertex index to start from
+ , vdVertexCount :: Int -- ^ The number of vertices used in this operation
}
- deriving Eq
--- | Struct used to hold hardware morph / pose vertex data information
---struct HardwareAnimationData
---{
--- const VertexElement* targetVertexElement;
--- Real parametric;
---};
---typedef vector::type HardwareAnimationDataList;
--- | VertexElements used for hardware morph / pose animation
---HardwareAnimationDataList hwAnimationDataList;
--- | Number of hardware animation data items used
---size_t hwAnimDataItemsUsed;
-
- {-| Clones this vertex data, potentially including replicating any vertex buffers.
- @param copyData Whether to create new vertex buffers too or just reference the existing ones
- @param mgr If supplied, the buffer manager through which copies should be made
- @remarks The caller is expected to delete the returned pointer when ready
- -}
--- VertexData* clone(bool copyData = true, HardwareBufferManagerBase* mgr = 0) const;
-
- {-| Modifies the vertex data to be suitable for use for rendering shadow geometry.
- @remarks
- Preparing vertex data to generate a shadow volume involves firstly ensuring that the
- vertex buffer containing the positions is a standalone vertex buffer,
- with no other components in it. This method will therefore break apart any existing
- vertex buffers if position is sharing a vertex buffer.
- Secondly, it will double the size of this vertex buffer so that there are 2 copies of
- the position data for the mesh. The first half is used for the original, and the second
- half is used for the 'extruded' version. The vertex count used to render will remain
- the same though, so as not to add any overhead to regular rendering of the object.
- Both copies of the position are required in one buffer because shadow volumes stretch
- from the original mesh to the extruded version.
- @par
- It's important to appreciate that this method can fundamentally change the structure of your
- vertex buffers, although in reality they will be new buffers. As it happens, if other
- objects are using the original buffers then they will be unaffected because the reference
- counting will keep them intact. However, if you have made any assumptions about the
- structure of the vertex data in the buffers of this object, you may have to rethink them.
- -}
--- void prepareForShadowVolume(void);
-
- {-| Additional shadow volume vertex buffer storage.
- @remarks
- This additional buffer is only used where we have prepared this VertexData for
- use in shadow volume construction, and where the current render system supports
- vertex programs. This buffer contains the 'w' vertex position component which will
- be used by that program to differentiate between extruded and non-extruded vertices.
- This 'w' component cannot be included in the original position buffer because
- DirectX does not allow 4-component positions in the fixed-function pipeline, and the original
- position buffer must still be usable for fixed-function rendering.
- @par
- Note that we don't store any vertex declaration or vertex buffer binding here because this
- can be reused in the shadow algorithm.
- -}
--- HardwareVertexBufferSharedPtr hardwareShadowVolWBuffer;
-
-
- {-| Reorganises the data in the vertex buffers according to the
- new vertex declaration passed in. Note that new vertex buffers
- are created and written to, so if the buffers being referenced
- by this vertex data object are also used by others, then the
- original buffers will not be damaged by this operation.
- Once this operation has completed, the new declaration
- passed in will overwrite the current one.
- @param newDeclaration The vertex declaration which will be used
- for the reorganised buffer state. Note that the new declaration
- must not include any elements which do not already exist in the
- current declaration; you can drop elements by
- excluding them from the declaration if you wish, however.
- @param bufferUsages Vector of usage flags which indicate the usage options
- for each new vertex buffer created. The indexes of the entries must correspond
- to the buffer binding values referenced in the declaration.
- @param mgr Optional pointer to the manager to use to create new declarations
- and buffers etc. If not supplied, the HardwareBufferManager singleton will be used
- -}
--- void reorganiseBuffers(VertexDeclaration* newDeclaration, const BufferUsageList& bufferUsage,
--- HardwareBufferManagerBase* mgr = 0);
-
- {-| Reorganises the data in the vertex buffers according to the
- new vertex declaration passed in. Note that new vertex buffers
- are created and written to, so if the buffers being referenced
- by this vertex data object are also used by others, then the
- original buffers will not be damaged by this operation.
- Once this operation has completed, the new declaration
- passed in will overwrite the current one.
- This version of the method derives the buffer usages from the existing
- buffers, by using the 'most flexible' usage from the equivalent sources.
- @param newDeclaration The vertex declaration which will be used
- for the reorganised buffer state. Note that the new delcaration
- must not include any elements which do not already exist in the
- current declaration; you can drop elements by
- excluding them from the declaration if you wish, however.
- @param mgr Optional pointer to the manager to use to create new declarations
- and buffers etc. If not supplied, the HardwareBufferManager singleton will be used
- -}
--- void reorganiseBuffers(VertexDeclaration* newDeclaration, HardwareBufferManagerBase* mgr = 0);
-
- {-| Remove any gaps in the vertex buffer bindings.
- @remarks
- This is useful if you've removed elements and buffers from this vertex
- data and want to remove any gaps in the vertex buffer bindings. This
- method is mainly useful when reorganising vertex data manually.
- @note
- This will cause binding index of the elements in the vertex declaration
- to be altered to new binding index.
- -}
--- void closeGapsInBindings(void);
-
- {-| Remove all vertex buffers that never used by the vertex declaration.
- @remarks
- This is useful if you've removed elements from the vertex declaration
- and want to unreference buffers that never used any more. This method
- is mainly useful when reorganising vertex data manually.
- @note
- This also remove any gaps in the vertex buffer bindings.
- -}
--- void removeUnusedBuffers(void);
-
- {-| Convert all packed colour values (VET_COLOUR_*) in buffers used to
- another type.
- @param srcType The source colour type to assume if the ambiguous VET_COLOUR
- is encountered.
- @param destType The destination colour type, must be VET_COLOUR_ABGR or
- VET_COLOUR_ARGB.
- -}
--- void convertPackedColour(VertexElementType srcType, VertexElementType destType);
-
-
- {-| Allocate elements to serve a holder of morph / pose target data
- for hardware morphing / pose blending.
- @remarks
- This method will allocate the given number of 3D texture coordinate
- sets for use as a morph target or target pose offset (3D position).
- These elements will be saved in hwAnimationDataList.
- It will also assume that the source of these new elements will be new
- buffers which are not bound at this time, so will start the sources to
- 1 higher than the current highest binding source. The caller is
- expected to bind these new buffers when appropriate. For morph animation
- the original position buffer will be the 'from' keyframe data, whilst
- for pose animation it will be the original vertex data.
- -}
--- void allocateHardwareAnimationElements(ushort count);
-
-
-
+ deriving (Eq,Ord)
--- | Summary class collecting together index data source information.
data HardwareIndexBuffer ib => IndexData ib
= IndexData
{ idIndexBuffer :: ib -- ^ pointer to the HardwareIndexBuffer to use, must be specified if useIndexes = true
, idIndexStart :: Int -- ^ index in the buffer to start from for this operation
, idIndexCount :: Int -- ^ The number of indexes to use from the buffer
}
- deriving Eq
-
- {-| Clones this index data, potentially including replicating the index buffer.
- @param copyData Whether to create new buffers too or just reference the existing ones
- @param mgr If supplied, the buffer manager through which copies should be made
- @remarks The caller is expected to delete the returned pointer when finished
- -}
--- IndexData* clone(bool copyData = true, HardwareBufferManagerBase* mgr = 0) const;
-
- {-| Re-order the indexes in this index data structure to be more
- vertex cache friendly; that is to re-use the same vertices as close
- together as possible.
- @remarks
- Can only be used for index data which consists of triangle lists.
- It would in fact be pointless to use it on triangle strips or fans
- in any case.
- -}
--- void optimiseVertexCacheTriList(void);
-
-
-{-| Vertex cache profiler.
-@remarks
- Utility class for evaluating the effectiveness of the use of the vertex
- cache by a given index buffer.
--}
-{-
-class _OgreExport VertexCacheProfiler : public BufferAlloc
-{
- public:
- enum CacheType {
- FIFO, LRU
- };
-
- VertexCacheProfiler(unsigned int cachesize = 16, CacheType cachetype = FIFO )
- : size ( cachesize ), type ( cachetype ), tail (0), buffersize (0), hit (0), miss (0)
- {
- cache = OGRE_ALLOC_T(uint32, size, MEMCATEGORY_GEOMETRY);
- };
-
- ~VertexCacheProfiler()
- {
- OGRE_FREE(cache, MEMCATEGORY_GEOMETRY);
- }
-
- void profile(const HardwareIndexBufferSharedPtr& indexBuffer);
- void reset() { hit = 0; miss = 0; tail = 0; buffersize = 0; };
- void flush() { tail = 0; buffersize = 0; };
-
- unsigned int getHits() { return hit; };
- unsigned int getMisses() { return miss; };
- unsigned int getSize() { return size; };
- private:
- unsigned int size;
- uint32 *cache;
- CacheType type;
-
- unsigned int tail, buffersize;
- unsigned int hit, miss;
-
- bool inCache(unsigned int index);
-};
--}
+ deriving (Eq,Ord)
diff --git a/Graphics/LambdaCube/World.hs b/Graphics/LambdaCube/World.hs
--- a/Graphics/LambdaCube/World.hs
+++ b/Graphics/LambdaCube/World.hs
@@ -1,904 +1,1020 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-module Graphics.LambdaCube.World where
-
-import Data.Maybe
-import qualified Data.List as List
-import Data.Map (Map,(!))
-import qualified Data.Map as Map
-import Data.IntMap (IntMap)
-import qualified Data.IntMap as IntMap
-import Control.Applicative
-import Control.Monad
-import System.Directory
-import System.FilePath
-
-import System.Log.Logger
-import Data.Graph.Inductive
-import qualified Data.ByteString.Lazy as B
-import qualified Data.ByteString as SB
-import qualified Data.ByteString.Internal as SB
-import Codec.Archive.Zip
-
-import Graphics.LambdaCube.Common
-import Graphics.LambdaCube.Loader.ResourceScript
-import Graphics.LambdaCube.Loader.MeshXML
-import Graphics.LambdaCube.Compositor
-import Graphics.LambdaCube.Material
-import Graphics.LambdaCube.Pass
-import Graphics.LambdaCube.Technique
-import Graphics.LambdaCube.TextureUnitState
-import Graphics.LambdaCube.PixelFormat
-import Graphics.LambdaCube.Math
-import Graphics.LambdaCube.Light
-import Graphics.LambdaCube.Image
-import Graphics.LambdaCube.Entity
-import Graphics.LambdaCube.Mesh
-import Graphics.LambdaCube.Types
-import Graphics.LambdaCube.Texture
-import Graphics.LambdaCube.GpuProgram
-import Graphics.LambdaCube.GpuProgramUsage
-import Graphics.LambdaCube.RenderQueue
-import Graphics.LambdaCube.RenderSystem
-import Graphics.LambdaCube.HardwareBuffer
-import Graphics.LambdaCube.HardwareVertexBuffer
-import Graphics.LambdaCube.HardwareIndexBuffer
---import Graphics.LambdaCube.Resource
-import Graphics.LambdaCube.RenderOperation
-
-
--- * World
-
-data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => FlattenScene vb ib t lp
- = FlattenScene
- { fsRenderable :: [(Matrix4,[RenderEntity vb ib t lp],Int,Int)] -- ^ List of Renderable information including WorldMatrix RenderQueueID and RenderPriority
- , fsCamera :: [(Matrix4,Camera)]
- , fsLight :: [(Matrix4,Light)]
- }
-
-data RenderSystem r vb ib q t p lp => World r vb ib q t p lp
- = World
- { wrResource :: ResourceLibrary vb ib t p lp -- IO related
- , wrRenderSystem :: r -- IO related
- , wrScene :: Scene vb ib t lp
- , wrTargets :: Map String (RenderTarget t lp)
- , wrRenderOptions :: IntMap RenderGroupOptions
- , wrImageLoaders :: [ImageLoader]
- }
-
-mapResource f w = w { wrResource = f (wrResource w) }
-mapScene f w = w { wrScene = f (wrScene w) }
-mapTargets f w = w { wrTargets = f (wrTargets w) }
-
-mkWorld :: RenderSystem r vb ib q t p lp => r -> [ImageLoader] -> IO (World r vb ib q t p lp)
-mkWorld rs imgLoaders = return World
- { wrResource = mkResource
- , wrRenderSystem = rs
- , wrScene = mkScene
- , wrTargets = Map.empty
- , wrRenderOptions = IntMap.empty
- , wrImageLoaders = imgLoaders
- }
-
-mkResource :: (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, GpuProgram p, LinkedGpuProgram lp) => ResourceLibrary vb ib t p lp
-mkResource = ResourceLibrary [] Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty
-
-mkScene :: (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => Scene vb ib t lp
---mkScene = Scene (mkUGraph [0] []) (IntMap.fromList [(0, SceneNode "Root" [] (transl 0 0 0))]) (Map.fromList [("Root",0)]) Nothing
--- TODO: update for new scene structure
-mkScene = Scene
- { scGraph = mkGraph [(0,"Root")] []
- -- use: bytestring-trie (efficient ByteString map)
- , scMap = Map.fromList [("Root", (0,SceneNode "Root" [] (transl 0 0 0)))]
- , scSky = Nothing
- }
-
--- * Resource
-
-data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, GpuProgram p, LinkedGpuProgram lp) => ResourceLibrary vb ib t p lp
- = ResourceLibrary
- { rlResourceGroups :: [ResourceGroup]
- , rlMeshMap :: Map String (Mesh vb ib)
- , rlMaterialMap :: Map String (Material t lp)
- , rlTextureMap :: Map String t
- , rlGpuProgramMap :: Map String (GpuProgramDescriptor p)
- , rlLinkedGpuProgramMap :: Map (String,String,String) lp
- , rlCompositorMap :: Map String (Compositor t lp)
- }
-
--- * SceneGraph
-
-data Camera
- = Camera
- { cmName :: String
- , cmFov :: FloatType
- , cmNear :: FloatType
- , cmFar :: FloatType
- , cmAspectRatio :: Maybe FloatType
- , cmPolygonMode :: PolygonMode -- ^ Rendering type
- }
-{-
- name CDATA #IMPLIED
- id ID #IMPLIED
- FOVy CDATA "45"
- aspectRatio CDATA "1.3333333"
- projectionType (perspective | orthographic) "perspective"
- polygonMode (points | wireframe | solid) "solid"
- useRenderingDistance (yes | no) "yes"
- lodBiasFactor CDATA "1.0"
--}
-cameraProjectionMatrix :: FloatType -> Camera -> Matrix4
-cameraProjectionMatrix a cam = perpectiveMatrix fov aspect near far
- where
- Camera
- { cmFov = fov
- , cmNear = near
- , cmFar = far
- , cmAspectRatio = aspectr
- } = cam
- aspect = fromMaybe a aspectr
-
-data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => SceneObject vb ib t lp
- = SO_Entity (Entity vb ib t lp)
- | SO_Camera Camera
- | SO_Light Light
--- | SO_ParticleSystem ParticleSystem
-
---data RenderTarget
--- = RT_MainBuffer
--- | RT_FrameBuffer
-
-{-
-data RenderWindow = RenderWindow
- { rwWidth :: Int
- , rwHeight :: Int
- , rwViewport :: [Viewport]
- --, rtTarget -- texture or screen
- }
--}
-
-data (Texture t, LinkedGpuProgram lp) => RenderTarget t lp
- = RenderTarget
- { rtName :: String
- , rtWidth :: Int
- , rtHeight :: Int
- , rtViewport :: [Viewport t lp]
- , rtTexture :: Maybe String
- }
-
-data (Texture t, LinkedGpuProgram lp) => Viewport t lp
- = Viewport
- { vpLeft :: FloatType
- , vpTop :: FloatType
- , vpWidth :: FloatType
- , vpHeight :: FloatType
- , vpCamera :: String --Camera
- , vpCompositors :: [Compositor t lp]
- , vpBackColour :: ColourValue
- , vpClearEveryFrame :: Bool
- , vpClearBuffers :: FrameBufferType
- }
-
---getViewportSize :: RenderTarget -> Viewport -> (Int,Int,Int,Int)
-getViewportSize t v = (x,y,w,h)
- where
- ww = fromIntegral $ rtWidth t
- wh = fromIntegral $ rtHeight t
- x = floor $ ww * (vpLeft v)
- y = floor $ wh * (vpTop v)
- w = floor $ ww * (vpWidth v)
- h = floor $ wh * (vpHeight v)
-
-data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => SceneNode vb ib t lp
- = SceneNode
- { snName :: String
- , snObject :: [SceneObject vb ib t lp]
- , snTransform :: Matrix4
- }-- deriving (Show,Read)
-
-data Sky
- = SkyBox --Material
- | SkyDome
- | SkyPlane
-
-{-
-data Scene = Scene
- { scGraph :: Gr () ()
--- , scMap :: Map Int SceneNode
- , scMap :: IntMap SceneNode
- , scNameMap :: Map String Int
- , scSky :: Maybe Sky
- -- Fog settings
- }
--}
-
-data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => Scene vb ib t lp
- = Scene
- { scGraph :: Gr String ()
- -- use: bytestring-trie (efficient ByteString map)
- , scMap :: Map String (Int,SceneNode vb ib t lp) -- ^ Contains GraphNodeID and SceneNode.
- , scSky :: Maybe Sky
- -- Fog settings
- }
-
-getMesh name world = case Map.lookup name (rlMeshMap rl) of
- Nothing -> do
- f <- loadFile (rlResourceGroups rl) name
- when (isNothing f) $ error $ "File not found: " ++ name
- m <- case takeExtension name of
- ".xml" -> do
- debugM "ResourceLibrary" $ "parsing mesh XML file " ++ name
- parseMesh rs $ map SB.w2c $ B.unpack $ fromMaybe (error "fromJust 9") f
- _ -> error ("Unsupported format!")
- return (m,world { wrResource = rl { rlMeshMap = Map.insert name m (rlMeshMap rl) } })
- Just m -> return (m,world)
- where
- rl = wrResource world
- rs = wrRenderSystem world
-
---loadMaterialResources :: ResourceLibrary -> Material -> IO (ResourceLibrary,Material)
-loadMaterialResources rs loaders reslib0 mat = case isJust $ mtSupportedTechniques mat of
- { True -> return (reslib0,mat) -- Material is already initialized
- ; False -> do
- let isSupportedTech _ = True -- TODO
- loadImage name = do
- d <- loadFile (rlResourceGroups reslib0) name
- case d of
- { Just imgdata -> do
- let loadImg img loader = case img of
- { Just _ -> return img
- ; Nothing -> loader name imgdata
- }
- foldM loadImg Nothing loaders
- ; Nothing -> do
- debugM "Load image" $ "File not found: " ++ name
- return Nothing
- }
- loadTextureUnit (rl0,tl) t = do
- let loadTexture (rl0',tl') texname = case Map.lookup texname $ rlTextureMap rl0' of
- { Just t -> return (rl0',t:tl') -- texture is loaded
- ; Nothing -> do -- we have to create it
- -- TODO: create and load texture via render system
- i <- loadImage texname
- case i of
- { Just img -> do
- {-
- virtual TexturePtr createManual(const String & name, const String& group,
- TextureType texType, uint width, uint height, uint depth,
- int num_mips, PixelFormat format, int usage = TU_DEFAULT, ManualResourceLoader* loader = 0,
- bool hwGammaCorrection = false, uint fsaa = 0, const String& fsaaHint = StringUtil::BLANK);
-
- { imName :: String
- , imHeight :: Int
- , imWidth :: Int
- , imDepth :: Int
- , imSize :: Int
- , imNumMipmaps :: Int
--- uint flags;
- , imFormat :: PixelFormat
- , imData :: (Ptr Word8) -- ^ Image can be empty
- }
- mkGLTexture :: String -> TextureType -> Int -> Int -> Int -> Int -> PixelFormat -> TextureUsage -> Bool -> Int -> String -> IO GLTexture
- mkGLTexture name texType width height depth numMips format usage hwGammaCorrection fsaa fsaaHint = do
- -}
- --createTexture :: a -> String -> TextureType -> Int -> Int -> Int -> Int -> PixelFormat -> TextueUsage -> Bool -> Int -> String -> IO t
- let usage = TextureUsage HBU_STATIC True False
- t <- createTexture rs texname (tusTextureType t) (imWidth img) (imHeight img) (imDepth img)
- (tusTextureSrcMipmaps t) (tusDesiredFormat t) usage (tusHwGamma t) 0 "" $ Just [img]
- -- TODO
- --let t = undefined
- let texmap = rlTextureMap rl0'
- return (rl0' { rlTextureMap = Map.insert texname t texmap },t:tl')
- ; Nothing -> do
- debugM "Load texture" $ "No proper image codec was found: " ++ texname
- return (rl0',tl')
- }
- }
- let loadCubicTexture rl0' texname = case Map.lookup (concat texname) $ rlTextureMap rl0' of
- { Just t -> return (rl0',[t]) -- texture is loaded
- ; Nothing -> do -- we have to create it
- -- TODO: create and load texture via render system
- i <- mapM loadImage texname
- case all isJust i of
- { True -> do
- let usage = TextureUsage HBU_STATIC True False
- img = fromJust $ head i
- t <- createTexture rs (concat texname) (tusTextureType t) (imWidth img) (imHeight img) (imDepth img)
- (tusTextureSrcMipmaps t) (tusDesiredFormat t) usage (tusHwGamma t) 0 "" $ Just $ map fromJust i
- let texmap = rlTextureMap rl0'
- return (rl0' { rlTextureMap = Map.insert (concat texname) t texmap },[t])
- ; False -> do
- debugM "Load texture" $ "No proper image codec was found: " ++ concat texname
- return (rl0',[])
- }
- }
- -- load textures
- -- TODO: load all frames
- (rl1,tex) <- case tusTextureType t of
- { TEX_TYPE_CUBE_MAP -> loadCubicTexture rl0 $ tusFrameNames t
- ; _ -> foldM loadTexture (rl0,[]) $ tusFrameNames t
- }
- let frames = reverse tex -- TODO: wrong in cubemap case
- return (rl1,(t { tusFrames = Just frames }):tl)
- loadShader (rl0,sl) sn = case Map.lookup sn $ rlGpuProgramMap rl0 of
- { Nothing -> do
- errorM "loadShader" $ "Unknown GpuProgram: " ++ sn
- return (rl0,sl)
- ; Just gpd -> case gpdGpuProgram gpd of
- { Just p -> return (rl0,p:sl)
- ; Nothing -> do
- -- GpuProgram is not loaded yet
- let fname = gpdFilename gpd
- msource <- loadFile (rlResourceGroups rl0) fname
- case msource of
- { Nothing -> do
- errorM "loadShader" $ "GpuProgram source not found: " ++ sn ++ " - " ++ fname
- return (rl0,sl)
- ; Just src -> do
- eprog <- createGpuProgram rs (gpdType gpd) $ map SB.w2c $ B.unpack src
- case eprog of
- { Right err -> do
- errorM "loadShader" $ "Error compile " ++ sn ++ ": " ++ err
- return (rl0,sl)
- ; Left prog -> do
- debugM "loadShader" $ "GpuProgram loaded: " ++ sn
- let gpd' = gpd { gpdGpuProgram = Just prog }
- gpmap = Map.insert sn gpd' $ rlGpuProgramMap rl0
- return (rl0 { rlGpuProgramMap = gpmap }, prog:sl)
- }
- }
- }
- }
- loadPass (rl0,pl) p = do
- -- load GpuPrograms
- (rl1,mlgp) <- case psLinkedGpuProgram p of
- { Just lgp -> return (rl0,Just lgp)
- ; Nothing -> do
- let getName Nothing = ""
- getName (Just u) = gpuProgramName u
- progName = (getName $ psVertexProgramUsage p, getName $ psFragmentProgramUsage p, getName $ psGeometryProgramUsage p)
- (vpn,fpn,gpn) = progName
- gpuprogmap = rlGpuProgramMap rl0
- collectNames cl [] = return cl
- collectNames cl nl = do
- -- check list nl
- let a = filter (`notElem` cl) nl
- getAttach m = case Map.lookup m gpuprogmap of
- { Nothing -> do
- errorM "loadShader" $ "Unknown attached GpuProgram: " ++ m
- return []
- ; Just gp -> return $ gpdAttach gp
- }
- b <- mapM getAttach a
- collectNames (cl ++ a) $ concat b
- -- collect required shaders name list
- progNames <- collectNames [] $ filter (/="") [vpn,fpn,gpn]
- case null progNames of
- { True -> return (rl0,Nothing)
- ; False -> do
- -- load all shader
- (rl1,progs) <- foldM loadShader (rl0,[]) progNames
- case Map.lookup progName $ rlLinkedGpuProgramMap rl1 of
- { Just lp -> return (rl1,Just lp)
- ; Nothing -> do
- -- create LinkedGpuProgram
- elprog <- createLinkedGpuProgram rs progs
- case elprog of
- { Right err -> do
- errorM "loadGpuProgram" $ "Error link " ++ (show progName) ++ ": " ++ err
- return (rl1,Nothing)
- ; Left lprog -> do
- debugM "loadGpuProgram" $ "GpuProgram linked: " ++ (show progName)
- let lprogmap = rlLinkedGpuProgramMap rl1
- lprogmap' = Map.insert progName lprog lprogmap
- return (rl1 { rlLinkedGpuProgramMap = lprogmap' },Just lprog)
- }
- }
- }
- }
- -- load textureunitstates (Texture)
- (rl2,texUnits) <- foldM loadTextureUnit (rl1,[]) $ psTextureUnitStates p
- return (rl2,(p { psTextureUnitStates = reverse texUnits, psLinkedGpuProgram = mlgp }):pl)
- loadTechnique (rl0,tl) t = do
- -- load passes (GpuProgram)
- (rl1,passes) <- foldM loadPass (rl0,[]) $ tchPasses t
- return (rl1,(t { tchPasses = reverse passes }):tl)
- -- select and load supported techniques
- (reslib1,suppTech) <- foldM loadTechnique (reslib0,[]) $ filter isSupportedTech $ mtTechniques mat
- -- Insert loaded material into MaterialMap
- let matmap = rlMaterialMap reslib1
- mat' = mat { mtSupportedTechniques = Just $ reverse suppTech }
- reslib2 = reslib1 { rlMaterialMap = Map.insert (mtName mat') mat' matmap }
- return (reslib2,mat')
- }
-
---getLoadedMaterial :: String -> World -> IO (World,Maybe Material)
---NOTE: this should return with Nothing if there's no supported technique
-getLoadedMaterial matname world0 = case Map.lookup matname $ rlMaterialMap $ wrResource world0 of
- { Nothing -> do
- errorM "loadMaterial" $ "Material not found: " ++ matname
- return (world0,Nothing)
- ; Just mat0 -> case isJust $ mtSupportedTechniques mat0 of
- { True -> return (world0,Just mat0)
- ; False -> do
- let rs = wrRenderSystem world0
- loaders = wrImageLoaders world0
- rl0 = wrResource world0
- (rl1,mat1) <- loadMaterialResources rs loaders rl0 mat0
- --TODO: this should return with Nothing if there's no supported technique
- return (world0 { wrResource = rl1 },Just mat1)
- }
- }
-
---setEntityMaterial :: World -> [String] -> Entity -> IO (World,Entity)
-setEntityMaterial world0 mats ent = do
- let reslib1 = wrResource world0
- rs = wrRenderSystem world0
- loaders = wrImageLoaders world0
- setSubEntMat (rl1,ses) (sent,matname) = do
- let matmap = (rlMaterialMap rl1)
- (rl2,mat) <- case Map.lookup matname matmap of
- { Just m -> do
- loadMaterialResources rs loaders rl1 m
- ; Nothing -> do
- error $ "Material not found: " ++ matname
- }
- return (rl2,sent { seMaterial = mat } : ses)
-
- (reslib2,subents) <- foldM setSubEntMat (reslib1,[]) $ zip (enSubEntityList ent) mats
- return (world0 { wrResource = reslib2 },ent { enSubEntityList = reverse subents })
-
---createEntity :: World -> String -> String -> IO (World,Entity)
-createEntity world0 ename mname = do
- -- lookup mesh, load if not exists
- --debugM "ResourceLibrary" $ "creating entity: \"" ++ ename ++ "\" from mesh: \"" ++ mname ++ "\""
- (mesh,world1) <- getMesh mname world0
- --debugM "ResourceLibrary" " done"
-
- let reslib1 = wrResource world1
- rs = wrRenderSystem world1
- loaders = wrImageLoaders world1
- mkSubent (rl1,ses) smesh = do
- let matname = (smMaterialName smesh)
- matmap = (rlMaterialMap rl1)
- (rl2,mat) <- case Map.lookup matname matmap of
- { Just m -> do
- loadMaterialResources rs loaders rl1 m
- ; Nothing -> do
- --debugM "createEntity" $ "Material not found: " ++ matname
- -- TODO
- error $ "Material not found: " ++ matname
- --loadMaterialResources rs loaders rl1 (matmap ! "WarningMaterial")
- }
- return (rl2,SubEntity { seMaterial = mat, seSubMesh = smesh } : ses)
-
- (reslib2,subents) <- foldM mkSubent (reslib1,[]) (msSubMeshList mesh)
-
- let ent = Entity
- { enName = ename
- , enRenderQueue = constRenderQueueMain
- , enMesh = mesh
- , enSubEntityList = reverse subents
- }
-
- return (world1 { wrResource = reslib2 },ent)
-
---loadFile :: [ResourceGroup] -> String -> Maybe ByteString
-loadFile respath fname = foldM (\s (_,l)->foldM load s l) Nothing respath
- where
- load s@(Just str) _ = return s
- load s (PathZip,n) = do
- -- TODO: this is a naive implementation with poor perfomance
- f <- B.readFile n
- let a = toArchive f
- return $ fmap fromEntry $ findEntryByPath fname a
- load Nothing (PathDir,n) = do
- let ffname = (addTrailingPathSeparator n) ++ fname
- e <- doesFileExist ffname
- ret <- if e then B.readFile ffname else return B.empty
- return $ if e then Just ret else Nothing
-
-renderWorld time name flatScene world = do
- -- TODO
- -- collect all render textures
- -- render the world on all render textures
- -- render the world last to the given named target
-
- -- forall viewports:
- -- setup viewport related matrices
- -- render scene
- case Map.lookup name targetMap of
- { Nothing -> do
- debugM "renderWold" $ "RenderTarget not found: " ++ name
- return world
- ; Just t -> do
- let targets = Map.elems targetMap
- (tg,tgs) = List.partition ((== name) . rtName) targets
- (rtl,rwl) = List.partition (isNothing . rtTexture) tgs
- mapM_ renderTarget $ rtl ++ rwl ++ tg
- return world
- }
- where
- targetMap = wrTargets world
- rs = wrRenderSystem world
-
- renderTarget rt = do
- -- TODO: calc render statistics
- let t = rtTexture rt
- -- call setRenderTarget rs
- mapM_ (renderViewport flatScene rt) $ rtViewport rt
- --if isNothing t then return () else do
- --let tex = txObject $ (rlTextureMap $ wrResource world) ! (fromMaybe (error "fromJust 0") t)
- --GL.textureBinding GL.Texture2D $= Just tex
- -- only hint code: glCopyTexImage2D(GL_TEXTURE_2D, 0, GL_LUMINANCE, 0, 0, 128, 128, 0);
- --GL.copyTexImage2D Nothing 0 GL.RGBA' (GL.Position 0 0) (GL.TextureSize2D w' h') 0
- --return ()
-
- renderViewport fs rtarget v = do
- let (vx,vy,vw,vh) = getViewportSize rtarget v
- setViewport rs vx vy vw vh
-
- -- Clear the viewport if required
- when (vpClearEveryFrame v) $
- clearFrameBuffer rs (vpClearBuffers v) (vpBackColour v) 1 0
-
- -- Begin the frame
- --mDestRenderSystem->_beginFrame();
-
- -- Set rasterisation mode
- setPolygonMode rs $ cmPolygonMode cam
-
- -- Set initial camera state
- setProjectionMatrix rs $ cameraProjectionMatrix (fromIntegral vw / fromIntegral vh) cam
-
- --mDestRenderSystem->_setTextureProjectionRelativeTo(mCameraRelativeRendering, camera->getDerivedPosition());
- --setTextureProjectionRelativeTo
-
- setViewMatrix rs cameraViewMatrix
-
- -- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- -- TODO: activate compositor chain render target if necessary
- -- (re)initialize compositor resources if necessary
- -- foreach compositor
- -- select technique
- -- create render textures
- -- initialize target passes
- -- do render
- -- foreach compositor and target pass
- -- bind target pass
- -- execute each composition pass in target pass
- --HINT:
- --
-
- -- FIXME: TEMP CODE
- unless (null $ vpCompositors v) $ do
- -- bind render texture
- return ()
-
- -- render objects
- rstat <- renderQueue time rs (wrRenderOptions world) emptyRenderStatistics $ fsRenderable fs
--- print rstat
-
- -- Compositor
- -- TargetPass
- -- Pass
- forM_ (vpCompositors v) $ \c -> do
- let ct = head $ fromMaybe (error "fromJust 112") $ cmpSupportedTechniques c
- -- select first technique
- forM (zip [0..] $ ctTargetPasses ct ++ [ctOutputTarget ct]) $ \(ctpidx,ctp) -> do
- -- -- copy previous output to target's output when input is previous
- when (ctpInputMode ctp == IM_PREVIOUS) $ do
- -- FIXME
- dirtyHackCopyTexImage rs (fromMaybe (error "fromJust 212") $ tdTexture $ fromJust $ ctpOutput ctp) vx vy vw vh
- forM (ctpPasses ctp) $ \cp -> do
- -- do composition pass action
- case cpType cp of
- { PT_RENDERQUAD -> do
- -- TODO
- -- setup quad material
- -- render quad
- let quadM = fromMaybe (error "fromJust 312") $ Map.lookup "Quad.mesh.xml" (rlMeshMap $ wrResource world)
- quadSM = head $ msSubMeshList quadM
- quadSE = SubEntity { seMaterial = fromMaybe (error "fromJust 412") $ cpMaterial cp, seSubMesh = quadSM }
- quadE = Entity "" constRenderQueueMain quadM [quadSE]
- quadRE = head $ prepare (transl 0 0 0) quadE
- quadRP = [RenderablePass (reOperation quadRE) p (transl 0 0 0) [] | p <- rePassList quadRE]
- setProjectionMatrix rs $ transl 0 0 0
- setViewMatrix rs $ transl 0 0 0
- setPolygonMode rs PM_SOLID
- renderPassGroup time rs emptyRenderStatistics quadRP
- return ()
- ; _ -> return ()
- }
-{-
- unless (null $ vpCompositors v) $ do
- -- FIXME: TEMP CODE
- -- unbind render texture, and we'll have the rendered scene in a texture
- -- create a custom temp pass with temp render texture input
- -- create quad render operation
- let quadSM = head $ msSubMeshList $ fromJust $ Map.lookup "Quad.mesh.xml" (rlMeshMap $ wrResource world)
- quadRO = RenderOperation
- { roVertexData = fromJust $ smVertexData quadSM
- , roOperationType = smOperationType quadSM
- , roIndexData = smIndexData quadSM
- }
- quadP = head $ tchPasses $ head $ fromJust $ mtSupportedTechniques $ fromJust $ Map.lookup "QuadMaterial" (rlMaterialMap $ wrResource world)
- quadRP = RenderablePass
- { rpOperation = quadRO
- , rpPass = quadP'
- , rpMatrix = transl 0 0 0
- , rpLights = []
- }
- rtex = fromJust $ Map.lookup "RenderTex01" $ (rlTextureMap $ wrResource world)
- tus = psTextureUnitStates quadP
- tu = head tus
- tut = tail tus
- tu' = tu { tusFrames = Just [rtex] }
- quadP' = quadP { psTextureUnitStates = (tu':tut) }
- --setProjectionMatrix rs $ cameraProjectionMatrix (fromIntegral vw / fromIntegral vh) cam
- setProjectionMatrix rs $ transl 0 0 0
- setViewMatrix rs $ transl 0 0 0
- dirtyHackCopyTexImage rs rtex vx vy vw vh
- setPolygonMode rs PM_SOLID
- renderPassGroup rs [quadRP]
- -- invert back
- --dirtyHackCopyTexImage rs rtex vx vy vw vh
--} --renderPassGroup rs [quadRP]
- return ()
-
-{-
- = RenderOperation
- { roVertexData :: VertexData vb -- ^ Vertex source data
- , roOperationType :: OperationType -- ^ The type of operation to perform
- , roIndexData :: Maybe (IndexData ib) -- ^ Index data - only valid if useIndexes is true
- }
- = RenderablePass
- { rpOperation :: RenderOperation vb ib
- , rpPass :: Pass t lp
- , rpMatrix :: Matrix4
- , rpLights :: [(Matrix4,Light)]
- }
---renderPassGroup :: RenderSystem -> RenderablePass -> IO ()
--}
- -- do a manual render for temp pass (we should reset world, view, projection and texture matrix)
-
-
----------------------------------------------------------------------
- -- push flatten scene into a render queue
- -- collect lights which affect each renderable
- -- fold addRenderable
- -- call renderQueue
- --let addRend (m,rend,grpID,prior) rq = addRenderable m rend (map snd $ fsLight fs) grpID prior rq
- --renderQueue' rs $ foldr addRend emptyRenderQueue $ fsRenderable fs
- -- old code below-------------------------------------------------------------------------------------------
- --mapM_ (renderEntity (wrRenderSystem world)) $ optimize $ foldr (\(m,r) l -> (prepare m r) ++ l) [] [(a,b) | (a,b,_,_) <- fsRenderable fs]
- where
- (camMat,cam) = head $ Prelude.filter (\(_,a) -> camName == (cmName a)) cams
- camName = vpCamera v
- cams = fsCamera fs
- (Matrix4
- r11 r12 r13 _
- r21 r22 r23 _
- r31 r32 r33 _
- tx ty tz _) = camMat
- {-
- cameraViewMatrix = (Matrix4
- r11 r21 r31 0
- r12 r22 r32 0
- r13 r23 r33 0
- (-tx) (-ty) (-tz) 1)
- -}
- cameraViewMatrix = camMat
-
--- createTexture :: a -> String -> TextureType -> Int -> Int -> Int -> TextureMipmap -> PixelFormat -> TextureUsage -> Bool -> Int -> String -> Image -> IO t
-addRenderTexture n w h world = do
- let rl = wrResource world
- tm = rlTextureMap rl
- rs = wrRenderSystem world
- t <- createTexture rs n TEX_TYPE_2D w h 1 (MIP_NUMBER 1) PF_R8G8B8A8 (TextureUsage HBU_STATIC True False) False 0 "" Nothing
- return world { wrResource = rl { rlTextureMap = Map.insert n t tm } }
- --mapResource f w = w { wrResource = f (wrResource w) }
-
---addRenderWindow :: String -> Int -> Int -> [Viewport] -> World -> IO World
-addRenderWindow n w h l world = do
- vl <- mapM (\f -> f world) l
- let rt = RenderTarget
- { rtName = n
- , rtWidth = w
- , rtHeight = h
- , rtViewport = vl
- , rtTexture = Nothing
- }
- return $ mapTargets (Map.insert n rt) world
-
- {-
- = Compositor
- { cmpName :: String
- , cmpTechniques :: [CompositionTechnique t]
- , cmpSupportedTechniques :: Maybe [CompositionTechnique t]
- }
-
- = CompositionTechnique
- { ctTextureDefinitions :: [TextureDefinition t]
- , ctTargetPasses :: [CompositionTargetPass] -- ^ Intermediate target passes
- , ctOutputTarget :: CompositionTargetPass -- ^ Output target pass (can be only one)
- , ctSchemeName :: String -- ^ Optional scheme name
- }
-
- = TextureDefinition
- { tdName :: String
- , tdWidth :: Maybe Int -- Nothing means adapt to target width
- , tdHeight :: Maybe Int -- Nothing means adapt to target height
- , tdWidthFactor :: FloatType -- multiple of target width to use (if width = Nothing)
- , tdHeightFactor :: FloatType -- multiple of target height to use (if height = Nothing)
- , tdFormatList :: [PixelFormat] -- more than one means MRT
- , tdFsaa :: Bool -- FSAA enabled; true = determine from main target (if render_scene), false = disable
- , tdHwGammaWrite :: Bool -- Do sRGB gamma correction on write (only 8-bit per channel formats)
- , tdShared :: Bool -- whether to use shared textures for this one
- , tdTexture :: Maybe t
- }
-
- = CompositionTargetPass
- { ctpInputMode :: InputMode -- ^ Input name
- , ctpOutputName :: String -- ^ (local) output texture
- , ctpOutput :: Maybe (TextureDefinition t)
- , ctpPasses :: [CompositionPass] -- ^ Passes
- , ctpOnlyInitial :: Bool -- ^ This target pass is only executed initially after the effect has been enabled.
- , ctpVisibilityMask :: Word32 -- ^ Visibility mask for this render
- , ctpLodBias :: FloatType -- ^ LOD bias of this render
- , ctpMaterialScheme :: String -- ^ Material scheme name
- , ctpShadowsEnabled :: Bool -- ^ Shadows option
- }
-
- = InputTex
- { itName :: String -- ^ Name (local) of the input texture
- , itMrtIndex :: Int -- ^ MRT surface index if applicable
- }
-
- = CompositionPass
- { cpType :: PassType -- ^ Type of composition pass
- , cpIdentifier :: Word32 -- ^ Identifier for this pass
- , cpMaterialName :: String -- ^ Material used for rendering
- , cpMaterial :: Maybe (Material t lp)
- , cpFirstRenderQueue :: Int -- ^ [first,last] render queue to render this pass (in case of PT_RENDERSCENE)
- , cpLastRenderQueue :: Int
- , cpClearBuffers :: (Bool,Bool,Bool) -- ^ Clear buffers (in case of PT_CLEAR), hint: [colour] [depth] [stencil]
- , cpClearColour :: ColourValue -- ^ Clear colour (in case of PT_CLEAR)
- , cpClearDepth :: FloatType -- ^ Clear depth (in case of PT_CLEAR)
- , cpClearStencil :: Word32 -- ^ Clear stencil value (in case of PT_CLEAR)
- , cpInputs :: IntMap InputTex -- ^ Inputs (for material used for rendering the quad)
- , cpStencilCheck :: Bool -- ^ Stencil operation parameters
- , cpStencilFunc :: CompareFunction
- , cpStencilRefValue :: Word32
- , cpStencilMask :: Word32
- , cpStencilFailOp :: StencilOperation
- , cpStencilDepthFailOp :: StencilOperation
- , cpStencilPassOp :: StencilOperation
- , cpStencilTwoSidedOperation :: Bool
- , cpQuadCornerModified :: Bool -- ^ true if quad should not cover whole screen
- , cpQuadLeft :: FloatType -- ^ quad positions in normalised coordinates [-1;1]x[-1;1] (in case of PT_RENDERQUAD)
- , cpQuadTop :: FloatType
- , cpQuadRight :: FloatType
- , cpQuadBottom :: FloatType
- , cpQuadFarCorners :: Bool
- , cpQuadFarCornersViewSpace :: Bool
- }
-
-data PassType
- = PT_CLEAR -- ^ Clear target to one colour
- | PT_STENCIL -- ^ Set stencil operation
- | PT_RENDERSCENE -- ^ Render the scene or part of it
- | PT_RENDERQUAD -- ^ Render a full screen quad
- -}
--- | Create render textures, and setup compositor chain.
-mkCompositorChain wr0 cl0 = do
- -- do we really need this ???? -- HINT: add an implicit target to first compositor which renders the scene into a viewportsized texture,
- -- iterate trough compositors and select first supported technique
- let rs = wrRenderSystem wr0
- initCompositor (world0,cl) c = do -- :: (World,[Maybe Compositor]) -> Compositor -> (World,[Maybe Compositor])
- -- TODO: select first supported technique
- let ct = head $ cmpTechniques c
- tds <- forM (ctTextureDefinitions ct) $ \td -> do
- -- create render textures
- let w = fromMaybe 1 $ tdWidth td
- h = fromMaybe 1 $ tdHeight td
- txn = (cmpName c ++ "/" ++ tdName td)
- t <- createTexture rs txn TEX_TYPE_2D w h 1 (MIP_NUMBER 1) (head $ tdFormatList td) (TextureUsage HBU_STATIC True False) False 0 "" Nothing
- debugM "Initialize Compositor" $ "Created compositor texture: " ++ txn
- return td { tdTexture = Just t }
-
- let texmap = Map.fromList [(tdName td,td) | td <- tds]
- onamel = map ctpOutputName $ ctTargetPasses ct
- outtexl = [Map.lookup o texmap | o <- onamel]
- checkTex b tn = case Map.member tn texmap of
- { True -> return b
- ; False -> do
- errorM "Initialize Compositor" $ "Unknown compositor texture: " ++ tn
- return False
- }
- oktex <- foldM checkTex True onamel
- case oktex of
- { False -> return (world0,Nothing:cl)
- ; True -> do
- -- setup compositor target pass output
- let tps0 = [tp { ctpOutput = o } | (o,tp) <- zip outtexl $ ctTargetPasses ct]
- initPasses (w0,tpl,okPasses) tp = do
- let initPass (w0,pl,okPass) cp = case cpType cp of
- { PT_RENDERQUAD -> do
- -- setup composition pass input
- -- load material
- (w1,mmat) <- getLoadedMaterial (cpMaterialName cp) w0
- case mmat of
- { Nothing -> return (w1,cp:pl,False)
- ; Just mat -> do
- -- check pass input texture names
- okInput <- foldM checkTex True [itName it | it <- IntMap.elems $ cpInputs cp]
- case okInput of
- { False -> return (w1,cp:pl,False)
- ; True -> do
- -- foreach material pass and for each textureunitstate
- -- setup texture when it's a RT
- let fp p = p { psTextureUnitStates = tul' }
- where
- tul' = [tu { tusFrames = fromMaybe (tusFrames tu) $ ft i } | (i,tu) <- tusl]
- ft i = case IntMap.lookup i $ cpInputs cp of
- { Nothing -> Nothing
- ; Just it -> Just $ Just [fromJust $ tdTexture $ texmap Map.! (itName it)]
- }
- tusl = zip [0..] $ psTextureUnitStates p
- mat' = mat { mtSupportedTechniques = Just [tch { tchPasses = [fp p | p <- tchPasses tch] } | tch <- fromJust $ mtSupportedTechniques mat] }
- --return with modified pass attached to the list
- return (w1,(cp { cpMaterial = Just mat' }):pl,okPass)
- }
- }
- ; _ -> return (w0,cp:pl,okPass)
- }
-
- (w1,pl,okPasses') <- foldM initPass (w0,[],okPasses) $ ctpPasses tp
- return (w1,(tp { ctpPasses = reverse pl }):tpl, okPasses')
-
- (world1,tps1,okInit1) <- foldM initPasses (world0,[],True) tps0
- (world2,motp,okInit2) <- initPasses (world1,[],okInit1) $ ctOutputTarget ct
- case okInit2 of
- { False -> return (world2,Nothing:cl)
- ; True -> do
- let otp = head motp
- tps2 = reverse tps1 -- [tp | Just tp <- tps1]
- return (world2,(Just c { cmpSupportedTechniques = Just [ct { ctTextureDefinitions = tds, ctTargetPasses = tps2, ctOutputTarget = otp }] }):cl)
- }
- }
- -- setup compositor target pass input
- (wr1,cl1) <- foldM initCompositor (wr0,[]) cl0
- let cl2 = reverse [c | Just c <- cl1]
- -- TODO: setup compositor chain connection
- return (wr1,cl2)
-
--- | Create a viewport and attach given compositors.
-mkViewport x y w h cam cnl world0 = do
- -- collect compositors
- let compMap = rlCompositorMap $ wrResource world0
- getCompositor l cn = case Map.lookup cn compMap of
- { Nothing -> do
- errorM "ApplyCompositor" $ "Unknown compositor: " ++ cn
- return l
- ; Just c -> return $ c:l
- }
-
- -- setup compositor chain
- cl0 <- foldM getCompositor [] cnl
- (world1,cl1) <- mkCompositorChain world0 $ reverse cl0
- return Viewport
- { vpLeft = x
- , vpTop = y
- , vpWidth = w
- , vpHeight = h
- , vpCamera = cam
- , vpCompositors = cl1
- , vpBackColour = (0,0,0,0)
- , vpClearEveryFrame = True
- , vpClearBuffers = FrameBufferType True True False
- }
-
---updateTargetSize :: String -> Int -> Int -> World -> IO World
-updateTargetSize n w h = return . mapTargets (Map.adjust f n)
- where
+{-# OPTIONS_GHC -fno-warn-unused-binds #-}
+{-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification, Rank2Types, NamedFieldPuns #-}
+
+module Graphics.LambdaCube.World where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Fix
+import Control.Monad.Trans
+import System.Directory
+import System.FilePath
+
+import Data.List
+import Data.IntMap (IntMap)
+import Data.Map (Map)
+import Data.Maybe
+import qualified Data.IntMap as IntMap
+import qualified Data.Map as Map
+
+import Codec.Archive.Zip
+import qualified Data.ByteString.Char8 as SB8
+import qualified Data.ByteString as SB
+import qualified Data.ByteString.Internal as SB
+import qualified Data.ByteString.Lazy as LB
+
+import Graphics.LambdaCube.Common
+import Graphics.LambdaCube.Compositor
+import Graphics.LambdaCube.Entity
+import Graphics.LambdaCube.Frustum
+import Graphics.LambdaCube.GpuProgram
+import Graphics.LambdaCube.GpuProgramUsage
+import Graphics.LambdaCube.HardwareBuffer
+import Graphics.LambdaCube.HardwareIndexBuffer
+import Graphics.LambdaCube.HardwareVertexBuffer
+import Graphics.LambdaCube.Image
+import Graphics.LambdaCube.Light
+import Graphics.LambdaCube.Loader.MeshXML
+import Graphics.LambdaCube.Loader.ResourceScript
+import Graphics.LambdaCube.Material
+import Graphics.LambdaCube.Mesh
+import Graphics.LambdaCube.Pass
+import Graphics.LambdaCube.PixelFormat
+import Graphics.LambdaCube.RenderQueue
+import Graphics.LambdaCube.RenderSystem
+import Graphics.LambdaCube.Technique
+import Graphics.LambdaCube.Texture
+import Graphics.LambdaCube.TextureUnitState
+import Graphics.LambdaCube.Tree
+import Graphics.LambdaCube.Types
+import Graphics.LambdaCube.Utility
+import Graphics.LambdaCube.VertexBufferVector
+
+-- * World transformation
+
+newtype LCM w e a = LCM { unLCM :: forall r . (a -> w -> IO r) -> (e -> w -> IO r) -> w -> IO r }
+
+instance Functor (LCM w e) where
+ fmap = liftM
+
+instance Applicative (LCM w e) where
+ pure = return
+ (<*>) = ap
+
+instance Monad (LCM w e) where
+ return x = LCM (\k t w -> k x w)
+ LCM lc >>= f = LCM (\k t -> lc (\x -> unLCM (f x) k t) t)
+
+instance MonadIO (LCM w e) where
+ liftIO m = LCM (\k t w -> m >>= \x -> k x w)
+
+-- | Embed a LambdaCube program in IO. The embedding manages a world,
+-- therefore it requires all the information to create one: the render
+-- system and a list of image loaders.
+runLCM :: (RenderSystem r vb ib q t1 p lp) => r
+ -> [ImageLoader]
+ -> LCM (World r vb ib q t1 p lp) e a
+ -> IO ()
+runLCM renderSystem imageLoaders (LCM lc) = do
+ let nop _ _ = return ()
+ lc nop nop (mkWorld renderSystem imageLoaders)
+
+-- Run a world transforming IO action in LCM.
+inLCM :: (w -> IO w) -> LCM w e ()
+inLCM act = LCM (\k t w -> act w >>= k ())
+
+-- Get the current state of the world.
+peekLCM :: LCM w e w
+peekLCM = LCM (\k t w -> k w w)
+
+-- Set the current state of the world.
+pokeLCM :: w -> LCM w e ()
+pokeLCM w' = LCM (\k t w -> k () w')
+
+-- Bypass the rest of the computation and throw an out-of-band value.
+throwLCM :: e -> LCM w e a
+throwLCM x = LCM (\k t w -> t x w)
+
+-- Join the normal and the out-of-band result of a computation: if a
+-- value was thrown, return it, otherwise return the result of the
+-- computation.
+catchLCM :: LCM w a a -> LCM w e a
+catchLCM (LCM lc) = LCM (\k t w -> lc k k w)
+
+errorLCM :: String -> String -> LCM w e ()
+errorLCM ty msg = liftIO $ putStrLn $ ty ++ msg
+
+debugLCM :: String -> String -> LCM w e ()
+debugLCM ty msg = liftIO $ putStrLn $ ty ++ msg
+
+-- * World
+
+data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => FlattenScene vb ib t lp
+ = FlattenScene
+ { fsRenderable :: [(Proj4,[RenderEntity vb ib t lp],Int,Int)] -- ^ List of Renderable information including WorldMatrix RenderQueueID and RenderPriority
+ , fsCamera :: [(Proj4,Camera)]
+ , fsLight :: [(Proj4,Light)]
+ }
+
+data RenderSystem r vb ib q t p lp => World r vb ib q t p lp
+ = World
+ { wrResource :: ResourceLibrary vb ib t p lp -- IO related
+ , wrRenderSystem :: r -- IO related
+ , wrScene :: Scene vb ib t lp
+ , wrTargets :: Map String (RenderTarget t lp)
+ , wrRenderOptions :: IntMap RenderGroupOptions
+ , wrImageLoaders :: [ImageLoader]
+ }
+
+updateWorld :: (w -> w) -> LCM w e ()
+updateWorld f = do
+ world <- peekLCM
+ pokeLCM $! f world
+
+updateResource :: (RenderSystem r vb ib q t p lp) => (ResourceLibrary vb ib t p lp -> ResourceLibrary vb ib t p lp) -> LCM (World r vb ib q t p lp) e ()
+updateResource f = do
+ world@World { wrResource = res } <- peekLCM
+ let res' = f res
+ res' `seq` pokeLCM $ world { wrResource = res' }
+
+{-
+mapResource :: (RenderSystem r vb ib q t p lp) => (ResourceLibrary vb ib t p lp -> ResourceLibrary vb ib t p lp) -> World r vb ib q t p lp -> World r vb ib q t p lp
+mapResource f w = w { wrResource = f (wrResource w) }
+-}
+
+mapScene :: (RenderSystem r vb ib q t p lp) => (Scene vb ib t lp -> Scene vb ib t lp) -> World r vb ib q t p lp -> World r vb ib q t p lp
+mapScene f w = w { wrScene = f (wrScene w) }
+
+mapTargets :: (RenderSystem r vb ib q t p lp) => (Map String (RenderTarget t lp) -> Map String (RenderTarget t lp)) -> World r vb ib q t p lp -> World r vb ib q t p lp
+mapTargets f w = w { wrTargets = f (wrTargets w) }
+
+mkWorld :: RenderSystem r vb ib q t p lp => r -> [ImageLoader] -> World r vb ib q t p lp
+mkWorld rs imgLoaders = World
+ { wrResource = mkResource
+ , wrRenderSystem = rs
+ , wrScene = mkScene
+ , wrTargets = Map.empty
+ , wrRenderOptions = IntMap.empty
+ , wrImageLoaders = imgLoaders
+ }
+
+mkResource :: (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, GpuProgram p, LinkedGpuProgram lp) => ResourceLibrary vb ib t p lp
+mkResource = ResourceLibrary [] Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty
+
+mkScene :: (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => Scene vb ib t lp
+mkScene = Scene
+ { scGraph = root "Root" (SceneNode "Root" [] idmtx)
+ , scSky = Nothing
+ }
+
+-- * Resource
+
+data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, GpuProgram p, LinkedGpuProgram lp) => ResourceLibrary vb ib t p lp
+ = ResourceLibrary
+ { rlResourceGroups :: [ResourceGroup]
+ , rlMeshMap :: Map String (Mesh vb ib)
+ , rlMaterialMap :: Map String (Material t lp)
+ , rlTextureMap :: Map String t
+ , rlGpuProgramMap :: Map String (GpuProgramDescriptor p)
+ , rlLinkedGpuProgramMap :: Map (String,String,String) lp
+ , rlCompositorMap :: Map String (Compositor t lp)
+ }
+
+-- * SceneGraph
+
+-- | Camera description.
+data Camera
+ = Camera
+ { cmName :: String -- ^ The name of the camera.
+ , cmFov :: FloatType -- ^ Field of view in radians.
+ , cmNear :: FloatType -- ^ Near plane clipping distance.
+ , cmFar :: FloatType -- ^ Far plane clipping distance.
+ , cmAspectRatio :: Maybe FloatType -- ^ Camera aspect ratio (width/height).
+ , cmPolygonMode :: PolygonMode -- ^ Rendering type.
+ }
+{-
+ name CDATA #IMPLIED
+ id ID #IMPLIED
+ FOVy CDATA "45"
+ aspectRatio CDATA "1.3333333"
+ projectionType (perspective | orthographic) "perspective"
+ polygonMode (points | wireframe | solid) "solid"
+ useRenderingDistance (yes | no) "yes"
+ lodBiasFactor CDATA "1.0"
+-}
+cameraProjectionMatrix :: FloatType -> Camera -> Mat4
+cameraProjectionMatrix a cam = perspective near far fov aspect
+ where
+ Camera
+ { cmFov = fov
+ , cmNear = near
+ , cmFar = far
+ , cmAspectRatio = aspectr
+ } = cam
+ aspect = fromMaybe a aspectr
+
+data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => SceneObject vb ib t lp
+ = SO_Entity (Entity vb ib t lp)
+ | SO_Camera Camera
+ | SO_Light Light
+-- | SO_ParticleSystem ParticleSystem
+
+--data RenderTarget
+-- = RT_MainBuffer
+-- | RT_FrameBuffer
+
+{-
+data RenderWindow = RenderWindow
+ { rwWidth :: Int
+ , rwHeight :: Int
+ , rwViewport :: [Viewport]
+ --, rtTarget -- texture or screen
+ }
+-}
+
+data (Texture t, LinkedGpuProgram lp) => RenderTarget t lp
+ = RenderTarget
+ { rtName :: String
+ , rtWidth :: Int
+ , rtHeight :: Int
+ , rtViewport :: [Viewport t lp]
+ , rtTexture :: Maybe String
+ }
+
+data (Texture t, LinkedGpuProgram lp) => Viewport t lp
+ = Viewport
+ { vpLeft :: FloatType
+ , vpTop :: FloatType
+ , vpWidth :: FloatType
+ , vpHeight :: FloatType
+ , vpCamera :: String --Camera
+ , vpCompositors :: [Compositor t lp]
+ , vpBackColour :: ColourValue
+ , vpClearEveryFrame :: Bool
+ , vpClearBuffers :: FrameBufferType
+ }
+
+getViewportSize :: (Texture t, LinkedGpuProgram lp) => RenderTarget t lp -> Viewport t lp -> (Int,Int,Int,Int)
+getViewportSize t v = (x,y,w,h)
+ where
+ ww = fromIntegral $ rtWidth t
+ wh = fromIntegral $ rtHeight t
+ x = floor $ ww * (vpLeft v)
+ y = floor $ wh * (vpTop v)
+ w = floor $ ww * (vpWidth v)
+ h = floor $ wh * (vpHeight v)
+
+data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => SceneNode vb ib t lp
+ = SceneNode
+ { snName :: String
+ , snObject :: [SceneObject vb ib t lp]
+ , snTransform :: Proj4
+ }-- deriving (Show,Read)
+
+data Sky
+ = SkyBox --Material
+ | SkyDome
+ | SkyPlane
+
+{-
+data Scene = Scene
+ { scGraph :: Gr () ()
+-- , scMap :: Map Int SceneNode
+ , scMap :: IntMap SceneNode
+ , scNameMap :: Map String Int
+ , scSky :: Maybe Sky
+ -- Fog settings
+ }
+-}
+
+data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => Scene vb ib t lp
+ = Scene
+ { scGraph :: IndexedTree (SceneNode vb ib t lp)
+ , scSky :: Maybe Sky
+ -- Fog settings
+ }
+
+-- | Add a new vector mesh to the world.
+addVMesh :: RenderSystem r vb ib q t p lp
+ => String -- ^ The name of the mesh in the world.
+ -> VMesh -- ^ The mesh to add.
+ -> LCM (World r vb ib q t p lp) e ()
+addVMesh name vmesh = do
+ world <- peekLCM
+ mesh <- liftIO $ meshFromV (wrRenderSystem world) vmesh
+ pokeLCM $ addMesh name mesh world
+
+-- | Retrieve a vector mesh from the world by name.
+getVMesh :: RenderSystem r vb ib q t p lp => String -> LCM (World r vb ib q t p lp) e VMesh
+getVMesh name = do
+ mesh <- getMesh name
+ liftIO $ vFromMesh mesh
+
+addMesh :: RenderSystem r vb ib q t p lp => String -> Mesh vb ib -> World r vb ib q t p lp -> World r vb ib q1 t p lp
+addMesh name mesh world = world { wrResource = rl { rlMeshMap = Map.insert name mesh (rlMeshMap rl) } }
+ where
+ rl = wrResource world
+
+getMesh :: RenderSystem r vb ib q t p lp => String -> LCM (World r vb ib q t p lp) e (Mesh vb ib)
+getMesh name = catchLCM $ do
+ World { wrResource, wrRenderSystem } <- peekLCM
+ let mm@ ~(Just m) = Map.lookup name (rlMeshMap wrResource)
+ when (isJust mm) $ throwLCM m
+ f <- readFile' name
+ m <- liftIO $ case takeExtension name of
+ ".xml" -> do
+ putStrLn $ "ResourceLibrary " ++ "parsing mesh XML file " ++ name
+ parseMesh wrRenderSystem $ SB8.unpack f
+ _ -> error "Unsupported format!"
+ {-
+ f <- loadFile (rlResourceGroups rl) name
+ when (isNothing f) $ error $ "File not found: " ++ name
+ case takeExtension name of
+ ".xml" -> do
+ debugM "ResourceLibrary" $ "parsing mesh XML file " ++ name
+ parseMesh rs $ map SB.w2c $ LB.unpack $ fromMaybe (error "fromJust 9") f
+ _ -> error ("Unsupported format!")
+ -}
+ updateResource $ \rl -> rl { rlMeshMap = Map.insert name m (rlMeshMap rl) }
+ return m
+
+--loadMaterialResources :: RenderSystem rs vb ib q t p lp =>
+-- rs -> [FilePath -> LB.ByteString -> IO (Maybe Image)] -> ResourceLibrary vb ib t p lp ->
+-- Material t lp -> IO (ResourceLibrary vb ib t p lp, Material t lp)
+loadMaterialResources :: RenderSystem rs vb ib q t p lp =>
+ Material t lp -> LCM (World rs vb ib q t p lp) e (Material t lp)
+loadMaterialResources mat = catchLCM $ do
+ when (isJust (mtSupportedTechniques mat)) $ throwLCM mat -- Material is already initialized
+
+ -- select and load supported techniques
+ suppTech <- forM (filter isSupportedTech (mtTechniques mat)) $ \tech -> do
+ -- load passes (GpuProgram)
+ passes <- forM (tchPasses tech) $ \pass -> do
+ lgp <- loadGpuProgram pass
+ tuss <- forM (psTextureUnitStates pass) loadTextureUnit
+ return $ pass
+ { psTextureUnitStates = tuss
+ , psLinkedGpuProgram = lgp
+ }
+
+ return (tech { tchPasses = passes })
+
+ -- Insert loaded material into MaterialMap
+ let mat' = mat { mtSupportedTechniques = Just suppTech }
+ updateResource $ \rl -> rl { rlMaterialMap = Map.insert (mtName mat') mat' (rlMaterialMap rl) }
+
+ return mat'
+ where
+ isSupportedTech _ = True -- TODO
+
+ loadGpuProgram pass = catchLCM $ do
+ let mlgp = psLinkedGpuProgram pass
+ when (isJust mlgp) $ throwLCM mlgp
+
+ world@World { wrRenderSystem = rs, wrResource = reslib } <- peekLCM
+ let gpuprogmap = rlGpuProgramMap reslib
+ progName@(vpn,fpn,gpn) =
+ (getName (psVertexProgramUsage pass),
+ getName (psFragmentProgramUsage pass),
+ getName (psGeometryProgramUsage pass))
+ where
+ getName = maybe "" gpuProgramName
+
+ -- collect required shaders name list
+ progNames <- flip fix ([],filter (/="") [vpn,fpn,gpn]) $ \loop (cl,nl) ->
+ case nl of
+ [] -> return cl
+ _ -> do
+ let fnl = filter (`notElem` cl) nl
+ nl' <- forM fnl $ \m -> case Map.lookup m gpuprogmap of
+ Nothing -> do
+ errorLCM "loadShader" $ "Unknown attached GpuProgram: " ++ m
+ return []
+ Just gp -> return (gpdAttach gp)
+ loop (cl ++ fnl, concat nl')
+
+ when (null progNames) $ throwLCM Nothing
+
+ -- load all shaders
+ progs <- fmap catMaybes . forM progNames $ \sn -> catchLCM $ do
+ reslib <- wrResource <$> peekLCM
+
+ let mgpd@ ~(Just gpd) = Map.lookup sn (rlGpuProgramMap reslib)
+ when (isNothing mgpd) $ do
+ errorLCM "loadShader" $ "Unknown GpuProgram: " ++ sn
+ throwLCM Nothing
+
+ let mp = gpdGpuProgram gpd
+ when (isJust mp) $ throwLCM mp
+
+ -- GpuProgram is not loaded yet
+ let fname = gpdFilename gpd
+ msrc@ ~(Just src) <- liftIO $ loadFile (rlResourceGroups reslib) fname
+ when (isNothing msrc) $ do
+ errorLCM "loadShader" $ "GpuProgram source not found: " ++ sn ++ " - " ++ fname
+ throwLCM Nothing
+
+ eprog <- liftIO $ createGpuProgram rs (gpdType gpd) (map SB.w2c (LB.unpack src))
+ case eprog of
+ Right err -> do
+ errorLCM "loadShader" $ "Error compile " ++ sn ++ ": " ++ err
+ return Nothing
+ Left prog -> do
+ debugLCM "loadShader" $ "GpuProgram loaded: " ++ sn
+ let mprog = Just prog
+ gpmap = Map.insert sn (gpd { gpdGpuProgram = mprog }) (rlGpuProgramMap reslib)
+ updateResource $ \rl -> rl { rlGpuProgramMap = gpmap }
+ return mprog
+
+ mlp <- Map.lookup progName . rlLinkedGpuProgramMap . wrResource <$> peekLCM
+ when (isJust mlp) $ throwLCM mlp
+
+ -- create LinkedGpuProgram
+ elprog <- liftIO $ createLinkedGpuProgram rs progs
+ case elprog of
+ Right err -> do
+ errorLCM "loadGpuProgram" $ "Error link " ++ show progName ++ ": " ++ err
+ return Nothing
+ Left lprog -> do
+ debugLCM "loadGpuProgram" $ "GpuProgram linked: " ++ show progName
+ lgpmap <- rlLinkedGpuProgramMap . wrResource <$> peekLCM
+ updateResource $ \rl -> rl { rlLinkedGpuProgramMap = Map.insert progName lprog lgpmap }
+ return (Just lprog)
+
+ loadImage name = do
+ World { wrResource, wrImageLoaders } <- peekLCM
+ d <- liftIO $ loadFile (rlResourceGroups wrResource) name
+ case d of
+ Just imgdata -> liftIO $ foldM' loadImg Nothing wrImageLoaders
+ where
+ loadImg Nothing loader = loader name imgdata
+ loadImg img _ = return img
+ Nothing -> do
+ debugLCM "Load image" $ "File not found: " ++ name
+ return Nothing
+
+ loadTextureUnit t = do
+ World { wrRenderSystem } <- peekLCM
+ let loadTexture texname = catchLCM $ do
+ reslib <- wrResource <$> peekLCM
+ let mt = Map.lookup texname (rlTextureMap reslib)
+ when (isJust mt) $ throwLCM mt -- texture is loaded
+
+ -- we have to create the texture
+ -- TODO: create and load texture via render system
+{-
+ virtual TexturePtr createManual(const String & name, const String& group,
+ TextureType texType, uint width, uint height, uint depth,
+ int num_mips, PixelFormat format, int usage = TU_DEFAULT, ManualResourceLoader* loader = 0,
+ bool hwGammaCorrection = false, uint fsaa = 0, const String& fsaaHint = StringUtil::BLANK);
+
+ { imName :: String
+ , imHeight :: Int
+ , imWidth :: Int
+ , imDepth :: Int
+ , imSize :: Int
+ , imNumMipmaps :: Int
+-- uint flags;
+ , imFormat :: PixelFormat
+ , imData :: (Ptr Word8) -- ^ Image can be empty
+ }
+ mkGLTexture :: String -> TextureType -> Int -> Int -> Int -> Int -> PixelFormat -> TextureUsage -> Bool -> Int -> String -> IO GLTexture
+ mkGLTexture name texType width height depth numMips format usage hwGammaCorrection fsaa fsaaHint = do
+--createTexture :: a -> String -> TextureType -> Int -> Int -> Int -> Int -> PixelFormat -> TextueUsage -> Bool -> Int -> String -> IO t
+-}
+ mi@ ~(Just img) <- loadImage texname
+ when (isNothing mi) $ do
+ debugLCM "Load texture" $ "No proper image codec was found: " ++ texname
+ throwLCM Nothing
+
+ let usage = TextureUsage HBU_STATIC True False
+ t <- liftIO $ createTexture wrRenderSystem texname (tusTextureType t)
+ (imWidth img) (imHeight img) (imDepth img)
+ (tusTextureSrcMipmaps t) (tusDesiredFormat t) usage (tusHwGamma t) 0 "" (Just [img])
+ -- TODO
+ --let t = undefined
+ let texmap = rlTextureMap reslib
+ updateResource $ \rl -> rl { rlTextureMap = Map.insert texname t texmap }
+ return (Just t)
+
+ loadCubicTexture texname = catchLCM $ do
+ texmap <- rlTextureMap . wrResource <$> peekLCM
+ let mt = Map.lookup (concat texname) texmap
+ when (isJust mt) $ throwLCM mt -- texture is loaded
+
+ -- we have to create the texture
+ -- TODO: create and load texture via render system
+ i <- forM texname loadImage
+ unless (all isJust i) $ do
+ debugLCM "Load texture" $ "No proper image codec was found: " ++ concat texname
+ throwLCM Nothing
+
+ let usage = TextureUsage HBU_STATIC True False
+ Just img : _ = i
+ t <- liftIO $ createTexture wrRenderSystem (concat texname) (tusTextureType t)
+ (imWidth img) (imHeight img) (imDepth img)
+ (tusTextureSrcMipmaps t) (tusDesiredFormat t) usage (tusHwGamma t) 0 "" (Just (map fromJust i))
+ updateResource $ \rl -> rl { rlTextureMap = Map.insert (concat texname) t texmap }
+ return (Just t)
+ -- load textures
+ -- TODO: load all frames
+ frames <- case tusTextureType t of
+ TEX_TYPE_CUBE_MAP -> maybeToList <$> loadCubicTexture (tusFrameNames t)
+ _ -> catMaybes <$> forM (tusFrameNames t) loadTexture
+ return $ t { tusFrames = Just frames }
+
+
+--NOTE: this should return with Nothing if there's no supported technique
+--getLoadedMaterial :: (RenderSystem rs vb ib q t p lp) => String -> World rs vb ib q t p lp -> IO (World rs vb ib q t p lp, Maybe (Material t lp))
+getLoadedMaterial :: RenderSystem r vb ib q t p lp => String -> LCM (World r vb ib q t p lp) e (Maybe (Material t lp))
+getLoadedMaterial matname = do
+ matmap <- rlMaterialMap . wrResource <$> peekLCM
+ case Map.lookup matname matmap of
+ Nothing -> do
+ errorLCM "loadMaterial" $ "Material not found: " ++ matname
+ return Nothing
+ Just m -> case mtSupportedTechniques m of
+ Just _ -> return (Just m)
+ --TODO: this should return with Nothing if there's no supported technique
+ Nothing -> Just <$> loadMaterialResources m
+
+setEntityMaterial :: RenderSystem r vb ib q t p lp => [String] -> Entity vb ib t lp -> LCM (World r vb ib q t p lp) e (Entity vb ib t lp)
+setEntityMaterial mats ent = do
+ subents <- forM (zip (enSubEntityList ent) mats) $ \(sent,matname) -> do
+ matmap <- rlMaterialMap . wrResource <$> peekLCM
+ mat <- case Map.lookup matname matmap of
+ Just m -> loadMaterialResources m
+ Nothing -> error $ "Material not found: " ++ matname
+ return (sent { seMaterial = mat })
+
+ return (ent { enSubEntityList = subents })
+
+createEntity :: (RenderSystem r vb ib q t p lp, Enum rqp) => String -> String -> rqp -> LCM (World r vb ib q t p lp) e (Entity vb ib t lp)
+createEntity ename mname renderQueueID = do
+ -- lookup mesh, load if not exists
+ --debugM "ResourceLibrary" $ "creating entity: \"" ++ ename ++ "\" from mesh: \"" ++ mname ++ "\""
+ mesh <- getMesh mname
+ --debugM "ResourceLibrary" " done"
+
+ subents <- forM (msSubMeshList mesh) $ \smesh -> do
+ matmap <- rlMaterialMap . wrResource <$> peekLCM
+ let matname = smMaterialName smesh
+ mat <- case Map.lookup matname matmap of
+ Just m -> loadMaterialResources m
+ Nothing -> error $ "Material not found: " ++ matname
+ --debugM "createEntity" $ "Material not found: " ++ matname
+ -- TODO
+ --loadMaterialResources (matmap ! "WarningMaterial")
+ return (SubEntity { seMaterial = mat, seSubMesh = smesh })
+
+ return $ Entity
+ { enName = ename
+ , enRenderQueue = fromEnum renderQueueID
+ , enMesh = mesh
+ , enSubEntityList = subents
+ }
+
+-- | Get the raw data for a resource in a lazy bytestring given its
+-- path. The data is cached, so this does not necessarily require
+-- disk I/O.
+readFile :: RenderSystem r vb ib q t p lp => FilePath -> LCM (World r vb ib q t p lp) e LB.ByteString
+readFile fname = do
+ world <- peekLCM
+ f <- liftIO $ loadFile (rlResourceGroups (wrResource world)) fname
+ case f of
+ Nothing -> throwLCM $ error $ "File not found: " ++ fname
+ Just d -> return d
+
+-- | Get the raw data for a resource in a strict bytestring given its
+-- path. The data is cached, so this does not necessarily require
+-- disk I/O.
+readFile' :: RenderSystem r vb ib q t p lp => FilePath -> LCM (World r vb ib q t p lp) e SB.ByteString
+readFile' fname = SB.concat <$> LB.toChunks <$> Graphics.LambdaCube.World.readFile fname
+
+loadFile :: [ResourceGroup] -> FilePath -> IO (Maybe LB.ByteString)
+loadFile respath fname = foldM' (\s (_,l) -> foldM' load s l) Nothing respath
+ where
+ load s@(Just str) _ = return s
+ load s (PathZip,n) = do
+ -- TODO: this is a naive implementation with poor perfomance
+ f <- LB.readFile n
+ let a = toArchive f
+ return $ fmap fromEntry $ findEntryByPath fname a
+ load Nothing (PathDir,n) = do
+ let ffname = (addTrailingPathSeparator n) ++ fname
+ e <- doesFileExist ffname
+ ret <- if e then LB.readFile ffname else return LB.empty
+ return $ if e then Just ret else Nothing
+
+renderFlatScene :: RenderSystem r vb ib q t p lp => FloatType -> String -> FlattenScene vb ib t lp -> LCM (World r vb ib q t p lp) e ()
+renderFlatScene time name flatScene = do
+ World { wrTargets, wrRenderSystem = rs, wrRenderOptions, wrResource } <- peekLCM
+ let renderTarget rt = do
+ -- TODO: calc render statistics
+ let t = rtTexture rt
+ -- call setRenderTarget rs
+ mapM_ (renderViewport flatScene rt) $ rtViewport rt
+ --if isNothing t then return () else do
+ --let tex = txObject $ (rlTextureMap $ wrResource world) ! (fromMaybe (error "fromJust 0") t)
+ --GL.textureBinding GL.Texture2D $= Just tex
+ -- only hint code: glCopyTexImage2D(GL_TEXTURE_2D, 0, GL_LUMINANCE, 0, 0, 128, 128, 0);
+ --GL.copyTexImage2D Nothing 0 GL.RGBA' (GL.Position 0 0) (GL.TextureSize2D w' h') 0
+ --return ()
+
+ renderViewport fs rtarget v = do
+ let (vx,vy,vw,vh) = getViewportSize rtarget v
+ (camMat,cam) = head $ Prelude.filter (\(_,a) -> camName == (cmName a)) $ fsCamera fs
+ camName = vpCamera v
+ cameraViewMatrix = inverse camMat
+ projectionMatrix = cameraProjectionMatrix (fromIntegral vw / fromIntegral vh) cam
+ camFrustum = frustumFromMatrix $ (fromProjective cameraViewMatrix) .*. projectionMatrix
+
+ setViewport rs vx vy vw vh
+
+ -- Clear the viewport if required
+ when (vpClearEveryFrame v) $
+ clearFrameBuffer rs (vpClearBuffers v) (vpBackColour v) 1 0
+
+ -- Begin the frame
+ --mDestRenderSystem->_beginFrame();
+
+ -- Set rasterisation mode
+ setPolygonMode rs $ cmPolygonMode cam
+
+ -- Set initial camera state
+ setProjectionMatrix rs projectionMatrix
+
+ --mDestRenderSystem->_setTextureProjectionRelativeTo(mCameraRelativeRendering, camera->getDerivedPosition());
+ --setTextureProjectionRelativeTo
+
+ setViewMatrix rs cameraViewMatrix
+
+ -- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ -- TODO: activate compositor chain render target if necessary
+ -- (re)initialize compositor resources if necessary
+ -- foreach compositor
+ -- select technique
+ -- create render textures
+ -- initialize target passes
+ -- do render
+ -- foreach compositor and target pass
+ -- bind target pass
+ -- execute each composition pass in target pass
+ --HINT:
+ --
+
+ -- FIXME: TEMP CODE
+ unless (null $ vpCompositors v) $ do
+ -- bind render texture
+ return ()
+
+ --TODO: cull scene
+ -- sphereInFrustum p r fr
+ --fsRenderable :: [(Mat44FT,[RenderEntity vb ib t lp],Int,Int)]
+ let culledScene = cull (fsRenderable fs)
+ where
+ cull rs = [(reMat,rel',rqid,rprio) | (reMat,rel,rqid,rprio) <- rs,
+ let p = trim (_4 (fromProjective reMat))
+ r re = norm $ (Vec3 (reBoundRadius re) 0 0) .* (trim (fromProjective reMat) :: Mat3)
+ rel' = [re | re <- rel, sphereInFrustum p (r re) camFrustum],
+ not (null rel')]
+ --putStrLn $ "full: " ++ (show $ length (fsRenderable fs)) ++ " culled: " ++ (show $ length culledScene)
+ -- render objects
+ rstat <- renderQueue time rs wrRenderOptions emptyRenderStatistics (fsLight fs) culledScene
+ -- print rstat
+
+ -- Compositor
+ -- TargetPass
+ -- Pass
+ forM_ (vpCompositors v) $ \c -> do
+ let ct = head $ fromMaybe (error "fromJust 112") $ cmpSupportedTechniques c
+ -- select first technique
+ forM (ctTargetPasses ct ++ [ctOutputTarget ct]) $ \ctp -> do
+ -- -- copy previous output to target's output when input is previous
+ when (ctpInputMode ctp == IM_PREVIOUS) $ do
+ -- FIXME
+ dirtyHackCopyTexImage rs (fromMaybe (error "fromJust 212") $ tdTexture $ fromJust $ ctpOutput ctp) vx vy vw vh
+ forM (ctpPasses ctp) $ \cp -> do
+ -- do composition pass action
+ case cpType cp of
+ PT_RENDERQUAD -> do
+ -- TODO
+ -- setup quad material
+ -- render quad
+ let quadM = fromMaybe (error "fromJust 312") $ Map.lookup "Quad.mesh.xml" (rlMeshMap wrResource)
+ quadSM = head $ msSubMeshList quadM
+ quadSE = SubEntity { seMaterial = fromMaybe (error "fromJust 412") $ cpMaterial cp, seSubMesh = quadSM }
+ quadE = Entity "" (fromEnum RQP_Main) quadM [quadSE]
+ quadRE = head $ prepare idmtx quadE
+ quadRP = [RenderablePass (reOperation quadRE) p idmtx [(idmtx,defaultLight)] | p <- rePassList quadRE]
+ defaultLight = Light
+ { lgType = LT_POINT
+ , lgDiffuse = (1,1,1,1)
+ , lgDirection = Vec3 0 0 1
+ , lgSpecular = (0,0,0,0)
+ , lgSpotOuter = pi / 180 * 40
+ , lgSpotFalloff = 1
+ , lgRange = 100000
+ , lgAttenuationConst = 1
+ , lgAttenuationLinear = 0
+ , lgAttenuationQuad = 0
+ }
+ setProjectionMatrix rs idmtx
+ setViewMatrix rs idmtx
+ setWorldMatrix rs idmtx
+ setPolygonMode rs PM_SOLID
+ renderPassGroup time rs emptyRenderStatistics quadRP
+ return ()
+ _ -> return ()
+ {-
+ unless (null $ vpCompositors v) $ do
+ -- FIXME: TEMP CODE
+ -- unbind render texture, and we'll have the rendered scene in a texture
+ -- create a custom temp pass with temp render texture input
+ -- create quad render operation
+ let quadSM = head $ msSubMeshList $ fromJust $ Map.lookup "Quad.mesh.xml" (rlMeshMap $ wrResource world)
+ quadRO = RenderOperation
+ { roVertexData = fromJust $ smVertexData quadSM
+ , roOperationType = smOperationType quadSM
+ , roIndexData = smIndexData quadSM
+ }
+ quadP = head $ tchPasses $ head $ fromJust $ mtSupportedTechniques $ fromJust $ Map.lookup "QuadMaterial" (rlMaterialMap $ wrResource world)
+ quadRP = RenderablePass
+ { rpOperation = quadRO
+ , rpPass = quadP'
+ , rpMatrix = transl 0 0 0
+ , rpLights = []
+ }
+ rtex = fromJust $ Map.lookup "RenderTex01" $ (rlTextureMap $ wrResource world)
+ tus = psTextureUnitStates quadP
+ tu = head tus
+ tut = tail tus
+ tu' = tu { tusFrames = Just [rtex] }
+ quadP' = quadP { psTextureUnitStates = (tu':tut) }
+ --setProjectionMatrix rs $ cameraProjectionMatrix (fromIntegral vw / fromIntegral vh) cam
+ setProjectionMatrix rs $ transl 0 0 0
+ setViewMatrix rs $ transl 0 0 0
+ dirtyHackCopyTexImage rs rtex vx vy vw vh
+ setPolygonMode rs PM_SOLID
+ renderPassGroup rs [quadRP]
+ -- invert back
+ --dirtyHackCopyTexImage rs rtex vx vy vw vh
+ -} --renderPassGroup rs [quadRP]
+
+ -- TODO
+ -- collect all render textures
+ -- render the world on all render textures
+ -- render the world last to the given named target
+
+ -- forall viewports:
+ -- setup viewport related matrices
+ -- render scene
+ case Map.lookup name wrTargets of
+ Nothing -> debugLCM "renderWold" $ "RenderTarget not found: " ++ name
+ Just t -> do
+ let targets = Map.elems wrTargets
+ (tg,tgs) = partition ((== name) . rtName) targets
+ (rtl,rwl) = partition (isNothing . rtTexture) tgs
+ liftIO $ prepareRender rs >> mapM_ renderTarget (rtl ++ rwl ++ tg) >> finishRender rs
+{-
+ = RenderOperation
+ { roVertexData :: VertexData vb -- ^ Vertex source data
+ , roOperationType :: OperationType -- ^ The type of operation to perform
+ , roIndexData :: Maybe (IndexData ib) -- ^ Index data - only valid if useIndexes is true
+ }
+ = RenderablePass
+ { rpOperation :: RenderOperation vb ib
+ , rpPass :: Pass t lp
+ , rpMatrix :: Matrix4
+ , rpLights :: [(Matrix4,Light)]
+ }
+--renderPassGroup :: RenderSystem -> RenderablePass -> IO ()
+-}
+ -- do a manual render for temp pass (we should reset world, view, projection and texture matrix)
+
+
+---------------------------------------------------------------------
+ -- push flatten scene into a render queue
+ -- collect lights which affect each renderable
+ -- fold addRenderable
+ -- call renderQueue
+ --let addRend (m,rend,grpID,prior) rq = addRenderable m rend (map snd $ fsLight fs) grpID prior rq
+ --renderQueue' rs $ foldr addRend emptyRenderQueue $ fsRenderable fs
+ -- old code below-------------------------------------------------------------------------------------------
+ --mapM_ (renderEntity (wrRenderSystem world)) $ optimize $ foldr (\(m,r) l -> (prepare m r) ++ l) [] [(a,b) | (a,b,_,_) <- fsRenderable fs]
+
+-- | Create a new texture.
+addRenderTexture :: RenderSystem r vb ib q a p lp
+ => String -- ^ The name of the texture.
+ -> Int -- ^ Width in texels.
+ -> Int -- ^ Height in texels.
+ -> LCM (World r vb ib q a p lp) e ()
+addRenderTexture n w h = do
+ World { wrRenderSystem, wrResource } <- peekLCM
+ let tm = rlTextureMap wrResource
+ t <- liftIO $ createTexture wrRenderSystem n TEX_TYPE_2D w h 1 (MIP_NUMBER 1) PF_R8G8B8A8 (TextureUsage HBU_STATIC True False) False 0 "" Nothing
+ updateResource $ \rl -> rl { rlTextureMap = Map.insert n t tm }
+
+-- | Specify the viewports to display in the window.
+addRenderWindow :: RenderSystem r vb ib q t p lp
+ => String -- ^ The name of the window.
+ -> Int -- ^ The width of the window in pixels.
+ -> Int -- ^ The height of the window in pixels.
+ -> [LCM (World r vb ib q t p lp) e (Viewport t lp)] -- ^ The actions describing the viewports to use.
+ -> LCM (World r vb ib q t p lp) e ()
+addRenderWindow n w h l = do
+ vl <- sequence l
+ let rt = RenderTarget
+ { rtName = n
+ , rtWidth = w
+ , rtHeight = h
+ , rtViewport = vl
+ , rtTexture = Nothing
+ }
+ updateWorld (mapTargets (Map.insert n rt))
+
+ {-
+ = Compositor
+ { cmpName :: String
+ , cmpTechniques :: [CompositionTechnique t]
+ , cmpSupportedTechniques :: Maybe [CompositionTechnique t]
+ }
+
+ = CompositionTechnique
+ { ctTextureDefinitions :: [TextureDefinition t]
+ , ctTargetPasses :: [CompositionTargetPass] -- ^ Intermediate target passes
+ , ctOutputTarget :: CompositionTargetPass -- ^ Output target pass (can be only one)
+ , ctSchemeName :: String -- ^ Optional scheme name
+ }
+
+ = TextureDefinition
+ { tdName :: String
+ , tdWidth :: Maybe Int -- Nothing means adapt to target width
+ , tdHeight :: Maybe Int -- Nothing means adapt to target height
+ , tdWidthFactor :: FloatType -- multiple of target width to use (if width = Nothing)
+ , tdHeightFactor :: FloatType -- multiple of target height to use (if height = Nothing)
+ , tdFormatList :: [PixelFormat] -- more than one means MRT
+ , tdFsaa :: Bool -- FSAA enabled; true = determine from main target (if render_scene), false = disable
+ , tdHwGammaWrite :: Bool -- Do sRGB gamma correction on write (only 8-bit per channel formats)
+ , tdShared :: Bool -- whether to use shared textures for this one
+ , tdTexture :: Maybe t
+ }
+
+ = CompositionTargetPass
+ { ctpInputMode :: InputMode -- ^ Input name
+ , ctpOutputName :: String -- ^ (local) output texture
+ , ctpOutput :: Maybe (TextureDefinition t)
+ , ctpPasses :: [CompositionPass] -- ^ Passes
+ , ctpOnlyInitial :: Bool -- ^ This target pass is only executed initially after the effect has been enabled.
+ , ctpVisibilityMask :: Word32 -- ^ Visibility mask for this render
+ , ctpLodBias :: FloatType -- ^ LOD bias of this render
+ , ctpMaterialScheme :: String -- ^ Material scheme name
+ , ctpShadowsEnabled :: Bool -- ^ Shadows option
+ }
+
+ = InputTex
+ { itName :: String -- ^ Name (local) of the input texture
+ , itMrtIndex :: Int -- ^ MRT surface index if applicable
+ }
+
+ = CompositionPass
+ { cpType :: PassType -- ^ Type of composition pass
+ , cpIdentifier :: Word32 -- ^ Identifier for this pass
+ , cpMaterialName :: String -- ^ Material used for rendering
+ , cpMaterial :: Maybe (Material t lp)
+ , cpFirstRenderQueue :: Int -- ^ [first,last] render queue to render this pass (in case of PT_RENDERSCENE)
+ , cpLastRenderQueue :: Int
+ , cpClearBuffers :: (Bool,Bool,Bool) -- ^ Clear buffers (in case of PT_CLEAR), hint: [colour] [depth] [stencil]
+ , cpClearColour :: ColourValue -- ^ Clear colour (in case of PT_CLEAR)
+ , cpClearDepth :: FloatType -- ^ Clear depth (in case of PT_CLEAR)
+ , cpClearStencil :: Word32 -- ^ Clear stencil value (in case of PT_CLEAR)
+ , cpInputs :: IntMap InputTex -- ^ Inputs (for material used for rendering the quad)
+ , cpStencilCheck :: Bool -- ^ Stencil operation parameters
+ , cpStencilFunc :: CompareFunction
+ , cpStencilRefValue :: Word32
+ , cpStencilMask :: Word32
+ , cpStencilFailOp :: StencilOperation
+ , cpStencilDepthFailOp :: StencilOperation
+ , cpStencilPassOp :: StencilOperation
+ , cpStencilTwoSidedOperation :: Bool
+ , cpQuadCornerModified :: Bool -- ^ true if quad should not cover whole screen
+ , cpQuadLeft :: FloatType -- ^ quad positions in normalised coordinates [-1;1]x[-1;1] (in case of PT_RENDERQUAD)
+ , cpQuadTop :: FloatType
+ , cpQuadRight :: FloatType
+ , cpQuadBottom :: FloatType
+ , cpQuadFarCorners :: Bool
+ , cpQuadFarCornersViewSpace :: Bool
+ }
+
+data PassType
+ = PT_CLEAR -- ^ Clear target to one colour
+ | PT_STENCIL -- ^ Set stencil operation
+ | PT_RENDERSCENE -- ^ Render the scene or part of it
+ | PT_RENDERQUAD -- ^ Render a full screen quad
+ -}
+
+-- | Create render textures, and setup compositor chain.
+mkCompositorChain :: RenderSystem r vb ib q t p lp => [Compositor t lp] -> LCM (World r vb ib q t p lp) e [Compositor t lp]
+mkCompositorChain cl = do
+ rs <- wrRenderSystem <$> peekLCM
+ -- do we really need this ???? -- HINT: add an implicit target to first compositor which renders the scene into a viewportsized texture,
+ -- iterate trough compositors and select first supported technique
+ let initCompositor c = catchLCM $ do -- :: (World,[Maybe Compositor]) -> Compositor -> (World,[Maybe Compositor])
+ -- TODO: select first supported technique
+ let ct = head $ cmpTechniques c
+ tds <- forM (ctTextureDefinitions ct) $ \td -> do
+ -- create render textures
+ let w = fromMaybe 1 $ tdWidth td
+ h = fromMaybe 1 $ tdHeight td
+ txn = (cmpName c ++ "/" ++ tdName td)
+ t <- liftIO $ createTexture rs txn TEX_TYPE_2D w h 1 (MIP_NUMBER 1) (head $ tdFormatList td) (TextureUsage HBU_STATIC True False) False 0 "" Nothing
+ debugLCM "Initialize Compositor" $ "Created compositor texture: " ++ txn
+ return td { tdTexture = Just t }
+
+ let texmap = Map.fromList [(tdName td,td) | td <- tds]
+ onamel = map ctpOutputName $ ctTargetPasses ct
+ outtexl = [Map.lookup o texmap | o <- onamel]
+ checkTex tn = unless (Map.member tn texmap) $ do
+ errorLCM "Initialize Compositor" $ "Unknown compositor texture: " ++ tn
+ throwLCM Nothing
+
+ forM_ onamel checkTex
+
+ -- setup compositor target pass output
+ let initPasses tp = do
+ pl <- forM (ctpPasses tp) $ \cp -> case cpType cp of
+ PT_RENDERQUAD -> do
+ -- setup composition pass input
+ -- load material
+ mmat@ ~(Just mat) <- getLoadedMaterial (cpMaterialName cp)
+ when (isNothing mmat) $ throwLCM Nothing
+
+ -- check pass input texture names
+ forM_ [itName it | it <- IntMap.elems $ cpInputs cp] checkTex
+
+ -- foreach material pass and for each textureunitstate
+ -- setup texture when it's a RT
+ let fp p = p { psTextureUnitStates = tul' }
+ where
+ tul' = [tu { tusFrames = fromMaybe (tusFrames tu) (ft i) } | (i,tu) <- tusl]
+ ft i = case IntMap.lookup i (cpInputs cp) of
+ Nothing -> Nothing
+ Just it -> Just $ Just [fromJust $ tdTexture $ texmap Map.! (itName it)]
+ tusl = zip [0..] $ psTextureUnitStates p
+ mat' = mat { mtSupportedTechniques = Just [tch { tchPasses = [fp p | p <- tchPasses tch] } | tch <- fromJust $ mtSupportedTechniques mat] }
+ --return with modified pass attached to the list
+ return (cp { cpMaterial = Just mat' })
+ _ -> return cp
+ return (tp { ctpPasses = pl })
+
+ tps <- forM [tp { ctpOutput = o } | (o,tp) <- zip outtexl (ctTargetPasses ct)] initPasses
+ otp <- initPasses (ctOutputTarget ct)
+ let ct' = ct { ctTextureDefinitions = tds, ctTargetPasses = tps, ctOutputTarget = otp }
+ return (Just c { cmpSupportedTechniques = Just [ct'] })
+
+ -- setup compositor target pass input
+ -- TODO: setup compositor chain connection
+ catMaybes <$> forM cl initCompositor
+
+-- | Create a viewport and attach given compositors.
+viewport :: RenderSystem r vb ib q t p lp
+ => FloatType -- ^ Viewport x position.
+ -> FloatType -- ^ Viewport y position.
+ -> FloatType -- ^ Viewport width.
+ -> FloatType -- ^ Viewport height.
+ -> String -- ^ The camera associated with the viewport.
+ -> [String] -- ^ The compositor chain to process the image with.
+ -> LCM (World r vb ib q t p lp) e (Viewport t lp)
+viewport x y w h cam cnl = do
+ compMap <- rlCompositorMap . wrResource <$> peekLCM
+ -- collect compositors
+ let getCompositor l cn = case Map.lookup cn compMap of
+ Nothing -> do
+ errorLCM "ApplyCompositor" $ "Unknown compositor: " ++ cn
+ return l
+ Just c -> return $ c:l
+
+ -- setup compositor chain
+ cl0 <- foldM' getCompositor [] cnl
+ cl1 <- mkCompositorChain (reverse cl0)
+ return Viewport
+ { vpLeft = x
+ , vpTop = y
+ , vpWidth = w
+ , vpHeight = h
+ , vpCamera = cam
+ , vpCompositors = cl1
+ , vpBackColour = (0,0,0,0)
+ , vpClearEveryFrame = True
+ , vpClearBuffers = FrameBufferType True True False
+ }
+
+-- | Adjust the dimensions of a given render target.
+updateTargetSize :: RenderSystem rs vb ib q t p lp
+ => String -- ^ The target to adjust.
+ -> Int -- ^ The new width.
+ -> Int -- ^ The new height.
+ -> LCM (World rs vb ib q t p lp) e ()
+updateTargetSize n w h = updateWorld (mapTargets (Map.adjust f n))
+ where
f t = t { rtWidth = w, rtHeight = h }
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright (c) 2009, Csaba Hruska
+Copyright (c) 2009-2011, Csaba Hruska
All rights reserved.
Redistribution and use in source and binary forms, with or without
diff --git a/README b/README
--- a/README
+++ b/README
@@ -16,3 +16,78 @@
You can use the addConfig function (found in comments in all the
examples) to load this file.
+
+
+Internals:
+ Internals overview:
+ ...
+
+ render pipeline:
+ Scene -> FlattenScene -> RenderQueue -> RenderablePass
+ |-> Light |-> Light (optimize - setup light and pass
+ |-> Camera |-> Camera render - render each RenderOperation (call RenderSystem's render function)
+ |-> Entity |-> RenderEntity operations)
+
+ for each RenderTarget
+ renderViewport
+
+ data types:
+ - RenderSystem related typeclasses
+ - HardwareBuffer
+ - HardwareVertexBuffer
+ - HardwareIndexBuffer
+ - Texture
+ - GpuProgram
+ - LinkedGpuProgram
+ - RenderSystemCapabilities
+ - World (top level data structure)
+ low level model data types:
+ - VertexData
+ - IndexData
+ - VertexDeclaration
+ - VertexBufferBinding
+ high level model data types:
+ - SubMesh
+ - Mesh
+ - VectorVertexData
+ material data types:
+ - Material
+ - Technique
+ - Pass
+ - TextureUnitState
+ scene related data types:
+ - FlattenScene
+ - SceneObject
+ - Entity
+ - SubEntity
+ - Camera
+ - Light
+ - SceneNode
+ - Scene
+ - MkSceneObjectAction
+ - MkNodeAction
+ - Frustum
+ high level render related data types:
+ - Compositor
+ - RenderTarget
+ - Viewport
+ -
+ low level rendering related data types:
+ - Renderable (type class)
+ - RenderEntity
+ - RenderOperation
+ - RenderablePass
+ -
+ resource related data types:
+ - ResourceLibrary
+ -
+
+User Guide:
+ - lambdacube is a rendering engine, does not care with window management and input handling.
+ - usage:
+ - create render system
+ - create world:
+ - init world with render system and resource paths and loaders
+ - create the scene
+ - render loop:
+ - derive a world data for each new frame, with required world modifications
diff --git a/lambdacube-engine.cabal b/lambdacube-engine.cabal
--- a/lambdacube-engine.cabal
+++ b/lambdacube-engine.cabal
@@ -1,114 +1,121 @@
name: lambdacube-engine
-version: 0.1.2
+version: 0.2.1
cabal-version: >= 1.6 && < 2
build-type: Simple
license: BSD3
license-file: LICENSE
-author: Csaba Hruska
+author: Csaba Hruska, Gergely Patai
maintainer: csaba (dot) hruska (at) gmail (dot) com
stability: experimental
homepage: http://www.haskell.org/haskellwiki/LambdaCubeEngine
+bug-reports: http://code.google.com/p/lambdacube/issues
category: Graphics
-tested-with: GHC == 6.10.1, GHC == 6.10.4
-synopsis: 3D rendering engine entirely written in Haskell
-description:
+tested-with: GHC == 6.10.1, GHC == 6.10.4, GHC == 7.0.3
+synopsis: 3D rendering engine written entirely in Haskell
+description:
LambdaCube is a 3D rendering engine written entirely in Haskell.
It targets newer graphics hardware. The engine uses Ogre3D's mesh
and material file format. The main goal of this project is to
provide a modern and feature rich graphical backend for various
- haskell projects (e.g. FRP libraries).
+ Haskell projects (e.g. FRP libraries).
+ .
+ While the interface looks huge on the surface, the only part of
+ interest to application developers is the "Graphics.LambdaCube"
+ module, and possibly "Graphics.LambdaCube.Loader.StbImage". The
+ rest is only exposed to make low-level interfacing possible.
extra-source-files:
CHANGES
README
- Graphics/LambdaCube/Loader/Makefile
Graphics/LambdaCube/Loader/CompositorScriptScanner.x
Graphics/LambdaCube/Loader/FontDefinitionScriptScanner.x
+ Graphics/LambdaCube/Loader/Makefile
Graphics/LambdaCube/Loader/MaterialScriptScanner.x
Graphics/LambdaCube/Loader/OverlayScriptScanner.x
Graphics/LambdaCube/Loader/ResourceScriptScanner.x
library
- build-depends:
+ build-depends:
+ OpenGLRaw,
+ vect >= 0.4.6 && < 1,
+ array >= 0.2.0.0 && < 1,
base >= 4.0.0.0 && < 5,
- zip-archive >= 0.1.1.3 && < 1,
binary >= 0.5.0.1 && < 1,
- uulib >= 0.9.10 && < 1,
- OpenGL >= 2.2.3 && < 3,
+ bitmap >= 0.0.1 && < 0.1,
bytestring >= 0.9.1.4 && < 1,
- xml >= 1.3 && < 2,
- stb-image >= 0.1.3 && < 0.2,
- filepath >= 1.1.0.1 && < 2,
- directory >= 1.0.0.2 && < 2,
- array >= 0.2.0.0 && < 1,
containers >= 0.2 && < 1,
- fgl >= 5.4.2.2 && < 6,
- hslogger >= 1.0.7 && < 2
+ directory >= 1.0.0.2 && < 2,
+ filepath >= 1.1.0.1 && < 2,
+ stb-image >= 0.2 && < 0.3,
+ uulib >= 0.9.10 && < 1,
+ vector,
+ vector-algorithms,
+ bytestring-trie >= 0.2 && < 0.3,
+ xml >= 1.3 && < 2,
+ zip-archive >= 0.1.1.3 && < 1,
+ mtl >= 2 && < 3
exposed-modules:
Graphics.LambdaCube
+ Graphics.LambdaCube.AnimationState
+ Graphics.LambdaCube.BlendMode
+ Graphics.LambdaCube.Common
Graphics.LambdaCube.Compositor
--- Graphics.LambdaCube.HardwareBufferManager
- Graphics.LambdaCube.World
- Graphics.LambdaCube.Light
+ Graphics.LambdaCube.Entity
+ Graphics.LambdaCube.Frustum
Graphics.LambdaCube.GpuProgram
--- Graphics.LambdaCube.MovableObject
- Graphics.LambdaCube.TextureUnitState
- Graphics.LambdaCube.VertexIndexData
Graphics.LambdaCube.GpuProgramParams
- Graphics.LambdaCube.Types
- Graphics.LambdaCube.Image
--- Graphics.LambdaCube.HardwarePixelBuffer
- Graphics.LambdaCube.Common
- Graphics.LambdaCube.HardwareIndexBuffer
- Graphics.LambdaCube.Texture
--- Graphics.LambdaCube.ParticleSystem
- Graphics.LambdaCube.Technique
Graphics.LambdaCube.GpuProgramUsage
- Graphics.LambdaCube.PixelFormat
- Graphics.LambdaCube.AnimationState
- Graphics.LambdaCube.Pass
- Graphics.LambdaCube.Material
- Graphics.LambdaCube.RenderSystemCapabilities
--- Graphics.LambdaCube.Overlay
--- Graphics.LambdaCube.Loader.ParticleSystemScript
+ Graphics.LambdaCube.HardwareBuffer
+ Graphics.LambdaCube.HardwareIndexBuffer
+ Graphics.LambdaCube.HardwareOcclusionQuery
+ Graphics.LambdaCube.HardwareVertexBuffer
+ Graphics.LambdaCube.Image
+ Graphics.LambdaCube.Light
+ Graphics.LambdaCube.Loader.CompositorScript
Graphics.LambdaCube.Loader.Generated.CompositorScriptScanner
- Graphics.LambdaCube.Loader.Generated.ResourceScriptScanner
--- Graphics.LambdaCube.Loader.Generated.FontDefinitionScriptScanner
Graphics.LambdaCube.Loader.Generated.MaterialScriptScanner
--- Graphics.LambdaCube.Loader.Generated.OverlayScriptScanner
- Graphics.LambdaCube.Loader.MeshXML
+ Graphics.LambdaCube.Loader.Generated.ResourceScriptScanner
Graphics.LambdaCube.Loader.MaterialScript
--- Graphics.LambdaCube.Loader.LMeshBinary
+ Graphics.LambdaCube.Loader.MeshXML
Graphics.LambdaCube.Loader.ParserUtil
--- Graphics.LambdaCube.Loader.OverlayScript
- Graphics.LambdaCube.Loader.CompositorScript
- Graphics.LambdaCube.Loader.StbImage
Graphics.LambdaCube.Loader.ResourceScript
- Graphics.LambdaCube.Math
- Graphics.LambdaCube.SceneGraph
- Graphics.LambdaCube.HardwareBuffer
- Graphics.LambdaCube.Resource
+ Graphics.LambdaCube.Loader.SkeletonXML
+ Graphics.LambdaCube.Loader.StbImage
+ Graphics.LambdaCube.Material
Graphics.LambdaCube.Mesh
- Graphics.LambdaCube.RenderSystem
+ Graphics.LambdaCube.MeshUtil
+ Graphics.LambdaCube.Pass
+ Graphics.LambdaCube.PixelFormat
+ Graphics.LambdaCube.RenderOperation
Graphics.LambdaCube.RenderQueue
- Graphics.LambdaCube.Frustum
+ Graphics.LambdaCube.RenderSystem
Graphics.LambdaCube.RenderSystem.GL
- Graphics.LambdaCube.RenderSystem.GL.GLGpuProgram
- Graphics.LambdaCube.RenderSystem.GL.GLCapabilities
- Graphics.LambdaCube.RenderSystem.GL.GLTexture
- Graphics.LambdaCube.RenderSystem.GL.GLUtils
- Graphics.LambdaCube.RenderSystem.GL.GLOcclusionQuery
- Graphics.LambdaCube.RenderSystem.GL.GLRenderSystem
- Graphics.LambdaCube.RenderSystem.GL.GLVertexBuffer
- Graphics.LambdaCube.RenderSystem.GL.GLIndexBuffer
- Graphics.LambdaCube.Entity
- Graphics.LambdaCube.HardwareVertexBuffer
- Graphics.LambdaCube.BlendMode
- Graphics.LambdaCube.RenderOperation
+ Graphics.LambdaCube.RenderSystem.GL.Capabilities
+ Graphics.LambdaCube.RenderSystem.GL.GpuProgram
+ Graphics.LambdaCube.RenderSystem.GL.IndexBuffer
+ Graphics.LambdaCube.RenderSystem.GL.OcclusionQuery
+ Graphics.LambdaCube.RenderSystem.GL.RenderSystem
+ Graphics.LambdaCube.RenderSystem.GL.Texture
+ Graphics.LambdaCube.RenderSystem.GL.Utils
+ Graphics.LambdaCube.RenderSystem.GL.VertexBuffer
+ Graphics.LambdaCube.RenderSystemCapabilities
+ Graphics.LambdaCube.Resource
+ Graphics.LambdaCube.SceneGraph
+ Graphics.LambdaCube.Skeleton
+ Graphics.LambdaCube.Technique
+ Graphics.LambdaCube.Texture
+ Graphics.LambdaCube.TextureUnitState
+ Graphics.LambdaCube.Tree
+ Graphics.LambdaCube.Types
Graphics.LambdaCube.Utility
- Graphics.LambdaCube.HardwareOcclusionQuery
+ Graphics.LambdaCube.VertexBufferVector
+ Graphics.LambdaCube.VertexIndexData
+ Graphics.LambdaCube.World
--- Graphics.LambdaCube
--- Graphics.LambdaCube.Loader.StbImage
--- Graphics.LambdaCube.RenderSystem.GL
+-- Graphics.LambdaCube.Loader.Generated.FontDefinitionScriptScanner
+-- Graphics.LambdaCube.Loader.Generated.OverlayScriptScanner
+-- Graphics.LambdaCube.Loader.OverlayScript
+-- Graphics.LambdaCube.Loader.ParticleSystemScript
+-- Graphics.LambdaCube.Overlay
+-- Graphics.LambdaCube.ParticleSystem
- ghc-options: -O2 -Wall
+ ghc-options: -O2 -fspec-constr-count=12 -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing