diff --git a/GLUT.cabal b/GLUT.cabal --- a/GLUT.cabal +++ b/GLUT.cabal @@ -1,185 +1,197 @@ -name: GLUT -version: 2.5.0.0 -license: BSD3 -license-file: LICENSE -maintainer: Sven Panne , Jason Dagit -bug-reports: https://github.com/haskell-opengl/GLUT/issues -homepage: http://www.haskell.org/haskellwiki/Opengl -category: Graphics -synopsis: A binding for the OpenGL Utility Toolkit -description: - A Haskell binding for the OpenGL Utility Toolkit, a window system independent - toolkit for writing OpenGL programs. For more information about the C library - on which this binding is based, please see: - . -build-type: Simple -cabal-version: >=1.6 -extra-source-files: - README.md - examples/BOGLGP/Chapter01/Makefile - examples/BOGLGP/Chapter01/OnYourOwn1.hs - examples/BOGLGP/Chapter01/Simple.hs - examples/BOGLGP/Chapter02/Makefile - examples/BOGLGP/Chapter02/OnYourOwn1.hs - examples/BOGLGP/Chapter02/OpenGLApplication.hs - examples/BOGLGP/Chapter03/Lines.hs - examples/BOGLGP/Chapter03/Makefile - examples/BOGLGP/Chapter03/OnYourOwn1.hs - examples/BOGLGP/Chapter03/Points.hs - examples/BOGLGP/Chapter03/Polygons.hs - examples/BOGLGP/Chapter03/TrianglesQuads.hs - examples/BOGLGP/Makefile - examples/Makefile - examples/Misc/ARBOcclude.hs - examples/Misc/ExtractContours.hs - examples/Misc/Gears.hs - examples/Misc/Makefile - examples/Misc/Pitfall14.hs - examples/Misc/SmoothOpenGL3.hs - examples/Misc/Triangulate.hs - examples/OrangeBook/3Dlabs-License.txt - examples/OrangeBook/Makefile - examples/OrangeBook/ogl2brick/Brick.frag - examples/OrangeBook/ogl2brick/Brick.hs - examples/OrangeBook/ogl2brick/Brick.vert - examples/OrangeBook/ogl2brick/Makefile - examples/RedBook4/00-README - examples/RedBook4/AAIndex.hs - examples/RedBook4/AARGB.hs - examples/RedBook4/AccAnti.hs - examples/RedBook4/AccPersp.hs - examples/RedBook4/Alpha.hs - examples/RedBook4/Alpha3D.hs - examples/RedBook4/BezCurve.hs - examples/RedBook4/BezMesh.hs - examples/RedBook4/BezSurf.hs - examples/RedBook4/BlendEqn.hs - examples/RedBook4/Checker.hs - examples/RedBook4/Clip.hs - examples/RedBook4/ColorMat.hs - examples/RedBook4/ColorMatrix.hs - examples/RedBook4/ColorTable.hs - examples/RedBook4/Combiner.hs - examples/RedBook4/Convolution.hs - examples/RedBook4/Cube.hs - examples/RedBook4/CubeMap.hs - examples/RedBook4/DList.hs - examples/RedBook4/DOF.hs - examples/RedBook4/Data/leeds.bin - examples/RedBook4/Double.hs - examples/RedBook4/DrawF.hs - examples/RedBook4/Feedback.hs - examples/RedBook4/Fog.hs - examples/RedBook4/FogCoord.hs - examples/RedBook4/FogIndex.hs - examples/RedBook4/Font.hs - examples/RedBook4/Hello.hs - examples/RedBook4/Histogram.hs - examples/RedBook4/Image.hs - examples/RedBook4/Light.hs - examples/RedBook4/Lines.hs - examples/RedBook4/MVArray.hs - examples/RedBook4/Makefile - examples/RedBook4/Material.hs - examples/RedBook4/Minmax.hs - examples/RedBook4/Mipmap.hs - examples/RedBook4/Model.hs - examples/RedBook4/MoveLight.hs - examples/RedBook4/MultiTex.hs - examples/RedBook4/Multisamp.hs - examples/RedBook4/PickDepth.hs - examples/RedBook4/PickSquare.hs - examples/RedBook4/Planet.hs - examples/RedBook4/PointP.hs - examples/RedBook4/PolyOff.hs - examples/RedBook4/Polys.hs - examples/RedBook4/Quadric.hs - examples/RedBook4/ReadImage.hs - examples/RedBook4/Robot.hs - examples/RedBook4/Scene.hs - examples/RedBook4/Select.hs - examples/RedBook4/ShadowMap.hs - examples/RedBook4/Smooth.hs - examples/RedBook4/Stencil.hs - examples/RedBook4/Stroke.hs - examples/RedBook4/SurfPoints.hs - examples/RedBook4/Surface.hs - examples/RedBook4/Teapots.hs - examples/RedBook4/Tess.hs - examples/RedBook4/TessWind.hs - examples/RedBook4/TexBind.hs - examples/RedBook4/TexGen.hs - examples/RedBook4/TexProx.hs - examples/RedBook4/TexSub.hs - examples/RedBook4/Texture3D.hs - examples/RedBook4/TextureSurf.hs - examples/RedBook4/Torus.hs - examples/RedBook4/Trim.hs - examples/RedBook4/UnProject.hs - examples/RedBook4/VArray.hs - examples/RedBook4/Wrap.hs - examples/examples.mk - include/HsGLUTExt.h - -flag split-base - -flag UseNativeWindowsLibraries - description: - When compiling under Windows, use the native libraries instead of e.g. the - ones coming with Cygwin. - -library - exposed-modules: - Graphics.UI.GLUT, - Graphics.UI.GLUT.Begin, - Graphics.UI.GLUT.Callbacks, - Graphics.UI.GLUT.Callbacks.Global, - Graphics.UI.GLUT.Callbacks.Window, - Graphics.UI.GLUT.Colormap, - Graphics.UI.GLUT.Debugging, - Graphics.UI.GLUT.DeviceControl, - Graphics.UI.GLUT.Fonts, - Graphics.UI.GLUT.GameMode, - Graphics.UI.GLUT.Initialization, - Graphics.UI.GLUT.Menu, - Graphics.UI.GLUT.Objects, - Graphics.UI.GLUT.Overlay, - Graphics.UI.GLUT.State, - Graphics.UI.GLUT.Window - other-modules: - Graphics.UI.GLUT.Callbacks.Registration, - Graphics.UI.GLUT.QueryUtils, - Graphics.UI.GLUT.Raw, - Graphics.UI.GLUT.Raw.APIEntry, - Graphics.UI.GLUT.Raw.Callbacks, - Graphics.UI.GLUT.Raw.Fonts, - Graphics.UI.GLUT.Raw.Functions, - Graphics.UI.GLUT.Raw.Tokens, - Graphics.UI.GLUT.Types - include-dirs: include - c-sources: - cbits/HsGLUT.c - if flag(split-base) - build-depends: base >= 3 && < 5, array >= 0.3 && < 0.5, containers >= 0.3 && < 0.6 - else - build-depends: base < 3 - build-depends: OpenGL >= 2.8.0.0, OpenGLRaw >= 1.3.0.0 - ghc-options: -Wall -O2 - if os(windows) && flag(UseNativeWindowsLibraries) - if arch(i386) - cpp-options: "-DCALLCONV=stdcall" - else - cpp-options: "-DCALLCONV=ccall" - cc-options: "-DUSE_GETPROCADDRESS" - extra-libraries: glut32 - else - cpp-options: "-DCALLCONV=ccall" - cc-options: "-DUSE_DLSYM" - if os(darwin) - frameworks: GLUT - else - extra-libraries: glut - -source-repository head - type: git - location: https://github.com/haskell-opengl/GLUT +name: GLUT +version: 2.5.0.1 +license: BSD3 +license-file: LICENSE +maintainer: Sven Panne , Jason Dagit +bug-reports: https://github.com/haskell-opengl/GLUT/issues +homepage: http://www.haskell.org/haskellwiki/Opengl +category: Graphics +synopsis: A binding for the OpenGL Utility Toolkit +description: + A Haskell binding for the OpenGL Utility Toolkit, a window system independent + toolkit for writing OpenGL programs. For more information about the C library + on which this binding is based, please see: + . +build-type: Simple +cabal-version: >=1.6 +extra-source-files: + README.md + examples/00-README + examples/BOGLGP/00-README + examples/BOGLGP/Chapter01/Makefile + examples/BOGLGP/Chapter01/OnYourOwn1.hs + examples/BOGLGP/Chapter01/Simple.hs + examples/BOGLGP/Chapter02/Makefile + examples/BOGLGP/Chapter02/OnYourOwn1.hs + examples/BOGLGP/Chapter02/OpenGLApplication.hs + examples/BOGLGP/Chapter03/Lines.hs + examples/BOGLGP/Chapter03/Makefile + examples/BOGLGP/Chapter03/OnYourOwn1.hs + examples/BOGLGP/Chapter03/Points.hs + examples/BOGLGP/Chapter03/Polygons.hs + examples/BOGLGP/Chapter03/TrianglesQuads.hs + examples/BOGLGP/Makefile + examples/Makefile + examples/Misc/00-README + examples/Misc/ARBOcclude.hs + examples/Misc/ExtractContours.hs + examples/Misc/Gears.hs + examples/Misc/Makefile + examples/Misc/Pitfall14.hs + examples/Misc/SmoothOpenGL3.hs + examples/Misc/Triangulate.hs + examples/OrangeBook/00-README + examples/OrangeBook/3Dlabs-License.txt + examples/OrangeBook/Makefile + examples/OrangeBook/ogl2brick/Brick.frag + examples/OrangeBook/ogl2brick/Brick.hs + examples/OrangeBook/ogl2brick/Brick.vert + examples/OrangeBook/ogl2brick/Makefile + examples/RedBook4/00-README + examples/RedBook4/AAIndex.hs + examples/RedBook4/AARGB.hs + examples/RedBook4/AccAnti.hs + examples/RedBook4/AccPersp.hs + examples/RedBook4/Alpha.hs + examples/RedBook4/Alpha3D.hs + examples/RedBook4/BezCurve.hs + examples/RedBook4/BezMesh.hs + examples/RedBook4/BezSurf.hs + examples/RedBook4/BlendEqn.hs + examples/RedBook4/Checker.hs + examples/RedBook4/Clip.hs + examples/RedBook4/ColorMat.hs + examples/RedBook4/ColorMatrix.hs + examples/RedBook4/ColorTable.hs + examples/RedBook4/Combiner.hs + examples/RedBook4/Convolution.hs + examples/RedBook4/Cube.hs + examples/RedBook4/CubeMap.hs + examples/RedBook4/DList.hs + examples/RedBook4/DOF.hs + examples/RedBook4/Data/leeds.bin + examples/RedBook4/Double.hs + examples/RedBook4/DrawF.hs + examples/RedBook4/Feedback.hs + examples/RedBook4/Fog.hs + examples/RedBook4/FogCoord.hs + examples/RedBook4/FogIndex.hs + examples/RedBook4/Font.hs + examples/RedBook4/Hello.hs + examples/RedBook4/Histogram.hs + examples/RedBook4/Image.hs + examples/RedBook4/Light.hs + examples/RedBook4/Lines.hs + examples/RedBook4/MVArray.hs + examples/RedBook4/Makefile + examples/RedBook4/Material.hs + examples/RedBook4/Minmax.hs + examples/RedBook4/Mipmap.hs + examples/RedBook4/Model.hs + examples/RedBook4/MoveLight.hs + examples/RedBook4/MultiTex.hs + examples/RedBook4/Multisamp.hs + examples/RedBook4/PickDepth.hs + examples/RedBook4/PickSquare.hs + examples/RedBook4/Planet.hs + examples/RedBook4/PointP.hs + examples/RedBook4/PolyOff.hs + examples/RedBook4/Polys.hs + examples/RedBook4/Quadric.hs + examples/RedBook4/ReadImage.hs + examples/RedBook4/Robot.hs + examples/RedBook4/Scene.hs + examples/RedBook4/Select.hs + examples/RedBook4/ShadowMap.hs + examples/RedBook4/Smooth.hs + examples/RedBook4/Stencil.hs + examples/RedBook4/Stroke.hs + examples/RedBook4/SurfPoints.hs + examples/RedBook4/Surface.hs + examples/RedBook4/Teapots.hs + examples/RedBook4/Tess.hs + examples/RedBook4/TessWind.hs + examples/RedBook4/TexBind.hs + examples/RedBook4/TexGen.hs + examples/RedBook4/TexProx.hs + examples/RedBook4/TexSub.hs + examples/RedBook4/Texture3D.hs + examples/RedBook4/TextureSurf.hs + examples/RedBook4/Torus.hs + examples/RedBook4/Trim.hs + examples/RedBook4/UnProject.hs + examples/RedBook4/VArray.hs + examples/RedBook4/Wrap.hs + examples/RedBook8/00-README + examples/RedBook8/Chapter01/Makefile + examples/RedBook8/Chapter01/triangles.frac + examples/RedBook8/Chapter01/Triangles.hs + examples/RedBook8/Chapter01/triangles.vert + examples/RedBook8/common/LoadShaders.hs + examples/RedBook8/common/Makefile + examples/RedBook8/Makefile + examples/examples.mk + include/HsGLUTExt.h + +flag split-base + +flag UseNativeWindowsLibraries + description: + When compiling under Windows, use the native libraries instead of e.g. the + ones coming with Cygwin. + +library + exposed-modules: + Graphics.UI.GLUT, + Graphics.UI.GLUT.Begin, + Graphics.UI.GLUT.Callbacks, + Graphics.UI.GLUT.Callbacks.Global, + Graphics.UI.GLUT.Callbacks.Window, + Graphics.UI.GLUT.Colormap, + Graphics.UI.GLUT.Debugging, + Graphics.UI.GLUT.DeviceControl, + Graphics.UI.GLUT.Fonts, + Graphics.UI.GLUT.GameMode, + Graphics.UI.GLUT.Initialization, + Graphics.UI.GLUT.Menu, + Graphics.UI.GLUT.Objects, + Graphics.UI.GLUT.Overlay, + Graphics.UI.GLUT.State, + Graphics.UI.GLUT.Window + other-modules: + Graphics.UI.GLUT.Callbacks.Registration, + Graphics.UI.GLUT.QueryUtils, + Graphics.UI.GLUT.Raw, + Graphics.UI.GLUT.Raw.APIEntry, + Graphics.UI.GLUT.Raw.Callbacks, + Graphics.UI.GLUT.Raw.Fonts, + Graphics.UI.GLUT.Raw.Functions, + Graphics.UI.GLUT.Raw.Tokens, + Graphics.UI.GLUT.Types + include-dirs: include + c-sources: + cbits/HsGLUT.c + if flag(split-base) + build-depends: base >= 3 && < 5, array >= 0.3 && < 0.5, containers >= 0.3 && < 0.6 + else + build-depends: base < 3 + build-depends: OpenGL >= 2.8.0.0, OpenGLRaw >= 1.3.0.0 + ghc-options: -Wall -O2 + if os(windows) && flag(UseNativeWindowsLibraries) + if arch(i386) + cpp-options: "-DCALLCONV=stdcall" + else + cpp-options: "-DCALLCONV=ccall" + cc-options: "-DUSE_GETPROCADDRESS" + extra-libraries: glut32 + else + cpp-options: "-DCALLCONV=ccall" + cc-options: "-DUSE_DLSYM" + if os(darwin) + frameworks: GLUT + else + extra-libraries: glut + +source-repository head + type: git + location: https://github.com/haskell-opengl/GLUT diff --git a/Graphics/UI/GLUT.hs b/Graphics/UI/GLUT.hs --- a/Graphics/UI/GLUT.hs +++ b/Graphics/UI/GLUT.hs @@ -1,386 +1,386 @@ ------------------------------------------------------------------------------ --- | --- Module : Graphics.UI.GLUT --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- A Haskell binding for GLUT, the OpenGL Utility Toolkit, a window system --- independent toolkit for writing OpenGL programs. It includes support for --- the extended functionality available in freeglut (see --- ) and OpenGLUT (see --- ), too. --- ------------------------------------------------------------------------------ - -module Graphics.UI.GLUT ( - -- * Legal stuff - - -- $LegalStuff - - -- * Introduction - - -- $Introduction - - -- ** Background - - -- $Background - - -- ** Design Philosophy - - -- $DesignPhilosophy - - -- ** API Versions - - -- $APIVersions - - -- ** Conventions - - -- $Conventions - - -- ** Terminology - - -- $Terminology - - module Graphics.Rendering.OpenGL, - - module Graphics.UI.GLUT.Initialization, - module Graphics.UI.GLUT.Begin, - module Graphics.UI.GLUT.Window, - module Graphics.UI.GLUT.Overlay, - module Graphics.UI.GLUT.Menu, - module Graphics.UI.GLUT.Callbacks, - module Graphics.UI.GLUT.Colormap, - module Graphics.UI.GLUT.State, - module Graphics.UI.GLUT.Fonts, - module Graphics.UI.GLUT.Objects, - module Graphics.UI.GLUT.Debugging, - module Graphics.UI.GLUT.DeviceControl, - module Graphics.UI.GLUT.GameMode -) where - -import Graphics.Rendering.OpenGL - -import Graphics.UI.GLUT.Initialization -import Graphics.UI.GLUT.Begin -import Graphics.UI.GLUT.Window -import Graphics.UI.GLUT.Overlay -import Graphics.UI.GLUT.Menu -import Graphics.UI.GLUT.Callbacks -import Graphics.UI.GLUT.Colormap -import Graphics.UI.GLUT.State -import Graphics.UI.GLUT.Fonts -import Graphics.UI.GLUT.Objects -import Graphics.UI.GLUT.Debugging -import Graphics.UI.GLUT.DeviceControl -import Graphics.UI.GLUT.GameMode - ------------------------------------------------------------------------------ --- $LegalStuff --- This documentation is heavily based on the man pages of Mark J. Kilgard\'s --- GLUT library. --- --- OpenGL is a trademark of Silicon Graphics, Inc. --- X Window System is a trademark of X Consortium, Inc. --- Spaceball is a registered trademark of Spatial Systems, Inc. --- --- The author has taken care in preparation of this documentation but makes --- no expressed or implied warranty of any kind and assumes no responsibility --- for errors or omissions. No liability is assumed for incidental or --- consequential damages in connection with or arising from the use of --- information or programs contained herein. - ------------------------------------------------------------------------------ --- $Introduction --- The OpenGL Utility Toolkit (GLUT) is a programming interface for writing --- window system independent OpenGL programs. Currently there are --- implementations for the X Window System, the Windows family, OS\/2, and Mac. --- The toolkit supports the following functionality: --- --- * Multiple windows for OpenGL rendering. --- --- * Callback driven event processing. --- --- * Sophisticated input devices. --- --- * An /idle/ routine and timers. --- --- * A simple, cascading pop-up menu facility. --- --- * Utility routines to generate various solid and wire frame objects. --- --- * Support for bitmap and stroke fonts. --- --- * Miscellaneous window management functions, including managing overlays. --- --- This documentation serves as both a specification and a programming guide. --- If you are interested in a brief introduction to programming with GLUT, --- have a look at the relevant parts of and the vast --- amount of books on OpenGL, most of them use GLUT. --- --- The remainder of this section describes GLUT\'s design philosophy and --- usage model. The following sections specify the GLUT routines, grouped by --- functionality. The final sections discuss usage advice and the logical --- programmer visible state maintained by GLUT. - ------------------------------------------------------------------------------ --- $Background --- One of the major accomplishments in the specification of OpenGL was --- the isolation of window system dependencies from OpenGL\'s rendering --- model. The result is that OpenGL is window system independent. --- --- Window system operations such as the creation of a rendering window and the --- handling of window system events are left to the native window system to --- define. Necessary interactions between OpenGL and the window system such as --- creating and binding an OpenGL context to a window are described separately --- from the OpenGL specification in a window system dependent specification. For --- example, the GLX specification describes the standard by which OpenGL --- interacts with the X Window System. --- --- The predecessor to OpenGL is IRIS GL. Unlike OpenGL, IRIS GL /does/ --- specify how rendering windows are created and manipulated. IRIS GL\'s --- windowing interface is reasonably popular largely because it is simple to --- use. IRIS GL programmers can worry about graphics programming without needing --- to be an expert in programming the native window system. Experience also --- demonstrated that IRIS GL\'s windowing interface was high-level enough that --- it could be retargeted to different window systems. Silicon Graphics migrated --- from NeWS to the X Window System without any major changes to IRIS GL\'s --- basic windowing interface. --- --- Removing window system operations from OpenGL is a sound decision because it --- allows the OpenGL graphics system to be retargeted to various systems --- including powerful but expensive graphics workstations as well as --- mass-production graphics systems like video games, set-top boxes for --- interactive television, and PCs. --- --- Unfortunately, the lack of a window system interface for OpenGL is a gap in --- OpenGL\'s utility. Learning native window system APIs such as the X Window --- System\'s Xlib or Motif can be daunting. Even those familiar with --- native window system APIs need to understand the interface that binds OpenGL --- to the native window system. And when an OpenGL program is written using the --- native window system interface, despite the portability of the program\'s --- OpenGL rendering code, the program itself will be window system dependent. --- --- Testing and documenting OpenGL\'s functionality lead to the development of --- the @tk@ and @aux@ toolkits. The @aux@ toolkit is used in the examples found --- in the /OpenGL Programming Guide/. Unfortunately, @aux@ has numerous --- limitations and its utility is largely limited to toy programs. The @tk@ --- library has more functionality than @aux@ but was developed in an /ad hoc/ --- fashion and still lacks much important functionality that IRIS GL programmers --- expect, like pop-up menus and overlays. --- --- GLUT is designed to fill the need for a window system independent programming --- interface for OpenGL programs. The interface is designed to be simple yet --- still meet the needs of useful OpenGL programs. Features from the IRIS GL, --- @aux@, and @tk@ interfaces are included to make it easy for programmers used --- to these interfaces to develop programs for GLUT. - ------------------------------------------------------------------------------ --- $DesignPhilosophy --- GLUT simplifies the implementation of programs using OpenGL rendering. The --- GLUT application programming interface (API) requires very few routines to --- display a graphics scene rendered using OpenGL. The GLUT API (like the OpenGL --- API) is stateful. Most initial GLUT state is defined and the initial state is --- reasonable for simple programs. The GLUT routines also take relatively few --- parameters. --- --- The GLUT API is (as much as reasonable) window system independent. For this --- reason, GLUT does not return /any/ native window system handles, pointers, or --- other data structures. More subtle window system dependencies such as --- reliance on window system dependent fonts are avoided by GLUT; instead, GLUT --- supplies its own (limited) set of fonts. --- --- For programming ease, GLUT provides a simple menu sub-API. While the menuing --- support is designed to be implemented as pop-up menus, GLUT gives window --- system leeway to support the menu functionality in another manner (pull-down --- menus for example). --- --- Two of the most important pieces of GLUT state are the /current window/ and --- /current menu/. Most window and menu routines affect the /current window/ or --- /menu/ respectively. Most callbacks implicitly set the /current window/ and --- /menu/ to the appropriate window or menu responsible for the callback. GLUT --- is designed so that a program with only a single window and\/or menu will not --- need to keep track of any window or menu identifiers. This greatly simplifies --- very simple GLUT programs. --- --- GLUT is designed for simple to moderately complex programs focused on OpenGL --- rendering. GLUT implements its own event loop. For this reason, mixing GLUT --- with other APIs that demand their own event handling structure may be --- difficult. The advantage of a builtin event dispatch loop is simplicity. --- --- GLUT contains routines for rendering fonts and geometric objects, however --- GLUT makes no claims on the OpenGL display list name space. For this reason, --- none of the GLUT rendering routines use OpenGL display lists. It is up to the --- GLUT programmer to compile the output from GLUT rendering routines into --- display lists if this is desired. --- --- GLUT routines are logically organized into several sub-APIs according to --- their functionality. The sub-APIs are: --- --- * /Initialization:/ Command line processing, window system initialization, --- and initial window creation state are controlled by these routines. --- --- * /Beginning Event Processing:/ This routine enters GLUT\'s event processing --- loop. This routine never returns, and it continuously calls GLUT callbacks --- as necessary. --- --- * /Window Management:/ These routines create and control windows. --- --- * /Overlay Management:/ These routines establish and manage overlays for --- windows. --- --- * /Menu Management:/ These routines create and control pop-up menus. --- --- * /Callback Registration:/ These routines register callbacks to be called by --- the GLUT event processing loop. --- --- * /Color Index Colormap Management:/ These routines allow the manipulation --- of color index colormaps for windows. --- --- * /State Retrieval:/ These routines allows programs to retrieve state from --- GLUT. --- --- * /Font Rendering:/ These routines allow rendering of stroke and bitmap --- fonts. --- --- * /Geometric Shape Rendering:/ These routines allow the rendering of 3D --- geometric objects including spheres, cones, icosahedrons, and teapots. --- --- * /Debugging:/ This routine reports any pending GL errors. --- --- * /Device Control:/ These routines allow setting the key repeat and polling --- the joystick. --- --- * /Game Mode:/ These routines allow programs to enter\/leave a full-screen --- mode with specified properties. - --- Note that the following item has been left out intentionally, its --- implementation is too SGI-specific: --- * /Video Resizing:/ These routines provide a means for doing swap or frame --- synchronous resizing\/panning of the area that is to be magnified (or --- passed through) to the output video resolution. - ------------------------------------------------------------------------------ --- $APIVersions --- The GLUT API has undergone several revisions with increasing functionality. --- This Haskell binding provides access to everything in API version 4, --- although it is not yet officially finalized. Nevertheless, it provides very --- useful things like handling full-screen modes and special keys. - ------------------------------------------------------------------------------ --- $Conventions --- GLUT window and screen coordinates are expressed in pixels. The upper --- left hand corner of the screen or a window is (0,0). X coordinates --- increase in a rightward direction; Y coordinates increase in a --- downward direction. Note: This is inconsistent with OpenGL\'s --- coordinate scheme that generally considers the lower left hand --- coordinate of a window to be at (0,0) but is consistent with most --- popular window systems. - ------------------------------------------------------------------------------ --- $Terminology --- A number of terms are used in a GLUT-specific manner throughout this --- document. The GLUT meaning of these terms is independent of the window --- system GLUT is used with. Here are GLUT-specific meanings for the --- following GLUT-specific terms: --- --- * /Callback:/ A programmer specified routine that can be registered with --- GLUT to be called in response to a specific type of event. Also used to --- refer to a specific callback routine being called. --- --- * /Colormap:/ A mapping of pixel values to RGB color values. Used by color --- index windows. --- --- * /Dials and button box:/ A sophisticated input device consisting of a pad --- of buttons and an array of rotating dials, often used by computer-aided --- design programs. --- --- * /Display mode:/ A set of OpenGL frame buffer capabilities that can be --- attributed to a window. --- --- * /Idle:/ A state when no window system events are received for processing --- as callbacks and the idle callback, if one is registered, is called. --- --- * /Layer in use:/ Either the normal plane or overlay. This per-window state --- determines what frame buffer layer OpenGL commands affect. --- --- * /Menu entry:/ A menu item that the user can select to trigger the menu --- callback for the menu entry\'s value. --- --- * /Menu item:/ Either a menu entry or a sub-menu trigger. --- --- * /Modifiers:/ The Shift, Ctrl, and Alt keys that can be held down --- simultaneously with a key or mouse button being pressed or released. --- --- * /Multisampling:/ A technique for hardware antialiasing generally available --- only on expensive 3D graphics hardware. Each pixel is composed of a number --- of samples (each containing color and depth information). The samples are --- averaged to determine the displayed pixel color value. Multisampling is --- supported as an extension to OpenGL. --- --- * /Normal plane:/ The default frame buffer layer where GLUT window state --- resides; as opposed to the /overlay/. --- --- * /Overlay:/ A frame buffer layer that can be displayed preferentially to --- the /normal plane/ and supports transparency to display through to the --- /normal plane/. Overlays are useful for rubber-banding effects, text --- annotation, and other operations, to avoid damaging the normal plane frame --- buffer state. Overlays require hardware support not present on all systems. --- --- * /Pop:/ The act of forcing a window to the top of the stacking order for --- sibling windows. --- --- * /Pop-up menu:/ A menu that can be set to appear when a specified mouse --- button is pressed in a window. A pop-menu consists of multiple menu items. --- --- * /Push:/ The act of forcing a window to the bottom of the stacking order --- for sibling windows. --- --- * /Reshape:/ The act of changing the size or shape of the window. --- --- * /Spaceball:/ A sophisticated 3D input device that provides six degrees of --- freedom, three axes of rotation and three axes of translation. It also --- supports a number of buttons. The device is a hand-sized ball attached to --- a base. By cupping the ball with one\'s hand and applying torsional or --- directional force on the ball, rotations and translationsare generated. --- --- * /Stereo:/ A frame buffer capability providing left and right color buffers --- for creating stereoscopic renderings. Typically, the user wears LCD --- shuttered goggles synchronized with the alternating display on the screen --- of the left and right color buffers. --- --- * /Sub-menu:/ A menu cascaded from some sub-menu trigger. --- --- * /Sub-menu trigger:/ A menu item that the user can enter to cascade another --- pop-up menu. --- --- * /Subwindow:/ A type of window that is the child window of a top-level --- window or other subwindow. The drawing and visible region of a subwindow --- is limited by its parent window. --- --- * /Tablet:/ A precise 2D input device. Like a mouse, 2D coordinates are --- returned. The absolute position of the tablet \"puck\" on the tablet is --- returned. Tablets also support a number of buttons. --- --- * /Timer:/ A callback that can be scheduled to be called in a specified --- interval of time. --- --- * /Top-level window:/ A window that can be placed, moved, resized, etc. --- independently from other top-level windows by the user. Subwindows may --- reside within a top-level window. --- --- * /Window:/ A rectangular area for OpenGL rendering. --- --- * /Window display state:/ One of shown, hidden, or iconified. A shown window --- is potentially visible on the screen (it may be obscured by other windows --- and not actually visible). A hidden window will never be visible. An --- iconified window is not visible but could be made visible in response to --- some user action like clicking on the window\'s corresponding icon. --- --- * /Window system:/ A broad notion that refers to both the mechanism and --- policy of the window system. For example, in the X Window System both the --- window manager and the X server are integral to what GLUT considers the --- window system. +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- A Haskell binding for GLUT, the OpenGL Utility Toolkit, a window system +-- independent toolkit for writing OpenGL programs. It includes support for +-- the extended functionality available in freeglut (see +-- ) and OpenGLUT (see +-- ), too. +-- +----------------------------------------------------------------------------- + +module Graphics.UI.GLUT ( + -- * Legal stuff + + -- $LegalStuff + + -- * Introduction + + -- $Introduction + + -- ** Background + + -- $Background + + -- ** Design Philosophy + + -- $DesignPhilosophy + + -- ** API Versions + + -- $APIVersions + + -- ** Conventions + + -- $Conventions + + -- ** Terminology + + -- $Terminology + + module Graphics.Rendering.OpenGL, + + module Graphics.UI.GLUT.Initialization, + module Graphics.UI.GLUT.Begin, + module Graphics.UI.GLUT.Window, + module Graphics.UI.GLUT.Overlay, + module Graphics.UI.GLUT.Menu, + module Graphics.UI.GLUT.Callbacks, + module Graphics.UI.GLUT.Colormap, + module Graphics.UI.GLUT.State, + module Graphics.UI.GLUT.Fonts, + module Graphics.UI.GLUT.Objects, + module Graphics.UI.GLUT.Debugging, + module Graphics.UI.GLUT.DeviceControl, + module Graphics.UI.GLUT.GameMode +) where + +import Graphics.Rendering.OpenGL + +import Graphics.UI.GLUT.Initialization +import Graphics.UI.GLUT.Begin +import Graphics.UI.GLUT.Window +import Graphics.UI.GLUT.Overlay +import Graphics.UI.GLUT.Menu +import Graphics.UI.GLUT.Callbacks +import Graphics.UI.GLUT.Colormap +import Graphics.UI.GLUT.State +import Graphics.UI.GLUT.Fonts +import Graphics.UI.GLUT.Objects +import Graphics.UI.GLUT.Debugging +import Graphics.UI.GLUT.DeviceControl +import Graphics.UI.GLUT.GameMode + +----------------------------------------------------------------------------- +-- $LegalStuff +-- This documentation is heavily based on the man pages of Mark J. Kilgard\'s +-- GLUT library. +-- +-- OpenGL is a trademark of Silicon Graphics, Inc. +-- X Window System is a trademark of X Consortium, Inc. +-- Spaceball is a registered trademark of Spatial Systems, Inc. +-- +-- The author has taken care in preparation of this documentation but makes +-- no expressed or implied warranty of any kind and assumes no responsibility +-- for errors or omissions. No liability is assumed for incidental or +-- consequential damages in connection with or arising from the use of +-- information or programs contained herein. + +----------------------------------------------------------------------------- +-- $Introduction +-- The OpenGL Utility Toolkit (GLUT) is a programming interface for writing +-- window system independent OpenGL programs. Currently there are +-- implementations for the X Window System, the Windows family, OS\/2, and Mac. +-- The toolkit supports the following functionality: +-- +-- * Multiple windows for OpenGL rendering. +-- +-- * Callback driven event processing. +-- +-- * Sophisticated input devices. +-- +-- * An /idle/ routine and timers. +-- +-- * A simple, cascading pop-up menu facility. +-- +-- * Utility routines to generate various solid and wire frame objects. +-- +-- * Support for bitmap and stroke fonts. +-- +-- * Miscellaneous window management functions, including managing overlays. +-- +-- This documentation serves as both a specification and a programming guide. +-- If you are interested in a brief introduction to programming with GLUT, +-- have a look at the relevant parts of and the vast +-- amount of books on OpenGL, most of them use GLUT. +-- +-- The remainder of this section describes GLUT\'s design philosophy and +-- usage model. The following sections specify the GLUT routines, grouped by +-- functionality. The final sections discuss usage advice and the logical +-- programmer visible state maintained by GLUT. + +----------------------------------------------------------------------------- +-- $Background +-- One of the major accomplishments in the specification of OpenGL was +-- the isolation of window system dependencies from OpenGL\'s rendering +-- model. The result is that OpenGL is window system independent. +-- +-- Window system operations such as the creation of a rendering window and the +-- handling of window system events are left to the native window system to +-- define. Necessary interactions between OpenGL and the window system such as +-- creating and binding an OpenGL context to a window are described separately +-- from the OpenGL specification in a window system dependent specification. For +-- example, the GLX specification describes the standard by which OpenGL +-- interacts with the X Window System. +-- +-- The predecessor to OpenGL is IRIS GL. Unlike OpenGL, IRIS GL /does/ +-- specify how rendering windows are created and manipulated. IRIS GL\'s +-- windowing interface is reasonably popular largely because it is simple to +-- use. IRIS GL programmers can worry about graphics programming without needing +-- to be an expert in programming the native window system. Experience also +-- demonstrated that IRIS GL\'s windowing interface was high-level enough that +-- it could be retargeted to different window systems. Silicon Graphics migrated +-- from NeWS to the X Window System without any major changes to IRIS GL\'s +-- basic windowing interface. +-- +-- Removing window system operations from OpenGL is a sound decision because it +-- allows the OpenGL graphics system to be retargeted to various systems +-- including powerful but expensive graphics workstations as well as +-- mass-production graphics systems like video games, set-top boxes for +-- interactive television, and PCs. +-- +-- Unfortunately, the lack of a window system interface for OpenGL is a gap in +-- OpenGL\'s utility. Learning native window system APIs such as the X Window +-- System\'s Xlib or Motif can be daunting. Even those familiar with +-- native window system APIs need to understand the interface that binds OpenGL +-- to the native window system. And when an OpenGL program is written using the +-- native window system interface, despite the portability of the program\'s +-- OpenGL rendering code, the program itself will be window system dependent. +-- +-- Testing and documenting OpenGL\'s functionality lead to the development of +-- the @tk@ and @aux@ toolkits. The @aux@ toolkit is used in the examples found +-- in the /OpenGL Programming Guide/. Unfortunately, @aux@ has numerous +-- limitations and its utility is largely limited to toy programs. The @tk@ +-- library has more functionality than @aux@ but was developed in an /ad hoc/ +-- fashion and still lacks much important functionality that IRIS GL programmers +-- expect, like pop-up menus and overlays. +-- +-- GLUT is designed to fill the need for a window system independent programming +-- interface for OpenGL programs. The interface is designed to be simple yet +-- still meet the needs of useful OpenGL programs. Features from the IRIS GL, +-- @aux@, and @tk@ interfaces are included to make it easy for programmers used +-- to these interfaces to develop programs for GLUT. + +----------------------------------------------------------------------------- +-- $DesignPhilosophy +-- GLUT simplifies the implementation of programs using OpenGL rendering. The +-- GLUT application programming interface (API) requires very few routines to +-- display a graphics scene rendered using OpenGL. The GLUT API (like the OpenGL +-- API) is stateful. Most initial GLUT state is defined and the initial state is +-- reasonable for simple programs. The GLUT routines also take relatively few +-- parameters. +-- +-- The GLUT API is (as much as reasonable) window system independent. For this +-- reason, GLUT does not return /any/ native window system handles, pointers, or +-- other data structures. More subtle window system dependencies such as +-- reliance on window system dependent fonts are avoided by GLUT; instead, GLUT +-- supplies its own (limited) set of fonts. +-- +-- For programming ease, GLUT provides a simple menu sub-API. While the menuing +-- support is designed to be implemented as pop-up menus, GLUT gives window +-- system leeway to support the menu functionality in another manner (pull-down +-- menus for example). +-- +-- Two of the most important pieces of GLUT state are the /current window/ and +-- /current menu/. Most window and menu routines affect the /current window/ or +-- /menu/ respectively. Most callbacks implicitly set the /current window/ and +-- /menu/ to the appropriate window or menu responsible for the callback. GLUT +-- is designed so that a program with only a single window and\/or menu will not +-- need to keep track of any window or menu identifiers. This greatly simplifies +-- very simple GLUT programs. +-- +-- GLUT is designed for simple to moderately complex programs focused on OpenGL +-- rendering. GLUT implements its own event loop. For this reason, mixing GLUT +-- with other APIs that demand their own event handling structure may be +-- difficult. The advantage of a builtin event dispatch loop is simplicity. +-- +-- GLUT contains routines for rendering fonts and geometric objects, however +-- GLUT makes no claims on the OpenGL display list name space. For this reason, +-- none of the GLUT rendering routines use OpenGL display lists. It is up to the +-- GLUT programmer to compile the output from GLUT rendering routines into +-- display lists if this is desired. +-- +-- GLUT routines are logically organized into several sub-APIs according to +-- their functionality. The sub-APIs are: +-- +-- * /Initialization:/ Command line processing, window system initialization, +-- and initial window creation state are controlled by these routines. +-- +-- * /Beginning Event Processing:/ This routine enters GLUT\'s event processing +-- loop. This routine never returns, and it continuously calls GLUT callbacks +-- as necessary. +-- +-- * /Window Management:/ These routines create and control windows. +-- +-- * /Overlay Management:/ These routines establish and manage overlays for +-- windows. +-- +-- * /Menu Management:/ These routines create and control pop-up menus. +-- +-- * /Callback Registration:/ These routines register callbacks to be called by +-- the GLUT event processing loop. +-- +-- * /Color Index Colormap Management:/ These routines allow the manipulation +-- of color index colormaps for windows. +-- +-- * /State Retrieval:/ These routines allows programs to retrieve state from +-- GLUT. +-- +-- * /Font Rendering:/ These routines allow rendering of stroke and bitmap +-- fonts. +-- +-- * /Geometric Shape Rendering:/ These routines allow the rendering of 3D +-- geometric objects including spheres, cones, icosahedrons, and teapots. +-- +-- * /Debugging:/ This routine reports any pending GL errors. +-- +-- * /Device Control:/ These routines allow setting the key repeat and polling +-- the joystick. +-- +-- * /Game Mode:/ These routines allow programs to enter\/leave a full-screen +-- mode with specified properties. + +-- Note that the following item has been left out intentionally, its +-- implementation is too SGI-specific: +-- * /Video Resizing:/ These routines provide a means for doing swap or frame +-- synchronous resizing\/panning of the area that is to be magnified (or +-- passed through) to the output video resolution. + +----------------------------------------------------------------------------- +-- $APIVersions +-- The GLUT API has undergone several revisions with increasing functionality. +-- This Haskell binding provides access to everything in API version 4, +-- although it is not yet officially finalized. Nevertheless, it provides very +-- useful things like handling full-screen modes and special keys. + +----------------------------------------------------------------------------- +-- $Conventions +-- GLUT window and screen coordinates are expressed in pixels. The upper +-- left hand corner of the screen or a window is (0,0). X coordinates +-- increase in a rightward direction; Y coordinates increase in a +-- downward direction. Note: This is inconsistent with OpenGL\'s +-- coordinate scheme that generally considers the lower left hand +-- coordinate of a window to be at (0,0) but is consistent with most +-- popular window systems. + +----------------------------------------------------------------------------- +-- $Terminology +-- A number of terms are used in a GLUT-specific manner throughout this +-- document. The GLUT meaning of these terms is independent of the window +-- system GLUT is used with. Here are GLUT-specific meanings for the +-- following GLUT-specific terms: +-- +-- * /Callback:/ A programmer specified routine that can be registered with +-- GLUT to be called in response to a specific type of event. Also used to +-- refer to a specific callback routine being called. +-- +-- * /Colormap:/ A mapping of pixel values to RGB color values. Used by color +-- index windows. +-- +-- * /Dials and button box:/ A sophisticated input device consisting of a pad +-- of buttons and an array of rotating dials, often used by computer-aided +-- design programs. +-- +-- * /Display mode:/ A set of OpenGL frame buffer capabilities that can be +-- attributed to a window. +-- +-- * /Idle:/ A state when no window system events are received for processing +-- as callbacks and the idle callback, if one is registered, is called. +-- +-- * /Layer in use:/ Either the normal plane or overlay. This per-window state +-- determines what frame buffer layer OpenGL commands affect. +-- +-- * /Menu entry:/ A menu item that the user can select to trigger the menu +-- callback for the menu entry\'s value. +-- +-- * /Menu item:/ Either a menu entry or a sub-menu trigger. +-- +-- * /Modifiers:/ The Shift, Ctrl, and Alt keys that can be held down +-- simultaneously with a key or mouse button being pressed or released. +-- +-- * /Multisampling:/ A technique for hardware antialiasing generally available +-- only on expensive 3D graphics hardware. Each pixel is composed of a number +-- of samples (each containing color and depth information). The samples are +-- averaged to determine the displayed pixel color value. Multisampling is +-- supported as an extension to OpenGL. +-- +-- * /Normal plane:/ The default frame buffer layer where GLUT window state +-- resides; as opposed to the /overlay/. +-- +-- * /Overlay:/ A frame buffer layer that can be displayed preferentially to +-- the /normal plane/ and supports transparency to display through to the +-- /normal plane/. Overlays are useful for rubber-banding effects, text +-- annotation, and other operations, to avoid damaging the normal plane frame +-- buffer state. Overlays require hardware support not present on all systems. +-- +-- * /Pop:/ The act of forcing a window to the top of the stacking order for +-- sibling windows. +-- +-- * /Pop-up menu:/ A menu that can be set to appear when a specified mouse +-- button is pressed in a window. A pop-menu consists of multiple menu items. +-- +-- * /Push:/ The act of forcing a window to the bottom of the stacking order +-- for sibling windows. +-- +-- * /Reshape:/ The act of changing the size or shape of the window. +-- +-- * /Spaceball:/ A sophisticated 3D input device that provides six degrees of +-- freedom, three axes of rotation and three axes of translation. It also +-- supports a number of buttons. The device is a hand-sized ball attached to +-- a base. By cupping the ball with one\'s hand and applying torsional or +-- directional force on the ball, rotations and translationsare generated. +-- +-- * /Stereo:/ A frame buffer capability providing left and right color buffers +-- for creating stereoscopic renderings. Typically, the user wears LCD +-- shuttered goggles synchronized with the alternating display on the screen +-- of the left and right color buffers. +-- +-- * /Sub-menu:/ A menu cascaded from some sub-menu trigger. +-- +-- * /Sub-menu trigger:/ A menu item that the user can enter to cascade another +-- pop-up menu. +-- +-- * /Subwindow:/ A type of window that is the child window of a top-level +-- window or other subwindow. The drawing and visible region of a subwindow +-- is limited by its parent window. +-- +-- * /Tablet:/ A precise 2D input device. Like a mouse, 2D coordinates are +-- returned. The absolute position of the tablet \"puck\" on the tablet is +-- returned. Tablets also support a number of buttons. +-- +-- * /Timer:/ A callback that can be scheduled to be called in a specified +-- interval of time. +-- +-- * /Top-level window:/ A window that can be placed, moved, resized, etc. +-- independently from other top-level windows by the user. Subwindows may +-- reside within a top-level window. +-- +-- * /Window:/ A rectangular area for OpenGL rendering. +-- +-- * /Window display state:/ One of shown, hidden, or iconified. A shown window +-- is potentially visible on the screen (it may be obscured by other windows +-- and not actually visible). A hidden window will never be visible. An +-- iconified window is not visible but could be made visible in response to +-- some user action like clicking on the window\'s corresponding icon. +-- +-- * /Window system:/ A broad notion that refers to both the mechanism and +-- policy of the window system. For example, in the X Window System both the +-- window manager and the X server are integral to what GLUT considers the +-- window system. diff --git a/Graphics/UI/GLUT/Begin.hs b/Graphics/UI/GLUT/Begin.hs --- a/Graphics/UI/GLUT/Begin.hs +++ b/Graphics/UI/GLUT/Begin.hs @@ -1,102 +1,102 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Begin --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- After a GLUT program has done initial setup such as creating windows and --- menus, GLUT programs enter the GLUT event processing loop by calling --- 'mainLoop' or handle events iteratively with 'mainLoopEvent'. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Begin ( - -- * Handling events - mainLoop, mainLoopEvent, leaveMainLoop, - - -- * Controlling the behaviour when windows are closed - ActionOnWindowClose(..), actionOnWindowClose -) where - -import Foreign.C.Types -import Graphics.Rendering.OpenGL.GL.StateVar -import Graphics.UI.GLUT.QueryUtils -import Graphics.UI.GLUT.Raw - --------------------------------------------------------------------------------- - --- | Enter the GLUT event processing loop; it will call as necessary any --- callbacks that have been registered. This routine should be called at most --- once in a GLUT program. - -mainLoop :: IO () -mainLoop = glutMainLoop - --------------------------------------------------------------------------------- - --- | (/freeglut only/) Process one iteration's worth of events in its event loop. --- This allows the application to control its own event loop and still use the --- GLUT package. - -mainLoopEvent :: IO () -mainLoopEvent = glutMainLoopEvent - --------------------------------------------------------------------------------- - --- | (/freeglut only/) Stop the event loop. If 'actionOnWindowClose' contains --- 'Exit', the application will exit; otherwise control will return to the --- function which called 'mainLoop'. --- --- If the application has two nested calls to 'mainLoop' and calls --- 'leaveMainLoop', the behaviour is undefined. It may leave only the inner --- nested loop or it may leave both loops. If the reader has a strong preference --- for one behaviour over the other he should contact the freeglut Programming --- Consortium and ask for the code to be fixed. - -leaveMainLoop :: IO () -leaveMainLoop = glutLeaveMainLoop - --------------------------------------------------------------------------------- - --- | The behaviour when the user closes a window. - -data ActionOnWindowClose - = -- | Exit the whole program when any window is closed or 'leaveMainLoop' - -- is called (default). - Exit - | -- | Return from mainLoop when any window is closed. - MainLoopReturns - | -- | Return from mainLoop after the last window is closed. - ContinueExecution - | ContinueExectuion - deriving ( Eq, Ord, Show ) - -{-# DEPRECATED ContinueExectuion "Use 'ContinueExecution' instead." #-} - -marshalActionOnWindowClose :: ActionOnWindowClose -> CInt -marshalActionOnWindowClose x = case x of - Exit -> glut_ACTION_EXIT - MainLoopReturns -> glut_ACTION_GLUTMAINLOOP_RETURNS - ContinueExecution -> glut_ACTION_CONTINUE_EXECUTION - ContinueExectuion -> glut_ACTION_CONTINUE_EXECUTION - -unmarshalActionOnWindowClose :: CInt -> ActionOnWindowClose -unmarshalActionOnWindowClose x - | x == glut_ACTION_EXIT = Exit - | x == glut_ACTION_GLUTMAINLOOP_RETURNS = MainLoopReturns - | x == glut_ACTION_CONTINUE_EXECUTION = ContinueExecution - | otherwise = error ("unmarshalActionOnWindowClose: illegal value " ++ show x) - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Controls the behaviour when the user closes a window. - -actionOnWindowClose :: StateVar ActionOnWindowClose -actionOnWindowClose = - makeStateVar - (simpleGet unmarshalActionOnWindowClose glut_ACTION_ON_WINDOW_CLOSE) - (glutSetOption glut_ACTION_ON_WINDOW_CLOSE . marshalActionOnWindowClose) +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Begin +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- After a GLUT program has done initial setup such as creating windows and +-- menus, GLUT programs enter the GLUT event processing loop by calling +-- 'mainLoop' or handle events iteratively with 'mainLoopEvent'. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Begin ( + -- * Handling events + mainLoop, mainLoopEvent, leaveMainLoop, + + -- * Controlling the behaviour when windows are closed + ActionOnWindowClose(..), actionOnWindowClose +) where + +import Foreign.C.Types +import Graphics.Rendering.OpenGL.GL.StateVar +import Graphics.UI.GLUT.QueryUtils +import Graphics.UI.GLUT.Raw + +-------------------------------------------------------------------------------- + +-- | Enter the GLUT event processing loop; it will call as necessary any +-- callbacks that have been registered. This routine should be called at most +-- once in a GLUT program. + +mainLoop :: IO () +mainLoop = glutMainLoop + +-------------------------------------------------------------------------------- + +-- | (/freeglut only/) Process one iteration's worth of events in its event loop. +-- This allows the application to control its own event loop and still use the +-- GLUT package. + +mainLoopEvent :: IO () +mainLoopEvent = glutMainLoopEvent + +-------------------------------------------------------------------------------- + +-- | (/freeglut only/) Stop the event loop. If 'actionOnWindowClose' contains +-- 'Exit', the application will exit; otherwise control will return to the +-- function which called 'mainLoop'. +-- +-- If the application has two nested calls to 'mainLoop' and calls +-- 'leaveMainLoop', the behaviour is undefined. It may leave only the inner +-- nested loop or it may leave both loops. If the reader has a strong preference +-- for one behaviour over the other he should contact the freeglut Programming +-- Consortium and ask for the code to be fixed. + +leaveMainLoop :: IO () +leaveMainLoop = glutLeaveMainLoop + +-------------------------------------------------------------------------------- + +-- | The behaviour when the user closes a window. + +data ActionOnWindowClose + = -- | Exit the whole program when any window is closed or 'leaveMainLoop' + -- is called (default). + Exit + | -- | Return from mainLoop when any window is closed. + MainLoopReturns + | -- | Return from mainLoop after the last window is closed. + ContinueExecution + | ContinueExectuion + deriving ( Eq, Ord, Show ) + +{-# DEPRECATED ContinueExectuion "Use 'ContinueExecution' instead." #-} + +marshalActionOnWindowClose :: ActionOnWindowClose -> CInt +marshalActionOnWindowClose x = case x of + Exit -> glut_ACTION_EXIT + MainLoopReturns -> glut_ACTION_GLUTMAINLOOP_RETURNS + ContinueExecution -> glut_ACTION_CONTINUE_EXECUTION + ContinueExectuion -> glut_ACTION_CONTINUE_EXECUTION + +unmarshalActionOnWindowClose :: CInt -> ActionOnWindowClose +unmarshalActionOnWindowClose x + | x == glut_ACTION_EXIT = Exit + | x == glut_ACTION_GLUTMAINLOOP_RETURNS = MainLoopReturns + | x == glut_ACTION_CONTINUE_EXECUTION = ContinueExecution + | otherwise = error ("unmarshalActionOnWindowClose: illegal value " ++ show x) + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Controls the behaviour when the user closes a window. + +actionOnWindowClose :: StateVar ActionOnWindowClose +actionOnWindowClose = + makeStateVar + (simpleGet unmarshalActionOnWindowClose glut_ACTION_ON_WINDOW_CLOSE) + (glutSetOption glut_ACTION_ON_WINDOW_CLOSE . marshalActionOnWindowClose) diff --git a/Graphics/UI/GLUT/Callbacks.hs b/Graphics/UI/GLUT/Callbacks.hs --- a/Graphics/UI/GLUT/Callbacks.hs +++ b/Graphics/UI/GLUT/Callbacks.hs @@ -1,47 +1,47 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Callbacks --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- --- GLUT supports a number of callbacks to respond to events. There are three --- types of callbacks: window, menu, and global. Window callbacks indicate when --- to redisplay or reshape a window, when the visibility of the window changes, --- and when input is available for the window. Menu callbacks are described in --- "Graphics.UI.GLUT.Menu". The global callbacks manage the passing of time and --- menu usage. The calling order of callbacks between different windows is --- undefined. --- --- Callbacks for input events should be delivered to the window the event occurs --- in. Events should not propagate to parent windows. --- --- A callback of type @Foo@ can registered by setting @fooCallback@ to 'Just' --- the callback. Almost all callbacks can be de-registered by setting --- the corresponding @fooCallback@ to 'Nothing', the only exceptions being --- 'Graphics.UI.GLUT.Callbacks.Window.DisplayCallback' (can only be --- re-registered) and 'Graphics.UI.GLUT.Callbacks.Global.TimerCallback' (can\'t --- be unregistered). --- --- /X Implementation Notes:/ The X GLUT implementation uses the X Input --- extension to support sophisticated input devices: Spaceball, dial & button --- box, and digitizing tablet. Because the X Input extension does not mandate --- how particular types of devices are advertised through the extension, it is --- possible GLUT for X may not correctly support input devices that would --- otherwise be of the correct type. The X GLUT implementation will support the --- Silicon Graphics Spaceball, dial & button box, and digitizing tablet as --- advertised through the X Input extension. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Callbacks ( - module Graphics.UI.GLUT.Callbacks.Window, - module Graphics.UI.GLUT.Callbacks.Global -) where - -import Graphics.UI.GLUT.Callbacks.Window -import Graphics.UI.GLUT.Callbacks.Global +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Callbacks +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- +-- GLUT supports a number of callbacks to respond to events. There are three +-- types of callbacks: window, menu, and global. Window callbacks indicate when +-- to redisplay or reshape a window, when the visibility of the window changes, +-- and when input is available for the window. Menu callbacks are described in +-- "Graphics.UI.GLUT.Menu". The global callbacks manage the passing of time and +-- menu usage. The calling order of callbacks between different windows is +-- undefined. +-- +-- Callbacks for input events should be delivered to the window the event occurs +-- in. Events should not propagate to parent windows. +-- +-- A callback of type @Foo@ can registered by setting @fooCallback@ to 'Just' +-- the callback. Almost all callbacks can be de-registered by setting +-- the corresponding @fooCallback@ to 'Nothing', the only exceptions being +-- 'Graphics.UI.GLUT.Callbacks.Window.DisplayCallback' (can only be +-- re-registered) and 'Graphics.UI.GLUT.Callbacks.Global.TimerCallback' (can\'t +-- be unregistered). +-- +-- /X Implementation Notes:/ The X GLUT implementation uses the X Input +-- extension to support sophisticated input devices: Spaceball, dial & button +-- box, and digitizing tablet. Because the X Input extension does not mandate +-- how particular types of devices are advertised through the extension, it is +-- possible GLUT for X may not correctly support input devices that would +-- otherwise be of the correct type. The X GLUT implementation will support the +-- Silicon Graphics Spaceball, dial & button box, and digitizing tablet as +-- advertised through the X Input extension. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Callbacks ( + module Graphics.UI.GLUT.Callbacks.Window, + module Graphics.UI.GLUT.Callbacks.Global +) where + +import Graphics.UI.GLUT.Callbacks.Window +import Graphics.UI.GLUT.Callbacks.Global diff --git a/Graphics/UI/GLUT/Callbacks/Global.hs b/Graphics/UI/GLUT/Callbacks/Global.hs --- a/Graphics/UI/GLUT/Callbacks/Global.hs +++ b/Graphics/UI/GLUT/Callbacks/Global.hs @@ -1,114 +1,114 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Callbacks.Global --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Callbacks.Global ( - -- * Menu status callback - MenuUsage(..), MenuStatusCallback, menuStatusCallback, - - -- * Idle callback - IdleCallback, idleCallback, - - -- * Timer callbacks - Timeout, TimerCallback, addTimerCallback -) where - -import Control.Monad.Fix -import Foreign.C.Types -import Graphics.Rendering.OpenGL ( Position(..) - , SettableStateVar - , makeSettableStateVar ) -import Graphics.UI.GLUT.Callbacks.Registration -import Graphics.UI.GLUT.Raw - --------------------------------------------------------------------------------- - -data MenuUsage - = NotInUse - | InUse - deriving ( Eq, Ord, Show ) - -unmarshalMenuUsage :: CInt -> MenuUsage -unmarshalMenuUsage x - | x == glut_MENU_NOT_IN_USE = NotInUse - | x == glut_MENU_IN_USE = InUse - | otherwise = error ("unmarshalMenuUsage: illegal value " ++ show x) - -type MenuStatusCallback = MenuUsage -> Position -> IO () - --- | Controls the global menu status callback so a GLUT program can determine --- when a menu is in use or not. When a menu status callback is registered, it --- will be called with the value 'InUse' when pop-up menus are in use by the --- user; and the callback will be called with the value 'NotInUse' when pop-up --- menus are no longer in use. Additionally, the location in window coordinates --- of the button press that caused the menu to go into use, or the location where --- the menu was released (maybe outside the window). Other callbacks continue to --- operate (except mouse motion callbacks) when pop-up menus are in use so the --- menu status callback allows a program to suspend animation or other tasks --- when menus are in use. The cascading and unmapping of sub-menus from an --- initial pop-up menu does not generate menu status callbacks. There is a --- single menu status callback for GLUT. --- --- When the menu status callback is called, the /current menu/ will be set to --- the initial pop-up menu in both the 'InUse' and 'NotInUse' cases. The --- /current window/ will be set to the window from which the initial menu was --- popped up from, also in both cases. - -menuStatusCallback :: SettableStateVar (Maybe MenuStatusCallback) -menuStatusCallback = - makeSettableStateVar $ - setCallback MenuStatusCB glutMenuStatusFunc - (makeMenuStatusFunc . unmarshal) - where unmarshal cb s x y = - cb (unmarshalMenuUsage s) - (Position (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - -type IdleCallback = IO () - --- | Controls the global idle callback so a GLUT program can perform background --- processing tasks or continuous animation when window system events are not --- being received. If enabled, the idle callback is continuously called when --- events are not being received. The /current window/ and /current menu/ will --- not be changed before the idle callback. Programs with multiple windows --- and\/or menus should explicitly set the /current window/ and\/or /current --- menu/ and not rely on its current setting. --- --- The amount of computation and rendering done in an idle callback should be --- minimized to avoid affecting the program\'s interactive response. In general, --- not more than a single frame of rendering should be done in an idle callback. - -idleCallback :: SettableStateVar (Maybe IdleCallback) -idleCallback = - makeSettableStateVar $ setCallback IdleCB glutIdleFunc makeIdleFunc - --------------------------------------------------------------------------------- - --- | Timeout for the timer callback in milliseconds -type Timeout = Int - -type TimerCallback = IO () - --- | Register a one-shot timer callback to be triggered after at least the given --- amount of time. Multiple timer callbacks at same or differing times may be --- registered simultaneously. There is no support for canceling a registered --- callback. --- --- The number of milliseconds is a lower bound on the time before the callback --- is generated. GLUT attempts to deliver the timer callback as soon as possible --- after the expiration of the callback\'s time interval. - -addTimerCallback :: Timeout -> TimerCallback -> IO () -addTimerCallback msecs timerCallback = do - funPtr <- mfix (\self -> makeTimerFunc (\_ -> do registerForCleanup self - timerCallback)) - glutTimerFunc (fromIntegral msecs) funPtr 0 +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Callbacks.Global +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Callbacks.Global ( + -- * Menu status callback + MenuUsage(..), MenuStatusCallback, menuStatusCallback, + + -- * Idle callback + IdleCallback, idleCallback, + + -- * Timer callbacks + Timeout, TimerCallback, addTimerCallback +) where + +import Control.Monad.Fix +import Foreign.C.Types +import Graphics.Rendering.OpenGL ( Position(..) + , SettableStateVar + , makeSettableStateVar ) +import Graphics.UI.GLUT.Callbacks.Registration +import Graphics.UI.GLUT.Raw + +-------------------------------------------------------------------------------- + +data MenuUsage + = NotInUse + | InUse + deriving ( Eq, Ord, Show ) + +unmarshalMenuUsage :: CInt -> MenuUsage +unmarshalMenuUsage x + | x == glut_MENU_NOT_IN_USE = NotInUse + | x == glut_MENU_IN_USE = InUse + | otherwise = error ("unmarshalMenuUsage: illegal value " ++ show x) + +type MenuStatusCallback = MenuUsage -> Position -> IO () + +-- | Controls the global menu status callback so a GLUT program can determine +-- when a menu is in use or not. When a menu status callback is registered, it +-- will be called with the value 'InUse' when pop-up menus are in use by the +-- user; and the callback will be called with the value 'NotInUse' when pop-up +-- menus are no longer in use. Additionally, the location in window coordinates +-- of the button press that caused the menu to go into use, or the location where +-- the menu was released (maybe outside the window). Other callbacks continue to +-- operate (except mouse motion callbacks) when pop-up menus are in use so the +-- menu status callback allows a program to suspend animation or other tasks +-- when menus are in use. The cascading and unmapping of sub-menus from an +-- initial pop-up menu does not generate menu status callbacks. There is a +-- single menu status callback for GLUT. +-- +-- When the menu status callback is called, the /current menu/ will be set to +-- the initial pop-up menu in both the 'InUse' and 'NotInUse' cases. The +-- /current window/ will be set to the window from which the initial menu was +-- popped up from, also in both cases. + +menuStatusCallback :: SettableStateVar (Maybe MenuStatusCallback) +menuStatusCallback = + makeSettableStateVar $ + setCallback MenuStatusCB glutMenuStatusFunc + (makeMenuStatusFunc . unmarshal) + where unmarshal cb s x y = + cb (unmarshalMenuUsage s) + (Position (fromIntegral x) (fromIntegral y)) + +-------------------------------------------------------------------------------- + +type IdleCallback = IO () + +-- | Controls the global idle callback so a GLUT program can perform background +-- processing tasks or continuous animation when window system events are not +-- being received. If enabled, the idle callback is continuously called when +-- events are not being received. The /current window/ and /current menu/ will +-- not be changed before the idle callback. Programs with multiple windows +-- and\/or menus should explicitly set the /current window/ and\/or /current +-- menu/ and not rely on its current setting. +-- +-- The amount of computation and rendering done in an idle callback should be +-- minimized to avoid affecting the program\'s interactive response. In general, +-- not more than a single frame of rendering should be done in an idle callback. + +idleCallback :: SettableStateVar (Maybe IdleCallback) +idleCallback = + makeSettableStateVar $ setCallback IdleCB glutIdleFunc makeIdleFunc + +-------------------------------------------------------------------------------- + +-- | Timeout for the timer callback in milliseconds +type Timeout = Int + +type TimerCallback = IO () + +-- | Register a one-shot timer callback to be triggered after at least the given +-- amount of time. Multiple timer callbacks at same or differing times may be +-- registered simultaneously. There is no support for canceling a registered +-- callback. +-- +-- The number of milliseconds is a lower bound on the time before the callback +-- is generated. GLUT attempts to deliver the timer callback as soon as possible +-- after the expiration of the callback\'s time interval. + +addTimerCallback :: Timeout -> TimerCallback -> IO () +addTimerCallback msecs timerCallback = do + funPtr <- mfix (\self -> makeTimerFunc (\_ -> do registerForCleanup self + timerCallback)) + glutTimerFunc (fromIntegral msecs) funPtr 0 diff --git a/Graphics/UI/GLUT/Callbacks/Registration.hs b/Graphics/UI/GLUT/Callbacks/Registration.hs --- a/Graphics/UI/GLUT/Callbacks/Registration.hs +++ b/Graphics/UI/GLUT/Callbacks/Registration.hs @@ -1,160 +1,160 @@ -{-# OPTIONS_GHC -fno-cse #-} - -{-# OPTIONS_HADDOCK hide #-} --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Callbacks.Registration --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Callbacks.Registration ( - CallbackType(..), registerForCleanup, setCallback, getCurrentWindow -) where - --------------------------------------------------------------------------------- - -import Control.Monad -import Data.IORef -import qualified Data.Map as Map ( empty, lookup, insert, delete ) -import Data.Map ( Map ) -import Foreign.Ptr -import Graphics.Rendering.OpenGL ( get ) -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.Window - --------------------------------------------------------------------------------- --- No timer callback here, because they are one-shot and "self destroy" - -data CallbackType - = DisplayCB | OverlayDisplayCB | ReshapeCB - | KeyboardCB | KeyboardUpCB | MouseCB - | MotionCB | PassiveMotionCB | CrossingCB - | VisibilityCB | WindowStatusCB | SpecialCB - | SpecialUpCB | SpaceballMotionCB | SpaceballRotateCB - | SpaceballButtonCB | ButtonBoxCB | DialsCB - | TabletMotionCB | TabletButtonCB | JoystickCB - | MenuStatusCB | IdleCB - | CloseCB -- freeglut only - | MouseWheelCB -- freeglut only - deriving ( Eq, Ord ) - -isGlobal :: CallbackType -> Bool -isGlobal MenuStatusCB = True -isGlobal IdleCB = True -isGlobal _ = False - --------------------------------------------------------------------------------- --- To uniquely identify a particular callback, the associated window is needed --- for window callbacks. - -data CallbackID = CallbackID (Maybe Window) CallbackType - deriving ( Eq, Ord ) - -getCallbackID :: CallbackType -> IO CallbackID -getCallbackID callbackType = do - maybeWindow <- if isGlobal callbackType - then return Nothing - else fmap Just $ getCurrentWindow "getCallbackID" - return $ CallbackID maybeWindow callbackType - -getCurrentWindow :: String -> IO Window -getCurrentWindow func = do - win <- get currentWindow - maybe (error (func ++ ": no current window")) return win - --------------------------------------------------------------------------------- --- This seems to be a common Haskell hack nowadays: A plain old global variable --- with an associated mutator. Perhaps some language/library support is needed? - -{-# NOINLINE theCallbackTable #-} -theCallbackTable :: IORef (CallbackTable a) -theCallbackTable = unsafePerformIO (newIORef emptyCallbackTable) - -getCallbackTable :: IO (CallbackTable a) -getCallbackTable = readIORef theCallbackTable - -modifyCallbackTable :: (CallbackTable a -> CallbackTable a) -> IO () -modifyCallbackTable = modifyIORef theCallbackTable - --------------------------------------------------------------------------------- - -type CallbackTable a = Map CallbackID (FunPtr a) - -emptyCallbackTable :: CallbackTable a -emptyCallbackTable = Map.empty - -lookupInCallbackTable :: CallbackID -> IO (Maybe (FunPtr a)) -lookupInCallbackTable callbackID = - fmap (Map.lookup callbackID) getCallbackTable - -deleteFromCallbackTable :: CallbackID -> IO () -deleteFromCallbackTable callbackID = - modifyCallbackTable (Map.delete callbackID) - -addToCallbackTable :: CallbackID -> FunPtr a -> IO () -addToCallbackTable callbackID funPtr = - modifyCallbackTable (Map.insert callbackID funPtr) - --------------------------------------------------------------------------------- --- Another global mutable variable: The list of function pointers ready to be --- freed by freeHaskellFunPtr - -{-# NOINLINE theCleanupList #-} -theCleanupList :: IORef [FunPtr a] -theCleanupList = unsafePerformIO (newIORef []) - -getCleanupList :: IO [FunPtr a] -getCleanupList = readIORef theCleanupList - -setCleanupList :: [FunPtr a] -> IO () -setCleanupList = writeIORef theCleanupList - --------------------------------------------------------------------------------- --- And yet another mutable (write-once) variable: A function pointer to a --- callback which frees all function pointers on the cleanup list. - -{-# NOINLINE theScavenger #-} -theScavenger :: IORef (FunPtr TimerFunc) -theScavenger = unsafePerformIO (newIORef =<< makeTimerFunc (\_ -> do - cleanupList <- getCleanupList - mapM_ freeHaskellFunPtr cleanupList - setCleanupList [])) - -getScavenger :: IO (FunPtr TimerFunc) -getScavenger = readIORef theScavenger - --------------------------------------------------------------------------------- --- Here is the really cunning stuff: If an element is added to the cleanup list --- when it is empty, register an immediate callback at GLUT to free the list as --- soon as possible. - -registerForCleanup :: FunPtr a -> IO () -registerForCleanup funPtr = do - oldCleanupList <- getCleanupList - setCleanupList (funPtr : oldCleanupList) - when (null oldCleanupList) $ do - scavenger <- getScavenger - glutTimerFunc 0 scavenger 0 - --------------------------------------------------------------------------------- - -setCallback :: CallbackType -> (FunPtr a -> IO ()) -> (b -> IO (FunPtr a)) - -> Maybe b -> IO () -setCallback callbackType registerAtGLUT makeCallback maybeCallback = do - callbackID <- getCallbackID callbackType - maybeOldFunPtr <- lookupInCallbackTable callbackID - case maybeOldFunPtr of - Nothing -> return () - Just oldFunPtr -> do registerForCleanup oldFunPtr - deleteFromCallbackTable callbackID - case maybeCallback of - Nothing -> registerAtGLUT nullFunPtr - Just callback -> do newFunPtr <- makeCallback callback - addToCallbackTable callbackID newFunPtr - registerAtGLUT newFunPtr +{-# OPTIONS_GHC -fno-cse #-} + +{-# OPTIONS_HADDOCK hide #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Callbacks.Registration +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Callbacks.Registration ( + CallbackType(..), registerForCleanup, setCallback, getCurrentWindow +) where + +-------------------------------------------------------------------------------- + +import Control.Monad +import Data.IORef +import qualified Data.Map as Map ( empty, lookup, insert, delete ) +import Data.Map ( Map ) +import Foreign.Ptr +import Graphics.Rendering.OpenGL ( get ) +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.Window + +-------------------------------------------------------------------------------- +-- No timer callback here, because they are one-shot and "self destroy" + +data CallbackType + = DisplayCB | OverlayDisplayCB | ReshapeCB + | KeyboardCB | KeyboardUpCB | MouseCB + | MotionCB | PassiveMotionCB | CrossingCB + | VisibilityCB | WindowStatusCB | SpecialCB + | SpecialUpCB | SpaceballMotionCB | SpaceballRotateCB + | SpaceballButtonCB | ButtonBoxCB | DialsCB + | TabletMotionCB | TabletButtonCB | JoystickCB + | MenuStatusCB | IdleCB + | CloseCB -- freeglut only + | MouseWheelCB -- freeglut only + deriving ( Eq, Ord ) + +isGlobal :: CallbackType -> Bool +isGlobal MenuStatusCB = True +isGlobal IdleCB = True +isGlobal _ = False + +-------------------------------------------------------------------------------- +-- To uniquely identify a particular callback, the associated window is needed +-- for window callbacks. + +data CallbackID = CallbackID (Maybe Window) CallbackType + deriving ( Eq, Ord ) + +getCallbackID :: CallbackType -> IO CallbackID +getCallbackID callbackType = do + maybeWindow <- if isGlobal callbackType + then return Nothing + else fmap Just $ getCurrentWindow "getCallbackID" + return $ CallbackID maybeWindow callbackType + +getCurrentWindow :: String -> IO Window +getCurrentWindow func = do + win <- get currentWindow + maybe (error (func ++ ": no current window")) return win + +-------------------------------------------------------------------------------- +-- This seems to be a common Haskell hack nowadays: A plain old global variable +-- with an associated mutator. Perhaps some language/library support is needed? + +{-# NOINLINE theCallbackTable #-} +theCallbackTable :: IORef (CallbackTable a) +theCallbackTable = unsafePerformIO (newIORef emptyCallbackTable) + +getCallbackTable :: IO (CallbackTable a) +getCallbackTable = readIORef theCallbackTable + +modifyCallbackTable :: (CallbackTable a -> CallbackTable a) -> IO () +modifyCallbackTable = modifyIORef theCallbackTable + +-------------------------------------------------------------------------------- + +type CallbackTable a = Map CallbackID (FunPtr a) + +emptyCallbackTable :: CallbackTable a +emptyCallbackTable = Map.empty + +lookupInCallbackTable :: CallbackID -> IO (Maybe (FunPtr a)) +lookupInCallbackTable callbackID = + fmap (Map.lookup callbackID) getCallbackTable + +deleteFromCallbackTable :: CallbackID -> IO () +deleteFromCallbackTable callbackID = + modifyCallbackTable (Map.delete callbackID) + +addToCallbackTable :: CallbackID -> FunPtr a -> IO () +addToCallbackTable callbackID funPtr = + modifyCallbackTable (Map.insert callbackID funPtr) + +-------------------------------------------------------------------------------- +-- Another global mutable variable: The list of function pointers ready to be +-- freed by freeHaskellFunPtr + +{-# NOINLINE theCleanupList #-} +theCleanupList :: IORef [FunPtr a] +theCleanupList = unsafePerformIO (newIORef []) + +getCleanupList :: IO [FunPtr a] +getCleanupList = readIORef theCleanupList + +setCleanupList :: [FunPtr a] -> IO () +setCleanupList = writeIORef theCleanupList + +-------------------------------------------------------------------------------- +-- And yet another mutable (write-once) variable: A function pointer to a +-- callback which frees all function pointers on the cleanup list. + +{-# NOINLINE theScavenger #-} +theScavenger :: IORef (FunPtr TimerFunc) +theScavenger = unsafePerformIO (newIORef =<< makeTimerFunc (\_ -> do + cleanupList <- getCleanupList + mapM_ freeHaskellFunPtr cleanupList + setCleanupList [])) + +getScavenger :: IO (FunPtr TimerFunc) +getScavenger = readIORef theScavenger + +-------------------------------------------------------------------------------- +-- Here is the really cunning stuff: If an element is added to the cleanup list +-- when it is empty, register an immediate callback at GLUT to free the list as +-- soon as possible. + +registerForCleanup :: FunPtr a -> IO () +registerForCleanup funPtr = do + oldCleanupList <- getCleanupList + setCleanupList (funPtr : oldCleanupList) + when (null oldCleanupList) $ do + scavenger <- getScavenger + glutTimerFunc 0 scavenger 0 + +-------------------------------------------------------------------------------- + +setCallback :: CallbackType -> (FunPtr a -> IO ()) -> (b -> IO (FunPtr a)) + -> Maybe b -> IO () +setCallback callbackType registerAtGLUT makeCallback maybeCallback = do + callbackID <- getCallbackID callbackType + maybeOldFunPtr <- lookupInCallbackTable callbackID + case maybeOldFunPtr of + Nothing -> return () + Just oldFunPtr -> do registerForCleanup oldFunPtr + deleteFromCallbackTable callbackID + case maybeCallback of + Nothing -> registerAtGLUT nullFunPtr + Just callback -> do newFunPtr <- makeCallback callback + addToCallbackTable callbackID newFunPtr + registerAtGLUT newFunPtr diff --git a/Graphics/UI/GLUT/Callbacks/Window.hs b/Graphics/UI/GLUT/Callbacks/Window.hs --- a/Graphics/UI/GLUT/Callbacks/Window.hs +++ b/Graphics/UI/GLUT/Callbacks/Window.hs @@ -1,838 +1,838 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Callbacks.Window --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Callbacks.Window ( - -- * Redisplay callbacks - DisplayCallback, displayCallback, overlayDisplayCallback, - - -- * Reshape callback - ReshapeCallback, reshapeCallback, - - -- * Callbacks for visibility changes - Visibility(..), VisibilityCallback, visibilityCallback, - WindowState(..), WindowStateCallback, windowStateCallback, - - -- * Window close callback - CloseCallback, closeCallback, - - -- * Keyboard callback - KeyboardCallback, keyboardCallback, keyboardUpCallback, - - -- * Special callback - SpecialCallback, specialCallback, specialUpCallback, - - -- * Mouse callback - MouseCallback, mouseCallback, - - -- * Keyboard and mouse input callback - Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..), - KeyboardMouseCallback, keyboardMouseCallback, - - -- * Mouse wheel callback - WheelNumber, WheelDirection, MouseWheelCallback, mouseWheelCallback, - - -- * Mouse movement callbacks - MotionCallback, motionCallback, passiveMotionCallback, - Crossing(..), CrossingCallback, crossingCallback, - - -- * Spaceball callback - SpaceballMotion, SpaceballRotation, ButtonIndex, SpaceballInput(..), - SpaceballCallback, spaceballCallback, - - -- * Dial & button box callback - DialAndButtonBoxInput(..), DialIndex, - DialAndButtonBoxCallback, dialAndButtonBoxCallback, - - -- * Tablet callback - TabletPosition(..), TabletInput(..), TabletCallback, tabletCallback, - - -- * Joystick callback - JoystickButtons(..), JoystickPosition(..), - JoystickCallback, joystickCallback -) where - -import Data.Bits hiding ( shift ) -import Data.Char -import Data.Maybe -import Foreign.C.Types -import Graphics.Rendering.OpenGL ( Position(..), Size(..) - , SettableStateVar, makeSettableStateVar ) -import Graphics.UI.GLUT.Callbacks.Registration -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.State -import Graphics.UI.GLUT.Types - --------------------------------------------------------------------------------- - --- | A display callback - -type DisplayCallback = IO () - --- | Controls the display callback for the /current window./ When GLUT determines --- that the normal plane for the window needs to be redisplayed, the display --- callback for the window is called. Before the callback, the /current window/ --- is set to the window needing to be redisplayed and (if no overlay display --- callback is registered) the /layer in use/ is set to the normal plane. The --- entire normal plane region should be redisplayed in response to the callback --- (this includes ancillary buffers if your program depends on their state). --- --- GLUT determines when the display callback should be triggered based on the --- window\'s redisplay state. The redisplay state for a window can be either set --- explicitly by calling 'Graphics.UI.GLUT.Window.postRedisplay' or implicitly --- as the result of window damage reported by the window system. Multiple posted --- redisplays for a window are coalesced by GLUT to minimize the number of --- display callbacks called. --- --- When an overlay is established for a window, but there is no overlay display --- callback registered, the display callback is used for redisplaying both the --- overlay and normal plane (that is, it will be called if either the redisplay --- state or overlay redisplay state is set). In this case, the /layer in use/ is --- not implicitly changed on entry to the display callback. --- --- See 'overlayDisplayCallback' to understand how distinct callbacks for the --- overlay and normal plane of a window may be established. --- --- When a window is created, no display callback exists for the window. It is --- the responsibility of the programmer to install a display callback for the --- window before the window is shown. A display callback must be registered for --- any window that is shown. If a window becomes displayed without a display --- callback being registered, a fatal error occurs. There is no way to --- \"deregister\" a display callback (though another callback routine can always --- be registered). --- --- Upon return from the display callback, the normal damaged state of the window --- (see 'Graphics.UI.GLUT.State.damaged') is cleared. If there is no overlay --- display callback registered the overlay damaged state of the window (see --- 'Graphics.UI.GLUT.State.damaged') is also cleared. - -displayCallback :: SettableStateVar DisplayCallback -displayCallback = makeSettableStateVar $ - setCallback DisplayCB glutDisplayFunc makeDisplayFunc . Just - --------------------------------------------------------------------------------- - --- | Controls the overlay display callback for the /current window./ The overlay --- display callback is functionally the same as the window\'s display callback --- except that the overlay display callback is used to redisplay the window\'s --- overlay. --- --- When GLUT determines that the overlay plane for the window needs to be --- redisplayed, the overlay display callback for the window is called. Before --- the callback, the /current window/ is set to the window needing to be --- redisplayed and the /layer in use/ is set to the overlay. The entire overlay --- region should be redisplayed in response to the callback (this includes --- ancillary buffers if your program depends on their state). --- --- GLUT determines when the overlay display callback should be triggered based --- on the window\'s overlay redisplay state. The overlay redisplay state for a --- window can be either set explicitly by calling --- 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay' or implicitly as the result --- of window damage reported by the window system. Multiple posted overlay --- redisplays for a window are coalesced by GLUT to minimize the number of --- overlay display callbacks called. --- --- Upon return from the overlay display callback, the overlay damaged state of --- the window (see 'Graphics.UI.GLUT.State.damaged') is cleared. --- --- Initially there is no overlay display callback registered when an overlay is --- established. See 'displayCallback' to understand how the display callback --- alone is used if an overlay display callback is not registered. - -overlayDisplayCallback :: SettableStateVar (Maybe DisplayCallback) -overlayDisplayCallback = makeSettableStateVar $ - setCallback OverlayDisplayCB glutOverlayDisplayFunc makeOverlayDisplayFunc - --------------------------------------------------------------------------------- - --- | A reshape callback - -type ReshapeCallback = Size -> IO () - --- | Controls the reshape callback for the /current window./ The reshape callback --- is triggered when a window is reshaped. A reshape callback is also triggered --- immediately before a window\'s first display callback after a window is --- created or whenever an overlay for the window is established. The parameter --- of the callback specifies the new window size in pixels. Before the callback, --- the /current window/ is set to the window that has been reshaped. --- --- If a reshape callback is not registered for a window or 'reshapeCallback' is --- set to 'Nothing' (to deregister a previously registered callback), the --- default reshape callback is used. This default callback will simply call --- --- @ --- 'Graphics.Rendering.OpenGL.GL.CoordTrans.viewport' ('Graphics.Rendering.OpenGL.GL.CoordTrans.Position' 0 0) ('Graphics.Rendering.OpenGL.GL.CoordTrans.Size' /width/ /height/) --- @ --- --- on the normal plane (and on the overlay if one exists). --- --- If an overlay is established for the window, a single reshape callback is --- generated. It is the callback\'s responsibility to update both the normal --- plane and overlay for the window (changing the layer in use as necessary). --- --- When a top-level window is reshaped, subwindows are not reshaped. It is up to --- the GLUT program to manage the size and positions of subwindows within a --- top-level window. Still, reshape callbacks will be triggered for subwindows --- when their size is changed using 'Graphics.UI.GLUT.Window.windowSize'. - -reshapeCallback :: SettableStateVar (Maybe ReshapeCallback) -reshapeCallback = makeSettableStateVar $ - setCallback ReshapeCB glutReshapeFunc (makeReshapeFunc . unmarshal) - where unmarshal cb w h = cb (Size (fromIntegral w) (fromIntegral h)) - --------------------------------------------------------------------------------- - --- | The visibility state of the /current window/ - -data Visibility - = NotVisible -- ^ No part of the /current window/ is visible, i.e., until the - -- window\'s visibility changes, all further rendering to the - -- window is discarded. - | Visible -- ^ The /current window/ is totally or partially visible. GLUT - -- considers a window visible if any pixel of the window is - -- visible or any pixel of any descendant window is visible on - -- the screen. - deriving ( Eq, Ord, Show ) - -unmarshalVisibility :: CInt -> Visibility -unmarshalVisibility x - | x == glut_NOT_VISIBLE = NotVisible - | x == glut_VISIBLE = Visible - | otherwise = error ("unmarshalVisibility: illegal value " ++ show x) - --------------------------------------------------------------------------------- - --- | A visibility callback - -type VisibilityCallback = Visibility -> IO () - --- | Controls the visibility callback for the /current window./ The visibility --- callback for a window is called when the visibility of a window changes. --- --- If the visibility callback for a window is disabled and later re-enabled, the --- visibility status of the window is undefined; any change in window visibility --- will be reported, that is if you disable a visibility callback and re-enable --- the callback, you are guaranteed the next visibility change will be reported. --- --- Note that you can either use 'visibilityCallback' or 'windowStateCallback', --- but not both, because the former is implemented via the latter. - -visibilityCallback :: SettableStateVar (Maybe VisibilityCallback) -visibilityCallback = makeSettableStateVar $ - setCallback VisibilityCB glutVisibilityFunc - (makeVisibilityFunc . unmarshal) - where unmarshal cb = cb . unmarshalVisibility - --------------------------------------------------------------------------------- - --- | The window state of the /current window/ - -data WindowState - = Unmapped -- ^ The /current window/ is unmapped. - | FullyRetained -- ^ The /current window/ is unobscured. - | PartiallyRetained -- ^ The /current window/ is partially obscured. - | FullyCovered -- ^ The /current window/ is fully obscured. - deriving ( Eq, Ord, Show ) - -unmarshalWindowState :: CInt -> WindowState -unmarshalWindowState x - | x == glut_HIDDEN = Unmapped - | x == glut_FULLY_RETAINED = FullyRetained - | x == glut_PARTIALLY_RETAINED = PartiallyRetained - | x == glut_FULLY_COVERED = FullyCovered - | otherwise = error ("unmarshalWindowState: illegal value " ++ show x) - --------------------------------------------------------------------------------- - --- | A window state callback - -type WindowStateCallback = WindowState -> IO () - --- | Controls the window state callback for the --- /current window./ The window state callback for a window is called when the --- window state of a window changes. --- --- If the window state callback for a window is disabled and later re-enabled, --- the window state state of the window is undefined; any change in the window --- state will be reported, that is if you disable a window state callback and --- re-enable the callback, you are guaranteed the next window state change will --- be reported. --- --- Note that you can either use 'visibilityCallback' or 'windowStateCallback', --- but not both, because the former is implemented via the latter. - -windowStateCallback :: SettableStateVar (Maybe WindowStateCallback) -windowStateCallback = makeSettableStateVar $ - setCallback WindowStatusCB glutWindowStatusFunc - (makeWindowStatusFunc . unmarshal) - where unmarshal cb = cb . unmarshalWindowState - --------------------------------------------------------------------------------- - -type CloseCallback = IO () - -closeCallback :: SettableStateVar (Maybe CloseCallback) -closeCallback = makeSettableStateVar $ - setCallback CloseCB glutCloseFunc makeCloseFunc - --------------------------------------------------------------------------------- - --- | A keyboard callback -type KeyboardCallback = Char -> Position -> IO () - -setKeyboardCallback :: Maybe KeyboardCallback -> IO () -setKeyboardCallback = - setCallback KeyboardCB glutKeyboardFunc (makeKeyboardFunc . unmarshal) - where unmarshal cb c x y = cb (chr (fromIntegral c)) - (Position (fromIntegral x) (fromIntegral y)) - --- | Controls the keyboard callback for the /current window/. This is --- activated only when a key is pressed. -keyboardCallback :: SettableStateVar (Maybe KeyboardCallback) -keyboardCallback = makeSettableStateVar setKeyboardCallback - --------------------------------------------------------------------------------- - -setKeyboardUpCallback :: Maybe KeyboardCallback -> IO () -setKeyboardUpCallback = - setCallback KeyboardUpCB glutKeyboardUpFunc - (makeKeyboardUpFunc . unmarshal) - where unmarshal cb c x y = cb (chr (fromIntegral c)) - (Position (fromIntegral x) (fromIntegral y)) - --- | Controls the keyboard callback for the /current window/. This is --- activated only when a key is released. -keyboardUpCallback :: SettableStateVar (Maybe KeyboardCallback) -keyboardUpCallback = makeSettableStateVar setKeyboardUpCallback --------------------------------------------------------------------------------- - --- | Special keys - -data SpecialKey - = KeyF1 - | KeyF2 - | KeyF3 - | KeyF4 - | KeyF5 - | KeyF6 - | KeyF7 - | KeyF8 - | KeyF9 - | KeyF10 - | KeyF11 - | KeyF12 - | KeyLeft - | KeyUp - | KeyRight - | KeyDown - | KeyPageUp - | KeyPageDown - | KeyHome - | KeyEnd - | KeyInsert - | KeyNumLock - | KeyBegin - | KeyDelete - | KeyUnknown Int - deriving ( Eq, Ord, Show ) - -unmarshalSpecialKey :: CInt -> SpecialKey -unmarshalSpecialKey x - | x == glut_KEY_F1 = KeyF1 - | x == glut_KEY_F2 = KeyF2 - | x == glut_KEY_F3 = KeyF3 - | x == glut_KEY_F4 = KeyF4 - | x == glut_KEY_F5 = KeyF5 - | x == glut_KEY_F6 = KeyF6 - | x == glut_KEY_F7 = KeyF7 - | x == glut_KEY_F8 = KeyF8 - | x == glut_KEY_F9 = KeyF9 - | x == glut_KEY_F10 = KeyF10 - | x == glut_KEY_F11 = KeyF11 - | x == glut_KEY_F12 = KeyF12 - | x == glut_KEY_LEFT = KeyLeft - | x == glut_KEY_UP = KeyUp - | x == glut_KEY_RIGHT = KeyRight - | x == glut_KEY_DOWN = KeyDown - | x == glut_KEY_PAGE_UP = KeyPageUp - | x == glut_KEY_PAGE_DOWN = KeyPageDown - | x == glut_KEY_HOME = KeyHome - | x == glut_KEY_END = KeyEnd - | x == glut_KEY_INSERT = KeyInsert - | x == glut_KEY_NUM_LOCK = KeyNumLock - | x == glut_KEY_BEGIN = KeyBegin - | x == glut_KEY_DELETE = KeyDelete - | otherwise = KeyUnknown (fromIntegral x) - --------------------------------------------------------------------------------- - --- | A special key callback -type SpecialCallback = SpecialKey -> Position -> IO () - -setSpecialCallback :: Maybe SpecialCallback -> IO () -setSpecialCallback = - setCallback SpecialCB glutSpecialFunc (makeSpecialFunc . unmarshal) - where unmarshal cb k x y = cb (unmarshalSpecialKey k) - (Position (fromIntegral x) (fromIntegral y)) - --- | Controls the special key callback for the /current window/. This is --- activated only when a special key is pressed. -specialCallback :: SettableStateVar (Maybe SpecialCallback) -specialCallback = makeSettableStateVar setSpecialCallback --------------------------------------------------------------------------------- - -setSpecialUpCallback :: Maybe SpecialCallback -> IO () -setSpecialUpCallback = - setCallback SpecialUpCB glutSpecialUpFunc (makeSpecialUpFunc . unmarshal) - where unmarshal cb k x y = cb (unmarshalSpecialKey k) - (Position (fromIntegral x) (fromIntegral y)) - --- | Controls the special key callback for the /current window/. This is --- activated only when a special key is released. -specialUpCallback :: SettableStateVar (Maybe SpecialCallback) -specialUpCallback = makeSettableStateVar setSpecialUpCallback --------------------------------------------------------------------------------- - --- | The current state of a key or button - -data KeyState - = Down - | Up - deriving ( Eq, Ord, Show ) - -unmarshalKeyState :: CInt -> KeyState -unmarshalKeyState x - | x == glut_DOWN = Down - | x == glut_UP = Up - | otherwise = error ("unmarshalKeyState: illegal value " ++ show x) - --------------------------------------------------------------------------------- - --- | A mouse callback -type MouseCallback = MouseButton -> KeyState -> Position -> IO () - -setMouseCallback :: Maybe MouseCallback -> IO () -setMouseCallback = - setCallback MouseCB glutMouseFunc (makeMouseFunc . unmarshal) - where unmarshal cb b s x y = cb (unmarshalMouseButton b) - (unmarshalKeyState s) - (Position (fromIntegral x) (fromIntegral y)) - --- | Controls the mouse callback for the /current window/. -mouseCallback :: SettableStateVar (Maybe MouseCallback) -mouseCallback = makeSettableStateVar setMouseCallback --------------------------------------------------------------------------------- - --- | The state of the keyboard modifiers - -data Modifiers = Modifiers { shift, ctrl, alt :: KeyState } - deriving ( Eq, Ord, Show ) - --- Could use fromBitfield + Enum/Bounded instances + marshalModifier instead... -unmarshalModifiers :: CInt -> Modifiers -unmarshalModifiers m = Modifiers { - shift = if (m .&. glut_ACTIVE_SHIFT) /= 0 then Down else Up, - ctrl = if (m .&. glut_ACTIVE_CTRL ) /= 0 then Down else Up, - alt = if (m .&. glut_ACTIVE_ALT ) /= 0 then Down else Up } - -getModifiers :: IO Modifiers -getModifiers = fmap unmarshalModifiers glutGetModifiers - --------------------------------------------------------------------------------- - --- | A generalized view of keys - -data Key - = Char Char - | SpecialKey SpecialKey - | MouseButton MouseButton - deriving ( Eq, Ord, Show ) - --- | A keyboard\/mouse callback - -type KeyboardMouseCallback = - Key -> KeyState -> Modifiers -> Position -> IO () - --- | Controls the keyboard\/mouse callback for the /current window./ The --- keyboard\/mouse callback for a window is called when the state of a key or --- mouse button changes. The callback parameters indicate the new state of the --- key\/button, the state of the keyboard modifiers, and the mouse location in --- window relative coordinates. --- --- Note that this is a convenience function that should not ordinarily be used --- in conjunction with `keyboardCallback`, `keyboardUpCallback`, --- `specialCallback`, `specialUpCallback`, or `mouseCallback`. - -keyboardMouseCallback :: SettableStateVar (Maybe KeyboardMouseCallback) -keyboardMouseCallback = makeSettableStateVar setKeyboardMouseCallback - -setKeyboardMouseCallback :: Maybe KeyboardMouseCallback -> IO () -setKeyboardMouseCallback Nothing = do - setKeyboardCallback Nothing - setKeyboardUpCallback Nothing - setSpecialCallback Nothing - setSpecialUpCallback Nothing - setMouseCallback Nothing -setKeyboardMouseCallback (Just cb) = do - setKeyboardCallback (Just (\c p -> do m <- getModifiers - cb (Char c) Down m p)) - setKeyboardUpCallback (Just (\c p -> do m <- getModifiers - cb (Char c) Up m p)) - setSpecialCallback (Just (\s p -> do m <- getModifiers - cb (SpecialKey s) Down m p)) - setSpecialUpCallback (Just (\s p -> do m <- getModifiers - cb (SpecialKey s) Up m p)) - setMouseCallback (Just (\b s p -> do m <- getModifiers - cb (MouseButton b) s m p)) - --------------------------------------------------------------------------------- - -type WheelNumber = Int - -type WheelDirection = Int - -type MouseWheelCallback = WheelNumber -> WheelDirection -> Position -> IO () - --- | (/freeglut only/) Controls the mouse wheel callback for the --- /current window./ The mouse wheel callback for a window is called when a --- mouse wheel is used and the wheel number is greater than or equal to --- 'Graphics.UI.GLUT.State.numMouseButtons'. - -mouseWheelCallback :: SettableStateVar (Maybe MouseWheelCallback) -mouseWheelCallback = makeSettableStateVar $ - setCallback MouseWheelCB glutMouseWheelFunc (makeMouseWheelFunc . unmarshal) - where unmarshal cb n d x y = cb (fromIntegral n) (fromIntegral d) - (Position (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - --- | A motion callback - -type MotionCallback = Position -> IO () - --- | Controls the motion callback for the /current window./ The motion callback --- for a window is called when the mouse moves within the window while one or --- more mouse buttons are pressed. The callback parameter indicates the mouse --- location in window relative coordinates. - -motionCallback :: SettableStateVar (Maybe MotionCallback) -motionCallback = makeSettableStateVar $ - setCallback MotionCB glutMotionFunc (makeMotionFunc . unmarshal) - where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - --- | Controls the passive motion callback for the /current window./ The passive --- motion callback for a window is called when the mouse moves within the window --- while /no/ mouse buttons are pressed. The callback parameter indicates the --- mouse location in window relative coordinates. - -passiveMotionCallback :: SettableStateVar (Maybe MotionCallback) -passiveMotionCallback = makeSettableStateVar $ - setCallback PassiveMotionCB glutPassiveMotionFunc - (makePassiveMotionFunc . unmarshal) - where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - --- | The relation between the mouse pointer and the /current window/ has --- changed. - -data Crossing - = WindowLeft -- ^ The mouse pointer has left the /current window./ - | WindowEntered -- ^ The mouse pointer has entered the /current window./ - deriving ( Eq, Ord, Show ) - -unmarshalCrossing :: CInt -> Crossing -unmarshalCrossing x - | x == glut_LEFT = WindowLeft - | x == glut_ENTERED = WindowEntered - | otherwise = error ("unmarshalCrossing: illegal value " ++ show x) - --------------------------------------------------------------------------------- - --- | An enter\/leave callback - -type CrossingCallback = Crossing -> IO () - --- | Controls the mouse enter\/leave callback for the /current window./ Note --- that some window systems may not generate accurate enter\/leave callbacks. --- --- /X Implementation Notes:/ An X implementation of GLUT should generate --- accurate enter\/leave callbacks. - -crossingCallback :: SettableStateVar (Maybe CrossingCallback) -crossingCallback = makeSettableStateVar $ - setCallback CrossingCB glutEntryFunc (makeEntryFunc . unmarshal) - where unmarshal cb = cb . unmarshalCrossing - --------------------------------------------------------------------------------- - --- | Translation of the Spaceball along one axis, normalized to be in the range --- of -1000 to +1000 inclusive - -type SpaceballMotion = Int - --- | Rotation of the Spaceball along one axis, normalized to be in the range --- of -1800 .. +1800 inclusive - -type SpaceballRotation = Int - --- | The index of a specific buttons of an input device. - -type ButtonIndex = Int - --- | The state of the Spaceball has changed. - -data SpaceballInput - = SpaceballMotion SpaceballMotion SpaceballMotion SpaceballMotion - | SpaceballRotation SpaceballRotation SpaceballRotation SpaceballRotation - | SpaceballButton ButtonIndex KeyState - deriving ( Eq, Ord, Show ) - --- | A SpaceballButton callback - -type SpaceballCallback = SpaceballInput -> IO () - --- | Controls the Spaceball callback for the /current window./ The Spaceball --- callback for a window is called when the window has Spaceball input focus --- (normally, when the mouse is in the window) and the user generates Spaceball --- translations, rotations, or button presses. The number of available Spaceball --- buttons can be determined with 'Graphics.UI.GLUT.State.numSpaceballButtons'. --- --- Registering a Spaceball callback when a Spaceball device is not available has --- no effect and is not an error. In this case, no Spaceball callbacks will be --- generated. - -spaceballCallback :: SettableStateVar (Maybe SpaceballCallback) -spaceballCallback = makeSettableStateVar setSpaceballCallback - -setSpaceballCallback :: Maybe SpaceballCallback -> IO () -setSpaceballCallback Nothing = do - setSpaceballMotionCallback Nothing - setSpaceballRotationCallback Nothing - setSpaceballButtonCallback Nothing -setSpaceballCallback (Just cb) = do - setSpaceballMotionCallback (Just (\x y z -> cb (SpaceballMotion x y z))) - setSpaceballRotationCallback (Just (\x y z -> cb (SpaceballRotation x y z))) - setSpaceballButtonCallback (Just (\b s -> cb (SpaceballButton b s))) - --------------------------------------------------------------------------------- - -type SpaceballMotionCallback = - SpaceballMotion -> SpaceballMotion -> SpaceballMotion -> IO () - -setSpaceballMotionCallback :: Maybe SpaceballMotionCallback -> IO () -setSpaceballMotionCallback = - setCallback SpaceballMotionCB glutSpaceballMotionFunc - (makeSpaceballMotionFunc . unmarshal) - where unmarshal cb x y z = - cb (fromIntegral x) (fromIntegral y) (fromIntegral z) - --------------------------------------------------------------------------------- - -type SpaceballRotationCallback = - SpaceballRotation -> SpaceballRotation -> SpaceballRotation -> IO () - -setSpaceballRotationCallback :: Maybe SpaceballRotationCallback -> IO () -setSpaceballRotationCallback = - setCallback SpaceballRotateCB glutSpaceballRotateFunc - (makeSpaceballRotateFunc . unmarshal) - where unmarshal cb x y z = - cb (fromIntegral x) (fromIntegral y) (fromIntegral z) - --------------------------------------------------------------------------------- - -type SpaceballButtonCallback = ButtonIndex -> KeyState -> IO () - -setSpaceballButtonCallback :: Maybe SpaceballButtonCallback -> IO () -setSpaceballButtonCallback = - setCallback SpaceballButtonCB glutSpaceballButtonFunc - (makeSpaceballButtonFunc . unmarshal) - where unmarshal cb b s = cb (fromIntegral b) (unmarshalKeyState s) - --------------------------------------------------------------------------------- - --- | The index of a specific dial of a dial and button box. - -type DialIndex = Int - --- | The dial & button box state has changed. - -data DialAndButtonBoxInput - = DialAndButtonBoxButton ButtonIndex KeyState - | DialAndButtonBoxDial DialIndex Int - deriving ( Eq, Ord, Show ) - --- | A dial & button box callback - -type DialAndButtonBoxCallback = DialAndButtonBoxInput -> IO () - --- | Controls the dial & button box callback for the /current window./ The dial --- & button box button callback for a window is called when the window has dial --- & button box input focus (normally, when the mouse is in the window) and the --- user generates dial & button box button presses or dial changes. The number --- of available dial & button box buttons and dials can be determined with --- 'Graphics.UI.GLUT.State.numDialsAndButtons'. --- --- Registering a dial & button box callback when a dial & button box device is --- not available is ineffectual and not an error. In this case, no dial & button --- box button will be generated. - -dialAndButtonBoxCallback :: SettableStateVar (Maybe DialAndButtonBoxCallback) -dialAndButtonBoxCallback = makeSettableStateVar setDialAndButtonBoxCallback - -setDialAndButtonBoxCallback :: Maybe DialAndButtonBoxCallback -> IO () -setDialAndButtonBoxCallback Nothing = do - setButtonBoxCallback Nothing - setDialsCallback Nothing -setDialAndButtonBoxCallback (Just cb) = do - setButtonBoxCallback (Just (\b s -> cb (DialAndButtonBoxButton b s))) - setDialsCallback (Just (\d x -> cb (DialAndButtonBoxDial d x))) - --------------------------------------------------------------------------------- - -type ButtonBoxCallback = ButtonIndex -> KeyState -> IO () - -setButtonBoxCallback :: Maybe ButtonBoxCallback -> IO () -setButtonBoxCallback = - setCallback ButtonBoxCB glutButtonBoxFunc (makeButtonBoxFunc . unmarshal) - where unmarshal cb b s = cb (fromIntegral b) (unmarshalKeyState s) - --------------------------------------------------------------------------------- - -type DialsCallback = DialIndex -> Int -> IO () - -setDialsCallback :: Maybe DialsCallback -> IO () -setDialsCallback = - setCallback DialsCB glutDialsFunc (makeDialsFunc . unmarshal) - where unmarshal cb d x = cb (fromIntegral d) (fromIntegral x) - --------------------------------------------------------------------------------- - --- | Absolute tablet position, with coordinates normalized to be in the range of --- 0 to 2000 inclusive - -data TabletPosition = TabletPosition Int Int - deriving ( Eq, Ord, Show ) - --- | The table state has changed. - -data TabletInput - = TabletMotion - | TabletButton ButtonIndex KeyState - deriving ( Eq, Ord, Show ) - --- | A tablet callback - -type TabletCallback = TabletInput -> TabletPosition -> IO () - --- | Controls the tablet callback for the /current window./ The tablet callback --- for a window is called when the window has tablet input focus (normally, when --- the mouse is in the window) and the user generates tablet motion or button --- presses. The number of available tablet buttons can be determined with --- 'Graphics.UI.GLUT.State.numTabletButtons'. --- --- Registering a tablet callback when a tablet device is not available is --- ineffectual and not an error. In this case, no tablet callbacks will be --- generated. - -tabletCallback :: SettableStateVar (Maybe TabletCallback) -tabletCallback = makeSettableStateVar setTabletCallback - -setTabletCallback :: Maybe TabletCallback -> IO () -setTabletCallback Nothing = do - setTabletMotionCallback Nothing - setTabletButtonCallback Nothing -setTabletCallback (Just cb) = do - setTabletMotionCallback (Just (\p -> cb TabletMotion p)) - setTabletButtonCallback (Just (\b s p -> cb (TabletButton b s) p)) - --------------------------------------------------------------------------------- - -type TabletMotionCallback = TabletPosition -> IO () - -setTabletMotionCallback :: Maybe TabletMotionCallback -> IO () -setTabletMotionCallback = - setCallback TabletMotionCB glutTabletMotionFunc - (makeTabletMotionFunc . unmarshal) - where unmarshal cb x y = - cb (TabletPosition (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - -type TabletButtonCallback = ButtonIndex -> KeyState -> TabletPosition -> IO () - -setTabletButtonCallback :: Maybe TabletButtonCallback -> IO () -setTabletButtonCallback = - setCallback TabletButtonCB glutTabletButtonFunc - (makeTabletButtonFunc . unmarshal) - where unmarshal cb b s x y = - cb (fromIntegral b) (unmarshalKeyState s) - (TabletPosition (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - --- | The state of the joystick buttons - -data JoystickButtons = JoystickButtons { - joystickButtonA, joystickButtonB, - joystickButtonC, joystickButtonD :: KeyState } - deriving ( Eq, Ord, Show ) - --- Could use fromBitfield + Enum/Bounded instances + unmarshalJoystickButton --- instead... -unmarshalJoystickButtons :: CUInt -> JoystickButtons -unmarshalJoystickButtons m = JoystickButtons { - joystickButtonA = if (m .&. glut_JOYSTICK_BUTTON_A) /= 0 then Down else Up, - joystickButtonB = if (m .&. glut_JOYSTICK_BUTTON_B) /= 0 then Down else Up, - joystickButtonC = if (m .&. glut_JOYSTICK_BUTTON_C) /= 0 then Down else Up, - joystickButtonD = if (m .&. glut_JOYSTICK_BUTTON_D) /= 0 then Down else Up } - --------------------------------------------------------------------------------- - --- | Absolute joystick position, with coordinates normalized to be in the range --- of -1000 to 1000 inclusive. The signs of the three axes mean the following: --- --- * negative = left, positive = right --- --- * negative = towards player, positive = away --- --- * if available (e.g. rudder): negative = down, positive = up - -data JoystickPosition = JoystickPosition Int Int Int - deriving ( Eq, Ord, Show ) - --------------------------------------------------------------------------------- - --- | A joystick callback - -type JoystickCallback = JoystickButtons -> JoystickPosition -> IO () - --- | Controls the joystick callback for the /current window./ The joystick --- callback is called either due to polling of the joystick at the uniform timer --- interval specified (if > 0) or in response to an explicit call of --- 'Graphics.UI.GLUT.DeviceControl.forceJoystickCallback'. --- --- /X Implementation Notes:/ Currently GLUT has no joystick support for X11. - --- joystickCallback :: SettableStateVar (Maybe JoystickCallback, PollRate) -joystickCallback :: SettableStateVar (Maybe (JoystickCallback, PollRate)) -joystickCallback = - makeSettableStateVar $ \maybeCBAndRate -> - setCallback JoystickCB - (\f -> glutJoystickFunc f (fromIntegral (snd (fromJust maybeCBAndRate)))) - (makeJoystickFunc . unmarshal) - (fmap fst maybeCBAndRate) - where unmarshal cb b x y z = cb (unmarshalJoystickButtons b) - (JoystickPosition (fromIntegral x) - (fromIntegral y) - (fromIntegral z)) +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Callbacks.Window +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Callbacks.Window ( + -- * Redisplay callbacks + DisplayCallback, displayCallback, overlayDisplayCallback, + + -- * Reshape callback + ReshapeCallback, reshapeCallback, + + -- * Callbacks for visibility changes + Visibility(..), VisibilityCallback, visibilityCallback, + WindowState(..), WindowStateCallback, windowStateCallback, + + -- * Window close callback + CloseCallback, closeCallback, + + -- * Keyboard callback + KeyboardCallback, keyboardCallback, keyboardUpCallback, + + -- * Special callback + SpecialCallback, specialCallback, specialUpCallback, + + -- * Mouse callback + MouseCallback, mouseCallback, + + -- * Keyboard and mouse input callback + Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..), + KeyboardMouseCallback, keyboardMouseCallback, + + -- * Mouse wheel callback + WheelNumber, WheelDirection, MouseWheelCallback, mouseWheelCallback, + + -- * Mouse movement callbacks + MotionCallback, motionCallback, passiveMotionCallback, + Crossing(..), CrossingCallback, crossingCallback, + + -- * Spaceball callback + SpaceballMotion, SpaceballRotation, ButtonIndex, SpaceballInput(..), + SpaceballCallback, spaceballCallback, + + -- * Dial & button box callback + DialAndButtonBoxInput(..), DialIndex, + DialAndButtonBoxCallback, dialAndButtonBoxCallback, + + -- * Tablet callback + TabletPosition(..), TabletInput(..), TabletCallback, tabletCallback, + + -- * Joystick callback + JoystickButtons(..), JoystickPosition(..), + JoystickCallback, joystickCallback +) where + +import Data.Bits hiding ( shift ) +import Data.Char +import Data.Maybe +import Foreign.C.Types +import Graphics.Rendering.OpenGL ( Position(..), Size(..) + , SettableStateVar, makeSettableStateVar ) +import Graphics.UI.GLUT.Callbacks.Registration +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.State +import Graphics.UI.GLUT.Types + +-------------------------------------------------------------------------------- + +-- | A display callback + +type DisplayCallback = IO () + +-- | Controls the display callback for the /current window./ When GLUT determines +-- that the normal plane for the window needs to be redisplayed, the display +-- callback for the window is called. Before the callback, the /current window/ +-- is set to the window needing to be redisplayed and (if no overlay display +-- callback is registered) the /layer in use/ is set to the normal plane. The +-- entire normal plane region should be redisplayed in response to the callback +-- (this includes ancillary buffers if your program depends on their state). +-- +-- GLUT determines when the display callback should be triggered based on the +-- window\'s redisplay state. The redisplay state for a window can be either set +-- explicitly by calling 'Graphics.UI.GLUT.Window.postRedisplay' or implicitly +-- as the result of window damage reported by the window system. Multiple posted +-- redisplays for a window are coalesced by GLUT to minimize the number of +-- display callbacks called. +-- +-- When an overlay is established for a window, but there is no overlay display +-- callback registered, the display callback is used for redisplaying both the +-- overlay and normal plane (that is, it will be called if either the redisplay +-- state or overlay redisplay state is set). In this case, the /layer in use/ is +-- not implicitly changed on entry to the display callback. +-- +-- See 'overlayDisplayCallback' to understand how distinct callbacks for the +-- overlay and normal plane of a window may be established. +-- +-- When a window is created, no display callback exists for the window. It is +-- the responsibility of the programmer to install a display callback for the +-- window before the window is shown. A display callback must be registered for +-- any window that is shown. If a window becomes displayed without a display +-- callback being registered, a fatal error occurs. There is no way to +-- \"deregister\" a display callback (though another callback routine can always +-- be registered). +-- +-- Upon return from the display callback, the normal damaged state of the window +-- (see 'Graphics.UI.GLUT.State.damaged') is cleared. If there is no overlay +-- display callback registered the overlay damaged state of the window (see +-- 'Graphics.UI.GLUT.State.damaged') is also cleared. + +displayCallback :: SettableStateVar DisplayCallback +displayCallback = makeSettableStateVar $ + setCallback DisplayCB glutDisplayFunc makeDisplayFunc . Just + +-------------------------------------------------------------------------------- + +-- | Controls the overlay display callback for the /current window./ The overlay +-- display callback is functionally the same as the window\'s display callback +-- except that the overlay display callback is used to redisplay the window\'s +-- overlay. +-- +-- When GLUT determines that the overlay plane for the window needs to be +-- redisplayed, the overlay display callback for the window is called. Before +-- the callback, the /current window/ is set to the window needing to be +-- redisplayed and the /layer in use/ is set to the overlay. The entire overlay +-- region should be redisplayed in response to the callback (this includes +-- ancillary buffers if your program depends on their state). +-- +-- GLUT determines when the overlay display callback should be triggered based +-- on the window\'s overlay redisplay state. The overlay redisplay state for a +-- window can be either set explicitly by calling +-- 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay' or implicitly as the result +-- of window damage reported by the window system. Multiple posted overlay +-- redisplays for a window are coalesced by GLUT to minimize the number of +-- overlay display callbacks called. +-- +-- Upon return from the overlay display callback, the overlay damaged state of +-- the window (see 'Graphics.UI.GLUT.State.damaged') is cleared. +-- +-- Initially there is no overlay display callback registered when an overlay is +-- established. See 'displayCallback' to understand how the display callback +-- alone is used if an overlay display callback is not registered. + +overlayDisplayCallback :: SettableStateVar (Maybe DisplayCallback) +overlayDisplayCallback = makeSettableStateVar $ + setCallback OverlayDisplayCB glutOverlayDisplayFunc makeOverlayDisplayFunc + +-------------------------------------------------------------------------------- + +-- | A reshape callback + +type ReshapeCallback = Size -> IO () + +-- | Controls the reshape callback for the /current window./ The reshape callback +-- is triggered when a window is reshaped. A reshape callback is also triggered +-- immediately before a window\'s first display callback after a window is +-- created or whenever an overlay for the window is established. The parameter +-- of the callback specifies the new window size in pixels. Before the callback, +-- the /current window/ is set to the window that has been reshaped. +-- +-- If a reshape callback is not registered for a window or 'reshapeCallback' is +-- set to 'Nothing' (to deregister a previously registered callback), the +-- default reshape callback is used. This default callback will simply call +-- +-- @ +-- 'Graphics.Rendering.OpenGL.GL.CoordTrans.viewport' ('Graphics.Rendering.OpenGL.GL.CoordTrans.Position' 0 0) ('Graphics.Rendering.OpenGL.GL.CoordTrans.Size' /width/ /height/) +-- @ +-- +-- on the normal plane (and on the overlay if one exists). +-- +-- If an overlay is established for the window, a single reshape callback is +-- generated. It is the callback\'s responsibility to update both the normal +-- plane and overlay for the window (changing the layer in use as necessary). +-- +-- When a top-level window is reshaped, subwindows are not reshaped. It is up to +-- the GLUT program to manage the size and positions of subwindows within a +-- top-level window. Still, reshape callbacks will be triggered for subwindows +-- when their size is changed using 'Graphics.UI.GLUT.Window.windowSize'. + +reshapeCallback :: SettableStateVar (Maybe ReshapeCallback) +reshapeCallback = makeSettableStateVar $ + setCallback ReshapeCB glutReshapeFunc (makeReshapeFunc . unmarshal) + where unmarshal cb w h = cb (Size (fromIntegral w) (fromIntegral h)) + +-------------------------------------------------------------------------------- + +-- | The visibility state of the /current window/ + +data Visibility + = NotVisible -- ^ No part of the /current window/ is visible, i.e., until the + -- window\'s visibility changes, all further rendering to the + -- window is discarded. + | Visible -- ^ The /current window/ is totally or partially visible. GLUT + -- considers a window visible if any pixel of the window is + -- visible or any pixel of any descendant window is visible on + -- the screen. + deriving ( Eq, Ord, Show ) + +unmarshalVisibility :: CInt -> Visibility +unmarshalVisibility x + | x == glut_NOT_VISIBLE = NotVisible + | x == glut_VISIBLE = Visible + | otherwise = error ("unmarshalVisibility: illegal value " ++ show x) + +-------------------------------------------------------------------------------- + +-- | A visibility callback + +type VisibilityCallback = Visibility -> IO () + +-- | Controls the visibility callback for the /current window./ The visibility +-- callback for a window is called when the visibility of a window changes. +-- +-- If the visibility callback for a window is disabled and later re-enabled, the +-- visibility status of the window is undefined; any change in window visibility +-- will be reported, that is if you disable a visibility callback and re-enable +-- the callback, you are guaranteed the next visibility change will be reported. +-- +-- Note that you can either use 'visibilityCallback' or 'windowStateCallback', +-- but not both, because the former is implemented via the latter. + +visibilityCallback :: SettableStateVar (Maybe VisibilityCallback) +visibilityCallback = makeSettableStateVar $ + setCallback VisibilityCB glutVisibilityFunc + (makeVisibilityFunc . unmarshal) + where unmarshal cb = cb . unmarshalVisibility + +-------------------------------------------------------------------------------- + +-- | The window state of the /current window/ + +data WindowState + = Unmapped -- ^ The /current window/ is unmapped. + | FullyRetained -- ^ The /current window/ is unobscured. + | PartiallyRetained -- ^ The /current window/ is partially obscured. + | FullyCovered -- ^ The /current window/ is fully obscured. + deriving ( Eq, Ord, Show ) + +unmarshalWindowState :: CInt -> WindowState +unmarshalWindowState x + | x == glut_HIDDEN = Unmapped + | x == glut_FULLY_RETAINED = FullyRetained + | x == glut_PARTIALLY_RETAINED = PartiallyRetained + | x == glut_FULLY_COVERED = FullyCovered + | otherwise = error ("unmarshalWindowState: illegal value " ++ show x) + +-------------------------------------------------------------------------------- + +-- | A window state callback + +type WindowStateCallback = WindowState -> IO () + +-- | Controls the window state callback for the +-- /current window./ The window state callback for a window is called when the +-- window state of a window changes. +-- +-- If the window state callback for a window is disabled and later re-enabled, +-- the window state state of the window is undefined; any change in the window +-- state will be reported, that is if you disable a window state callback and +-- re-enable the callback, you are guaranteed the next window state change will +-- be reported. +-- +-- Note that you can either use 'visibilityCallback' or 'windowStateCallback', +-- but not both, because the former is implemented via the latter. + +windowStateCallback :: SettableStateVar (Maybe WindowStateCallback) +windowStateCallback = makeSettableStateVar $ + setCallback WindowStatusCB glutWindowStatusFunc + (makeWindowStatusFunc . unmarshal) + where unmarshal cb = cb . unmarshalWindowState + +-------------------------------------------------------------------------------- + +type CloseCallback = IO () + +closeCallback :: SettableStateVar (Maybe CloseCallback) +closeCallback = makeSettableStateVar $ + setCallback CloseCB glutCloseFunc makeCloseFunc + +-------------------------------------------------------------------------------- + +-- | A keyboard callback +type KeyboardCallback = Char -> Position -> IO () + +setKeyboardCallback :: Maybe KeyboardCallback -> IO () +setKeyboardCallback = + setCallback KeyboardCB glutKeyboardFunc (makeKeyboardFunc . unmarshal) + where unmarshal cb c x y = cb (chr (fromIntegral c)) + (Position (fromIntegral x) (fromIntegral y)) + +-- | Controls the keyboard callback for the /current window/. This is +-- activated only when a key is pressed. +keyboardCallback :: SettableStateVar (Maybe KeyboardCallback) +keyboardCallback = makeSettableStateVar setKeyboardCallback + +-------------------------------------------------------------------------------- + +setKeyboardUpCallback :: Maybe KeyboardCallback -> IO () +setKeyboardUpCallback = + setCallback KeyboardUpCB glutKeyboardUpFunc + (makeKeyboardUpFunc . unmarshal) + where unmarshal cb c x y = cb (chr (fromIntegral c)) + (Position (fromIntegral x) (fromIntegral y)) + +-- | Controls the keyboard callback for the /current window/. This is +-- activated only when a key is released. +keyboardUpCallback :: SettableStateVar (Maybe KeyboardCallback) +keyboardUpCallback = makeSettableStateVar setKeyboardUpCallback +-------------------------------------------------------------------------------- + +-- | Special keys + +data SpecialKey + = KeyF1 + | KeyF2 + | KeyF3 + | KeyF4 + | KeyF5 + | KeyF6 + | KeyF7 + | KeyF8 + | KeyF9 + | KeyF10 + | KeyF11 + | KeyF12 + | KeyLeft + | KeyUp + | KeyRight + | KeyDown + | KeyPageUp + | KeyPageDown + | KeyHome + | KeyEnd + | KeyInsert + | KeyNumLock + | KeyBegin + | KeyDelete + | KeyUnknown Int + deriving ( Eq, Ord, Show ) + +unmarshalSpecialKey :: CInt -> SpecialKey +unmarshalSpecialKey x + | x == glut_KEY_F1 = KeyF1 + | x == glut_KEY_F2 = KeyF2 + | x == glut_KEY_F3 = KeyF3 + | x == glut_KEY_F4 = KeyF4 + | x == glut_KEY_F5 = KeyF5 + | x == glut_KEY_F6 = KeyF6 + | x == glut_KEY_F7 = KeyF7 + | x == glut_KEY_F8 = KeyF8 + | x == glut_KEY_F9 = KeyF9 + | x == glut_KEY_F10 = KeyF10 + | x == glut_KEY_F11 = KeyF11 + | x == glut_KEY_F12 = KeyF12 + | x == glut_KEY_LEFT = KeyLeft + | x == glut_KEY_UP = KeyUp + | x == glut_KEY_RIGHT = KeyRight + | x == glut_KEY_DOWN = KeyDown + | x == glut_KEY_PAGE_UP = KeyPageUp + | x == glut_KEY_PAGE_DOWN = KeyPageDown + | x == glut_KEY_HOME = KeyHome + | x == glut_KEY_END = KeyEnd + | x == glut_KEY_INSERT = KeyInsert + | x == glut_KEY_NUM_LOCK = KeyNumLock + | x == glut_KEY_BEGIN = KeyBegin + | x == glut_KEY_DELETE = KeyDelete + | otherwise = KeyUnknown (fromIntegral x) + +-------------------------------------------------------------------------------- + +-- | A special key callback +type SpecialCallback = SpecialKey -> Position -> IO () + +setSpecialCallback :: Maybe SpecialCallback -> IO () +setSpecialCallback = + setCallback SpecialCB glutSpecialFunc (makeSpecialFunc . unmarshal) + where unmarshal cb k x y = cb (unmarshalSpecialKey k) + (Position (fromIntegral x) (fromIntegral y)) + +-- | Controls the special key callback for the /current window/. This is +-- activated only when a special key is pressed. +specialCallback :: SettableStateVar (Maybe SpecialCallback) +specialCallback = makeSettableStateVar setSpecialCallback +-------------------------------------------------------------------------------- + +setSpecialUpCallback :: Maybe SpecialCallback -> IO () +setSpecialUpCallback = + setCallback SpecialUpCB glutSpecialUpFunc (makeSpecialUpFunc . unmarshal) + where unmarshal cb k x y = cb (unmarshalSpecialKey k) + (Position (fromIntegral x) (fromIntegral y)) + +-- | Controls the special key callback for the /current window/. This is +-- activated only when a special key is released. +specialUpCallback :: SettableStateVar (Maybe SpecialCallback) +specialUpCallback = makeSettableStateVar setSpecialUpCallback +-------------------------------------------------------------------------------- + +-- | The current state of a key or button + +data KeyState + = Down + | Up + deriving ( Eq, Ord, Show ) + +unmarshalKeyState :: CInt -> KeyState +unmarshalKeyState x + | x == glut_DOWN = Down + | x == glut_UP = Up + | otherwise = error ("unmarshalKeyState: illegal value " ++ show x) + +-------------------------------------------------------------------------------- + +-- | A mouse callback +type MouseCallback = MouseButton -> KeyState -> Position -> IO () + +setMouseCallback :: Maybe MouseCallback -> IO () +setMouseCallback = + setCallback MouseCB glutMouseFunc (makeMouseFunc . unmarshal) + where unmarshal cb b s x y = cb (unmarshalMouseButton b) + (unmarshalKeyState s) + (Position (fromIntegral x) (fromIntegral y)) + +-- | Controls the mouse callback for the /current window/. +mouseCallback :: SettableStateVar (Maybe MouseCallback) +mouseCallback = makeSettableStateVar setMouseCallback +-------------------------------------------------------------------------------- + +-- | The state of the keyboard modifiers + +data Modifiers = Modifiers { shift, ctrl, alt :: KeyState } + deriving ( Eq, Ord, Show ) + +-- Could use fromBitfield + Enum/Bounded instances + marshalModifier instead... +unmarshalModifiers :: CInt -> Modifiers +unmarshalModifiers m = Modifiers { + shift = if (m .&. glut_ACTIVE_SHIFT) /= 0 then Down else Up, + ctrl = if (m .&. glut_ACTIVE_CTRL ) /= 0 then Down else Up, + alt = if (m .&. glut_ACTIVE_ALT ) /= 0 then Down else Up } + +getModifiers :: IO Modifiers +getModifiers = fmap unmarshalModifiers glutGetModifiers + +-------------------------------------------------------------------------------- + +-- | A generalized view of keys + +data Key + = Char Char + | SpecialKey SpecialKey + | MouseButton MouseButton + deriving ( Eq, Ord, Show ) + +-- | A keyboard\/mouse callback + +type KeyboardMouseCallback = + Key -> KeyState -> Modifiers -> Position -> IO () + +-- | Controls the keyboard\/mouse callback for the /current window./ The +-- keyboard\/mouse callback for a window is called when the state of a key or +-- mouse button changes. The callback parameters indicate the new state of the +-- key\/button, the state of the keyboard modifiers, and the mouse location in +-- window relative coordinates. +-- +-- Note that this is a convenience function that should not ordinarily be used +-- in conjunction with `keyboardCallback`, `keyboardUpCallback`, +-- `specialCallback`, `specialUpCallback`, or `mouseCallback`. + +keyboardMouseCallback :: SettableStateVar (Maybe KeyboardMouseCallback) +keyboardMouseCallback = makeSettableStateVar setKeyboardMouseCallback + +setKeyboardMouseCallback :: Maybe KeyboardMouseCallback -> IO () +setKeyboardMouseCallback Nothing = do + setKeyboardCallback Nothing + setKeyboardUpCallback Nothing + setSpecialCallback Nothing + setSpecialUpCallback Nothing + setMouseCallback Nothing +setKeyboardMouseCallback (Just cb) = do + setKeyboardCallback (Just (\c p -> do m <- getModifiers + cb (Char c) Down m p)) + setKeyboardUpCallback (Just (\c p -> do m <- getModifiers + cb (Char c) Up m p)) + setSpecialCallback (Just (\s p -> do m <- getModifiers + cb (SpecialKey s) Down m p)) + setSpecialUpCallback (Just (\s p -> do m <- getModifiers + cb (SpecialKey s) Up m p)) + setMouseCallback (Just (\b s p -> do m <- getModifiers + cb (MouseButton b) s m p)) + +-------------------------------------------------------------------------------- + +type WheelNumber = Int + +type WheelDirection = Int + +type MouseWheelCallback = WheelNumber -> WheelDirection -> Position -> IO () + +-- | (/freeglut only/) Controls the mouse wheel callback for the +-- /current window./ The mouse wheel callback for a window is called when a +-- mouse wheel is used and the wheel number is greater than or equal to +-- 'Graphics.UI.GLUT.State.numMouseButtons'. + +mouseWheelCallback :: SettableStateVar (Maybe MouseWheelCallback) +mouseWheelCallback = makeSettableStateVar $ + setCallback MouseWheelCB glutMouseWheelFunc (makeMouseWheelFunc . unmarshal) + where unmarshal cb n d x y = cb (fromIntegral n) (fromIntegral d) + (Position (fromIntegral x) (fromIntegral y)) + +-------------------------------------------------------------------------------- + +-- | A motion callback + +type MotionCallback = Position -> IO () + +-- | Controls the motion callback for the /current window./ The motion callback +-- for a window is called when the mouse moves within the window while one or +-- more mouse buttons are pressed. The callback parameter indicates the mouse +-- location in window relative coordinates. + +motionCallback :: SettableStateVar (Maybe MotionCallback) +motionCallback = makeSettableStateVar $ + setCallback MotionCB glutMotionFunc (makeMotionFunc . unmarshal) + where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y)) + +-------------------------------------------------------------------------------- + +-- | Controls the passive motion callback for the /current window./ The passive +-- motion callback for a window is called when the mouse moves within the window +-- while /no/ mouse buttons are pressed. The callback parameter indicates the +-- mouse location in window relative coordinates. + +passiveMotionCallback :: SettableStateVar (Maybe MotionCallback) +passiveMotionCallback = makeSettableStateVar $ + setCallback PassiveMotionCB glutPassiveMotionFunc + (makePassiveMotionFunc . unmarshal) + where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y)) + +-------------------------------------------------------------------------------- + +-- | The relation between the mouse pointer and the /current window/ has +-- changed. + +data Crossing + = WindowLeft -- ^ The mouse pointer has left the /current window./ + | WindowEntered -- ^ The mouse pointer has entered the /current window./ + deriving ( Eq, Ord, Show ) + +unmarshalCrossing :: CInt -> Crossing +unmarshalCrossing x + | x == glut_LEFT = WindowLeft + | x == glut_ENTERED = WindowEntered + | otherwise = error ("unmarshalCrossing: illegal value " ++ show x) + +-------------------------------------------------------------------------------- + +-- | An enter\/leave callback + +type CrossingCallback = Crossing -> IO () + +-- | Controls the mouse enter\/leave callback for the /current window./ Note +-- that some window systems may not generate accurate enter\/leave callbacks. +-- +-- /X Implementation Notes:/ An X implementation of GLUT should generate +-- accurate enter\/leave callbacks. + +crossingCallback :: SettableStateVar (Maybe CrossingCallback) +crossingCallback = makeSettableStateVar $ + setCallback CrossingCB glutEntryFunc (makeEntryFunc . unmarshal) + where unmarshal cb = cb . unmarshalCrossing + +-------------------------------------------------------------------------------- + +-- | Translation of the Spaceball along one axis, normalized to be in the range +-- of -1000 to +1000 inclusive + +type SpaceballMotion = Int + +-- | Rotation of the Spaceball along one axis, normalized to be in the range +-- of -1800 .. +1800 inclusive + +type SpaceballRotation = Int + +-- | The index of a specific buttons of an input device. + +type ButtonIndex = Int + +-- | The state of the Spaceball has changed. + +data SpaceballInput + = SpaceballMotion SpaceballMotion SpaceballMotion SpaceballMotion + | SpaceballRotation SpaceballRotation SpaceballRotation SpaceballRotation + | SpaceballButton ButtonIndex KeyState + deriving ( Eq, Ord, Show ) + +-- | A SpaceballButton callback + +type SpaceballCallback = SpaceballInput -> IO () + +-- | Controls the Spaceball callback for the /current window./ The Spaceball +-- callback for a window is called when the window has Spaceball input focus +-- (normally, when the mouse is in the window) and the user generates Spaceball +-- translations, rotations, or button presses. The number of available Spaceball +-- buttons can be determined with 'Graphics.UI.GLUT.State.numSpaceballButtons'. +-- +-- Registering a Spaceball callback when a Spaceball device is not available has +-- no effect and is not an error. In this case, no Spaceball callbacks will be +-- generated. + +spaceballCallback :: SettableStateVar (Maybe SpaceballCallback) +spaceballCallback = makeSettableStateVar setSpaceballCallback + +setSpaceballCallback :: Maybe SpaceballCallback -> IO () +setSpaceballCallback Nothing = do + setSpaceballMotionCallback Nothing + setSpaceballRotationCallback Nothing + setSpaceballButtonCallback Nothing +setSpaceballCallback (Just cb) = do + setSpaceballMotionCallback (Just (\x y z -> cb (SpaceballMotion x y z))) + setSpaceballRotationCallback (Just (\x y z -> cb (SpaceballRotation x y z))) + setSpaceballButtonCallback (Just (\b s -> cb (SpaceballButton b s))) + +-------------------------------------------------------------------------------- + +type SpaceballMotionCallback = + SpaceballMotion -> SpaceballMotion -> SpaceballMotion -> IO () + +setSpaceballMotionCallback :: Maybe SpaceballMotionCallback -> IO () +setSpaceballMotionCallback = + setCallback SpaceballMotionCB glutSpaceballMotionFunc + (makeSpaceballMotionFunc . unmarshal) + where unmarshal cb x y z = + cb (fromIntegral x) (fromIntegral y) (fromIntegral z) + +-------------------------------------------------------------------------------- + +type SpaceballRotationCallback = + SpaceballRotation -> SpaceballRotation -> SpaceballRotation -> IO () + +setSpaceballRotationCallback :: Maybe SpaceballRotationCallback -> IO () +setSpaceballRotationCallback = + setCallback SpaceballRotateCB glutSpaceballRotateFunc + (makeSpaceballRotateFunc . unmarshal) + where unmarshal cb x y z = + cb (fromIntegral x) (fromIntegral y) (fromIntegral z) + +-------------------------------------------------------------------------------- + +type SpaceballButtonCallback = ButtonIndex -> KeyState -> IO () + +setSpaceballButtonCallback :: Maybe SpaceballButtonCallback -> IO () +setSpaceballButtonCallback = + setCallback SpaceballButtonCB glutSpaceballButtonFunc + (makeSpaceballButtonFunc . unmarshal) + where unmarshal cb b s = cb (fromIntegral b) (unmarshalKeyState s) + +-------------------------------------------------------------------------------- + +-- | The index of a specific dial of a dial and button box. + +type DialIndex = Int + +-- | The dial & button box state has changed. + +data DialAndButtonBoxInput + = DialAndButtonBoxButton ButtonIndex KeyState + | DialAndButtonBoxDial DialIndex Int + deriving ( Eq, Ord, Show ) + +-- | A dial & button box callback + +type DialAndButtonBoxCallback = DialAndButtonBoxInput -> IO () + +-- | Controls the dial & button box callback for the /current window./ The dial +-- & button box button callback for a window is called when the window has dial +-- & button box input focus (normally, when the mouse is in the window) and the +-- user generates dial & button box button presses or dial changes. The number +-- of available dial & button box buttons and dials can be determined with +-- 'Graphics.UI.GLUT.State.numDialsAndButtons'. +-- +-- Registering a dial & button box callback when a dial & button box device is +-- not available is ineffectual and not an error. In this case, no dial & button +-- box button will be generated. + +dialAndButtonBoxCallback :: SettableStateVar (Maybe DialAndButtonBoxCallback) +dialAndButtonBoxCallback = makeSettableStateVar setDialAndButtonBoxCallback + +setDialAndButtonBoxCallback :: Maybe DialAndButtonBoxCallback -> IO () +setDialAndButtonBoxCallback Nothing = do + setButtonBoxCallback Nothing + setDialsCallback Nothing +setDialAndButtonBoxCallback (Just cb) = do + setButtonBoxCallback (Just (\b s -> cb (DialAndButtonBoxButton b s))) + setDialsCallback (Just (\d x -> cb (DialAndButtonBoxDial d x))) + +-------------------------------------------------------------------------------- + +type ButtonBoxCallback = ButtonIndex -> KeyState -> IO () + +setButtonBoxCallback :: Maybe ButtonBoxCallback -> IO () +setButtonBoxCallback = + setCallback ButtonBoxCB glutButtonBoxFunc (makeButtonBoxFunc . unmarshal) + where unmarshal cb b s = cb (fromIntegral b) (unmarshalKeyState s) + +-------------------------------------------------------------------------------- + +type DialsCallback = DialIndex -> Int -> IO () + +setDialsCallback :: Maybe DialsCallback -> IO () +setDialsCallback = + setCallback DialsCB glutDialsFunc (makeDialsFunc . unmarshal) + where unmarshal cb d x = cb (fromIntegral d) (fromIntegral x) + +-------------------------------------------------------------------------------- + +-- | Absolute tablet position, with coordinates normalized to be in the range of +-- 0 to 2000 inclusive + +data TabletPosition = TabletPosition Int Int + deriving ( Eq, Ord, Show ) + +-- | The table state has changed. + +data TabletInput + = TabletMotion + | TabletButton ButtonIndex KeyState + deriving ( Eq, Ord, Show ) + +-- | A tablet callback + +type TabletCallback = TabletInput -> TabletPosition -> IO () + +-- | Controls the tablet callback for the /current window./ The tablet callback +-- for a window is called when the window has tablet input focus (normally, when +-- the mouse is in the window) and the user generates tablet motion or button +-- presses. The number of available tablet buttons can be determined with +-- 'Graphics.UI.GLUT.State.numTabletButtons'. +-- +-- Registering a tablet callback when a tablet device is not available is +-- ineffectual and not an error. In this case, no tablet callbacks will be +-- generated. + +tabletCallback :: SettableStateVar (Maybe TabletCallback) +tabletCallback = makeSettableStateVar setTabletCallback + +setTabletCallback :: Maybe TabletCallback -> IO () +setTabletCallback Nothing = do + setTabletMotionCallback Nothing + setTabletButtonCallback Nothing +setTabletCallback (Just cb) = do + setTabletMotionCallback (Just (\p -> cb TabletMotion p)) + setTabletButtonCallback (Just (\b s p -> cb (TabletButton b s) p)) + +-------------------------------------------------------------------------------- + +type TabletMotionCallback = TabletPosition -> IO () + +setTabletMotionCallback :: Maybe TabletMotionCallback -> IO () +setTabletMotionCallback = + setCallback TabletMotionCB glutTabletMotionFunc + (makeTabletMotionFunc . unmarshal) + where unmarshal cb x y = + cb (TabletPosition (fromIntegral x) (fromIntegral y)) + +-------------------------------------------------------------------------------- + +type TabletButtonCallback = ButtonIndex -> KeyState -> TabletPosition -> IO () + +setTabletButtonCallback :: Maybe TabletButtonCallback -> IO () +setTabletButtonCallback = + setCallback TabletButtonCB glutTabletButtonFunc + (makeTabletButtonFunc . unmarshal) + where unmarshal cb b s x y = + cb (fromIntegral b) (unmarshalKeyState s) + (TabletPosition (fromIntegral x) (fromIntegral y)) + +-------------------------------------------------------------------------------- + +-- | The state of the joystick buttons + +data JoystickButtons = JoystickButtons { + joystickButtonA, joystickButtonB, + joystickButtonC, joystickButtonD :: KeyState } + deriving ( Eq, Ord, Show ) + +-- Could use fromBitfield + Enum/Bounded instances + unmarshalJoystickButton +-- instead... +unmarshalJoystickButtons :: CUInt -> JoystickButtons +unmarshalJoystickButtons m = JoystickButtons { + joystickButtonA = if (m .&. glut_JOYSTICK_BUTTON_A) /= 0 then Down else Up, + joystickButtonB = if (m .&. glut_JOYSTICK_BUTTON_B) /= 0 then Down else Up, + joystickButtonC = if (m .&. glut_JOYSTICK_BUTTON_C) /= 0 then Down else Up, + joystickButtonD = if (m .&. glut_JOYSTICK_BUTTON_D) /= 0 then Down else Up } + +-------------------------------------------------------------------------------- + +-- | Absolute joystick position, with coordinates normalized to be in the range +-- of -1000 to 1000 inclusive. The signs of the three axes mean the following: +-- +-- * negative = left, positive = right +-- +-- * negative = towards player, positive = away +-- +-- * if available (e.g. rudder): negative = down, positive = up + +data JoystickPosition = JoystickPosition Int Int Int + deriving ( Eq, Ord, Show ) + +-------------------------------------------------------------------------------- + +-- | A joystick callback + +type JoystickCallback = JoystickButtons -> JoystickPosition -> IO () + +-- | Controls the joystick callback for the /current window./ The joystick +-- callback is called either due to polling of the joystick at the uniform timer +-- interval specified (if > 0) or in response to an explicit call of +-- 'Graphics.UI.GLUT.DeviceControl.forceJoystickCallback'. +-- +-- /X Implementation Notes:/ Currently GLUT has no joystick support for X11. + +-- joystickCallback :: SettableStateVar (Maybe JoystickCallback, PollRate) +joystickCallback :: SettableStateVar (Maybe (JoystickCallback, PollRate)) +joystickCallback = + makeSettableStateVar $ \maybeCBAndRate -> + setCallback JoystickCB + (\f -> glutJoystickFunc f (fromIntegral (snd (fromJust maybeCBAndRate)))) + (makeJoystickFunc . unmarshal) + (fmap fst maybeCBAndRate) + where unmarshal cb b x y z = cb (unmarshalJoystickButtons b) + (JoystickPosition (fromIntegral x) + (fromIntegral y) + (fromIntegral z)) diff --git a/Graphics/UI/GLUT/Colormap.hs b/Graphics/UI/GLUT/Colormap.hs --- a/Graphics/UI/GLUT/Colormap.hs +++ b/Graphics/UI/GLUT/Colormap.hs @@ -1,110 +1,110 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Colormap --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- OpenGL supports both RGBA and color index rendering. The RGBA mode is --- generally preferable to color index because more OpenGL rendering --- capabilities are available and color index mode requires the loading of --- colormap entries. --- --- The GLUT color index state variables are used to read and write entries in a --- window\'s color index colormap. Every GLUT color index window has its own --- logical color index colormap. The size of a window\'s colormap can be --- determined by reading 'numColorMapEntries'. --- --- GLUT color index windows within a program can attempt to share colormap --- resources by copying a single color index colormap to multiple windows using --- 'copyColormap'. If possible GLUT will attempt to share the actual colormap. --- While copying colormaps using 'copyColormap' can potentially allow sharing of --- physical colormap resources, logically each window has its own colormap. So --- changing a copied colormap of a window will force the duplication of the --- colormap. For this reason, color index programs should generally load a --- single color index colormap, copy it to all color index windows within the --- program, and then not modify any colormap cells. --- --- Use of multiple colormaps is likely to result in colormap installation --- problems where some windows are displayed with an incorrect colormap due to --- limitations on colormap resources. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Colormap ( - colorMapEntry, - copyColormap, - numColorMapEntries, - transparentIndex -) where - -import Foreign.C.Types -import Graphics.Rendering.OpenGL ( GLfloat, GLint, Color3(..), Index1(..) - , StateVar, makeStateVar, GettableStateVar - , makeGettableStateVar ) -import Graphics.UI.GLUT.QueryUtils -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.Types - --------------------------------------------------------------------------------- - --- | Controls the color index colormap entry of the /current window/\'s logical --- colormap for the /layer in use/. The /layer in use/ of the /current window/ --- should be a color index window. The color index should be zero or greater and --- less than the total number of colormap entries for the window (see --- 'numColorMapEntries') and different from an overlay\'s transparent index (see --- 'transparentIndex'). --- --- If the /layer in use/\'s colormap was copied by reference, setting a colormap --- entry will force the duplication of the colormap. - -colorMapEntry :: Index1 GLint -> StateVar (Color3 GLfloat) -colorMapEntry (Index1 cell) = - makeStateVar (getColorMapEntry (fromIntegral cell)) - (setColorMapEntry (fromIntegral cell)) - -setColorMapEntry :: CInt -> Color3 GLfloat -> IO () -setColorMapEntry cell (Color3 r g b) = glutSetColor cell r g b - -getColorMapEntry :: CInt -> IO (Color3 GLfloat) -getColorMapEntry cell = do - r <- glutGetColor cell glut_RED - g <- glutGetColor cell glut_GREEN - b <- glutGetColor cell glut_BLUE - return $ Color3 r g b - --------------------------------------------------------------------------------- - --- | Copy (lazily if possible to promote sharing) the logical colormap from a --- specified window to the /current window/\'s /layer in use/. The copy will be --- from the normal plane to the normal plane; or from the overlay to the overlay --- (never across different layers). Once a colormap has been copied, avoid --- setting cells in the colormap via 'colorMapEntry' since that will force an --- actual copy of the colormap if it was previously copied by reference. --- 'copyColormap' should only be called when both the /current window/ and the --- specified window are color index windows. - -copyColormap :: Window -> IO () -copyColormap (Window win) = glutCopyColormap win - --------------------------------------------------------------------------------- - --- | Contains the number of entries in the colormap of the /current window/\'s --- current layer (0 in RGBA mode). - -numColorMapEntries :: GettableStateVar GLint -numColorMapEntries = - makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_COLORMAP_SIZE - --------------------------------------------------------------------------------- - --- | Contains the transparent color index of the overlay of the /current window/ --- or -1 if no overlay is in use. - -transparentIndex :: GettableStateVar (Index1 GLint) -transparentIndex = - makeGettableStateVar $ - layerGet (Index1 . fromIntegral) glut_TRANSPARENT_INDEX +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Colormap +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- OpenGL supports both RGBA and color index rendering. The RGBA mode is +-- generally preferable to color index because more OpenGL rendering +-- capabilities are available and color index mode requires the loading of +-- colormap entries. +-- +-- The GLUT color index state variables are used to read and write entries in a +-- window\'s color index colormap. Every GLUT color index window has its own +-- logical color index colormap. The size of a window\'s colormap can be +-- determined by reading 'numColorMapEntries'. +-- +-- GLUT color index windows within a program can attempt to share colormap +-- resources by copying a single color index colormap to multiple windows using +-- 'copyColormap'. If possible GLUT will attempt to share the actual colormap. +-- While copying colormaps using 'copyColormap' can potentially allow sharing of +-- physical colormap resources, logically each window has its own colormap. So +-- changing a copied colormap of a window will force the duplication of the +-- colormap. For this reason, color index programs should generally load a +-- single color index colormap, copy it to all color index windows within the +-- program, and then not modify any colormap cells. +-- +-- Use of multiple colormaps is likely to result in colormap installation +-- problems where some windows are displayed with an incorrect colormap due to +-- limitations on colormap resources. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Colormap ( + colorMapEntry, + copyColormap, + numColorMapEntries, + transparentIndex +) where + +import Foreign.C.Types +import Graphics.Rendering.OpenGL ( GLfloat, GLint, Color3(..), Index1(..) + , StateVar, makeStateVar, GettableStateVar + , makeGettableStateVar ) +import Graphics.UI.GLUT.QueryUtils +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.Types + +-------------------------------------------------------------------------------- + +-- | Controls the color index colormap entry of the /current window/\'s logical +-- colormap for the /layer in use/. The /layer in use/ of the /current window/ +-- should be a color index window. The color index should be zero or greater and +-- less than the total number of colormap entries for the window (see +-- 'numColorMapEntries') and different from an overlay\'s transparent index (see +-- 'transparentIndex'). +-- +-- If the /layer in use/\'s colormap was copied by reference, setting a colormap +-- entry will force the duplication of the colormap. + +colorMapEntry :: Index1 GLint -> StateVar (Color3 GLfloat) +colorMapEntry (Index1 cell) = + makeStateVar (getColorMapEntry (fromIntegral cell)) + (setColorMapEntry (fromIntegral cell)) + +setColorMapEntry :: CInt -> Color3 GLfloat -> IO () +setColorMapEntry cell (Color3 r g b) = glutSetColor cell r g b + +getColorMapEntry :: CInt -> IO (Color3 GLfloat) +getColorMapEntry cell = do + r <- glutGetColor cell glut_RED + g <- glutGetColor cell glut_GREEN + b <- glutGetColor cell glut_BLUE + return $ Color3 r g b + +-------------------------------------------------------------------------------- + +-- | Copy (lazily if possible to promote sharing) the logical colormap from a +-- specified window to the /current window/\'s /layer in use/. The copy will be +-- from the normal plane to the normal plane; or from the overlay to the overlay +-- (never across different layers). Once a colormap has been copied, avoid +-- setting cells in the colormap via 'colorMapEntry' since that will force an +-- actual copy of the colormap if it was previously copied by reference. +-- 'copyColormap' should only be called when both the /current window/ and the +-- specified window are color index windows. + +copyColormap :: Window -> IO () +copyColormap (Window win) = glutCopyColormap win + +-------------------------------------------------------------------------------- + +-- | Contains the number of entries in the colormap of the /current window/\'s +-- current layer (0 in RGBA mode). + +numColorMapEntries :: GettableStateVar GLint +numColorMapEntries = + makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_COLORMAP_SIZE + +-------------------------------------------------------------------------------- + +-- | Contains the transparent color index of the overlay of the /current window/ +-- or -1 if no overlay is in use. + +transparentIndex :: GettableStateVar (Index1 GLint) +transparentIndex = + makeGettableStateVar $ + layerGet (Index1 . fromIntegral) glut_TRANSPARENT_INDEX diff --git a/Graphics/UI/GLUT/Debugging.hs b/Graphics/UI/GLUT/Debugging.hs --- a/Graphics/UI/GLUT/Debugging.hs +++ b/Graphics/UI/GLUT/Debugging.hs @@ -1,37 +1,37 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Debugging --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- This module contains a simple utility routine to report any pending GL --- errors. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Debugging ( - reportErrors -) where - -import Graphics.Rendering.OpenGL ( Error(..), errors, get ) -import System.Environment -import System.IO - --------------------------------------------------------------------------------- - --- | Report any pending GL errors to stderr (which is typically the console). --- If there are no pending errors, this routine does nothing. Note that the --- error flags are reset after this action, i.e. there are no pending errors --- left afterwards. - -reportErrors :: IO () -reportErrors = get errors >>= mapM_ reportError - -reportError :: Error -> IO () -reportError (Error _ msg) = do - pn <- getProgName - hPutStrLn stderr ("GLUT: Warning in " ++ pn ++ ": GL error: " ++ msg) +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Debugging +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- This module contains a simple utility routine to report any pending GL +-- errors. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Debugging ( + reportErrors +) where + +import Graphics.Rendering.OpenGL ( Error(..), errors, get ) +import System.Environment +import System.IO + +-------------------------------------------------------------------------------- + +-- | Report any pending GL errors to stderr (which is typically the console). +-- If there are no pending errors, this routine does nothing. Note that the +-- error flags are reset after this action, i.e. there are no pending errors +-- left afterwards. + +reportErrors :: IO () +reportErrors = get errors >>= mapM_ reportError + +reportError :: Error -> IO () +reportError (Error _ msg) = do + pn <- getProgName + hPutStrLn stderr ("GLUT: Warning in " ++ pn ++ ": GL error: " ++ msg) diff --git a/Graphics/UI/GLUT/DeviceControl.hs b/Graphics/UI/GLUT/DeviceControl.hs --- a/Graphics/UI/GLUT/DeviceControl.hs +++ b/Graphics/UI/GLUT/DeviceControl.hs @@ -1,122 +1,122 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.DeviceControl --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- GLUT offers some routines for controlling the key repeat and polling the --- joystick. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.DeviceControl ( - GlobalKeyRepeat(..), globalKeyRepeat, - PerWindowKeyRepeat(..), perWindowKeyRepeat, - forceJoystickCallback -) where - -import Foreign.C.Types -import Graphics.Rendering.OpenGL ( StateVar, makeStateVar ) -import Graphics.UI.GLUT.QueryUtils -import Graphics.UI.GLUT.Raw - --------------------------------------------------------------------------------- - --- | The state of the global key repeat - -data GlobalKeyRepeat - = GlobalKeyRepeatOff - | GlobalKeyRepeatOn - | GlobalKeyRepeatDefault - deriving ( Eq, Ord, Show ) - -marshalGlobalKeyRepeat :: GlobalKeyRepeat -> CInt -marshalGlobalKeyRepeat x = case x of - GlobalKeyRepeatOff -> glut_KEY_REPEAT_OFF - GlobalKeyRepeatOn -> glut_KEY_REPEAT_ON - GlobalKeyRepeatDefault -> glut_KEY_REPEAT_DEFAULT - -unmarshalGlobalKeyRepeat :: CInt -> GlobalKeyRepeat -unmarshalGlobalKeyRepeat x - | x == glut_KEY_REPEAT_OFF = GlobalKeyRepeatOff - | x == glut_KEY_REPEAT_ON = GlobalKeyRepeatOn - | x == glut_KEY_REPEAT_DEFAULT = GlobalKeyRepeatDefault - | otherwise = error ("unmarshalGlobalKeyRepeat: illegal value " ++ show x) - --------------------------------------------------------------------------------- - --- | Controls the key repeat mode for the window system on a global basis if --- possible. If supported by the window system, the key repeat can either be --- disabled, enabled, or set to the window system\'s default key repeat state. --- --- /X Implementation Notes:/ X11 sends @KeyPress@ events repeatedly when the --- window system\'s global auto repeat is enabled. 'perWindowKeyRepeat' can --- prevent these auto repeated keystrokes from being reported as keyboard or --- special callbacks, but there is still some minimal overhead by the X server --- to continually stream @KeyPress@ events to the GLUT application. The --- 'globalKeyRepeat' state variable can be used to actually disable the global --- sending of auto repeated @KeyPress@ events. Note that 'globalKeyRepeat' --- affects the global window system auto repeat state so other applications --- will not auto repeat if you disable auto repeat globally through --- 'globalKeyRepeat'. GLUT applications using the X11 GLUT implementation --- should disable key repeat with 'globalKeyRepeat' to disable key repeats most --- efficiently, but are responsible for explicitly restoring the default key --- repeat state on exit. --- --- /Win32 Implementation Notes:/ The Win32 implementation of 'globalKeyRepeat' --- does nothing. The 'perWindowKeyRepeat' can be used in the Win32 GLUT --- implementation to ignore repeated keys on a per-window basis without changing --- the global window system key repeat. - -globalKeyRepeat :: StateVar GlobalKeyRepeat -globalKeyRepeat = - makeStateVar (deviceGet unmarshalGlobalKeyRepeat glut_DEVICE_KEY_REPEAT) - (glutSetKeyRepeat . marshalGlobalKeyRepeat) - --------------------------------------------------------------------------------- - --- | The state of the per-window key repeat - -data PerWindowKeyRepeat - = PerWindowKeyRepeatOff - | PerWindowKeyRepeatOn - deriving ( Eq, Ord, Show ) - -marshalPerWindowKeyRepeat :: PerWindowKeyRepeat -> CInt -marshalPerWindowKeyRepeat x = case x of - PerWindowKeyRepeatOn -> 0 - PerWindowKeyRepeatOff -> 1 - -unmarshalPerWindowKeyRepeat :: CInt -> PerWindowKeyRepeat -unmarshalPerWindowKeyRepeat x - | x == 0 = PerWindowKeyRepeatOn - | otherwise = PerWindowKeyRepeatOff - --------------------------------------------------------------------------------- - --- | Controls if auto repeat keystrokes are reported to the /current window./ --- Ignoring auto repeated keystrokes is generally done in conjunction with using --- the 'Graphics.UI.GLUT.Callbacks.Window.keyboardMouseCallback'. If you do --- not ignore auto repeated keystrokes, your GLUT application will experience --- repeated release\/press callbacks. Games using the keyboard will typically --- want to ignore key repeat. - -perWindowKeyRepeat :: StateVar PerWindowKeyRepeat -perWindowKeyRepeat = - makeStateVar - (deviceGet unmarshalPerWindowKeyRepeat glut_DEVICE_IGNORE_KEY_REPEAT) - (glutIgnoreKeyRepeat . marshalPerWindowKeyRepeat) - --------------------------------------------------------------------------------- - --- | Execute the joystick callback set by --- 'Graphics.UI.GLUT.Callbacks.Window.joystickCallback' once (if one exists). --- This is done in a synchronous fashion within the current context, i.e. when --- 'forceJoystickCallback' returns, the callback will have already happened. - -forceJoystickCallback :: IO () -forceJoystickCallback = glutForceJoystickFunc +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.DeviceControl +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- GLUT offers some routines for controlling the key repeat and polling the +-- joystick. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.DeviceControl ( + GlobalKeyRepeat(..), globalKeyRepeat, + PerWindowKeyRepeat(..), perWindowKeyRepeat, + forceJoystickCallback +) where + +import Foreign.C.Types +import Graphics.Rendering.OpenGL ( StateVar, makeStateVar ) +import Graphics.UI.GLUT.QueryUtils +import Graphics.UI.GLUT.Raw + +-------------------------------------------------------------------------------- + +-- | The state of the global key repeat + +data GlobalKeyRepeat + = GlobalKeyRepeatOff + | GlobalKeyRepeatOn + | GlobalKeyRepeatDefault + deriving ( Eq, Ord, Show ) + +marshalGlobalKeyRepeat :: GlobalKeyRepeat -> CInt +marshalGlobalKeyRepeat x = case x of + GlobalKeyRepeatOff -> glut_KEY_REPEAT_OFF + GlobalKeyRepeatOn -> glut_KEY_REPEAT_ON + GlobalKeyRepeatDefault -> glut_KEY_REPEAT_DEFAULT + +unmarshalGlobalKeyRepeat :: CInt -> GlobalKeyRepeat +unmarshalGlobalKeyRepeat x + | x == glut_KEY_REPEAT_OFF = GlobalKeyRepeatOff + | x == glut_KEY_REPEAT_ON = GlobalKeyRepeatOn + | x == glut_KEY_REPEAT_DEFAULT = GlobalKeyRepeatDefault + | otherwise = error ("unmarshalGlobalKeyRepeat: illegal value " ++ show x) + +-------------------------------------------------------------------------------- + +-- | Controls the key repeat mode for the window system on a global basis if +-- possible. If supported by the window system, the key repeat can either be +-- disabled, enabled, or set to the window system\'s default key repeat state. +-- +-- /X Implementation Notes:/ X11 sends @KeyPress@ events repeatedly when the +-- window system\'s global auto repeat is enabled. 'perWindowKeyRepeat' can +-- prevent these auto repeated keystrokes from being reported as keyboard or +-- special callbacks, but there is still some minimal overhead by the X server +-- to continually stream @KeyPress@ events to the GLUT application. The +-- 'globalKeyRepeat' state variable can be used to actually disable the global +-- sending of auto repeated @KeyPress@ events. Note that 'globalKeyRepeat' +-- affects the global window system auto repeat state so other applications +-- will not auto repeat if you disable auto repeat globally through +-- 'globalKeyRepeat'. GLUT applications using the X11 GLUT implementation +-- should disable key repeat with 'globalKeyRepeat' to disable key repeats most +-- efficiently, but are responsible for explicitly restoring the default key +-- repeat state on exit. +-- +-- /Win32 Implementation Notes:/ The Win32 implementation of 'globalKeyRepeat' +-- does nothing. The 'perWindowKeyRepeat' can be used in the Win32 GLUT +-- implementation to ignore repeated keys on a per-window basis without changing +-- the global window system key repeat. + +globalKeyRepeat :: StateVar GlobalKeyRepeat +globalKeyRepeat = + makeStateVar (deviceGet unmarshalGlobalKeyRepeat glut_DEVICE_KEY_REPEAT) + (glutSetKeyRepeat . marshalGlobalKeyRepeat) + +-------------------------------------------------------------------------------- + +-- | The state of the per-window key repeat + +data PerWindowKeyRepeat + = PerWindowKeyRepeatOff + | PerWindowKeyRepeatOn + deriving ( Eq, Ord, Show ) + +marshalPerWindowKeyRepeat :: PerWindowKeyRepeat -> CInt +marshalPerWindowKeyRepeat x = case x of + PerWindowKeyRepeatOn -> 0 + PerWindowKeyRepeatOff -> 1 + +unmarshalPerWindowKeyRepeat :: CInt -> PerWindowKeyRepeat +unmarshalPerWindowKeyRepeat x + | x == 0 = PerWindowKeyRepeatOn + | otherwise = PerWindowKeyRepeatOff + +-------------------------------------------------------------------------------- + +-- | Controls if auto repeat keystrokes are reported to the /current window./ +-- Ignoring auto repeated keystrokes is generally done in conjunction with using +-- the 'Graphics.UI.GLUT.Callbacks.Window.keyboardMouseCallback'. If you do +-- not ignore auto repeated keystrokes, your GLUT application will experience +-- repeated release\/press callbacks. Games using the keyboard will typically +-- want to ignore key repeat. + +perWindowKeyRepeat :: StateVar PerWindowKeyRepeat +perWindowKeyRepeat = + makeStateVar + (deviceGet unmarshalPerWindowKeyRepeat glut_DEVICE_IGNORE_KEY_REPEAT) + (glutIgnoreKeyRepeat . marshalPerWindowKeyRepeat) + +-------------------------------------------------------------------------------- + +-- | Execute the joystick callback set by +-- 'Graphics.UI.GLUT.Callbacks.Window.joystickCallback' once (if one exists). +-- This is done in a synchronous fashion within the current context, i.e. when +-- 'forceJoystickCallback' returns, the callback will have already happened. + +forceJoystickCallback :: IO () +forceJoystickCallback = glutForceJoystickFunc diff --git a/Graphics/UI/GLUT/Fonts.hs b/Graphics/UI/GLUT/Fonts.hs --- a/Graphics/UI/GLUT/Fonts.hs +++ b/Graphics/UI/GLUT/Fonts.hs @@ -1,183 +1,183 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Fonts --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- GLUT supports two types of font rendering: stroke fonts, meaning each --- character is rendered as a set of line segments; and bitmap fonts, where each --- character is a bitmap generated with --- 'Graphics.Rendering.OpenGL.GL.Bitmaps.bitmap'. Stroke fonts have the --- advantage that because they are geometry, they can be arbitrarily scale and --- rendered. Bitmap fonts are less flexible since they are rendered as bitmaps --- but are usually faster than stroke fonts. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Fonts ( - Font(..), BitmapFont(..), StrokeFont(..), -) where - -import Data.Char -import Foreign.C.String -import Foreign.C.Types -import Foreign.Ptr -import Graphics.Rendering.OpenGL ( GLint, GLfloat ) -import Graphics.UI.GLUT.Raw - --------------------------------------------------------------------------------- - -class Font a where - -- | Render the string in the named font, without using any display lists. - -- Rendering a nonexistent character has no effect. - -- - -- If the font is a bitmap font, 'renderString' automatically sets the OpenGL - -- unpack pixel storage modes it needs appropriately and saves and restores - -- the previous modes before returning. The generated call to - -- 'Graphics.Rendering.OpenGL.GL.bitmap' will adjust the current raster - -- position based on the width of the string. - -- If the font is a stroke font, - -- 'Graphics.Rendering.OpenGL.GL.CoordTrans.translate' is used to translate - -- the current model view matrix to advance the width of the string. - - renderString :: a -> String -> IO () - - -- | For a bitmap font, return the width in pixels of a string. For a stroke - -- font, return the width in units. While the width of characters in a font - -- may vary (though fixed width fonts do not vary), the maximum height - -- characteristics of a particular font are fixed. - - stringWidth :: a -> String -> IO GLint - - -- | (/freeglut only/) For a bitmap font, return the maximum height of the - -- characters in the given font measured in pixels. For a stroke font, - -- return the width in units. - - fontHeight :: a -> IO GLfloat - -instance Font BitmapFont where - renderString = bitmapString - stringWidth = bitmapLength - fontHeight = bitmapHeight - - -instance Font StrokeFont where - renderString = strokeString - stringWidth = strokeLength - fontHeight = strokeHeight - --------------------------------------------------------------------------------- - --- | The bitmap fonts available in GLUT. The exact bitmap to be used is --- defined by the standard X glyph bitmaps for the X font with the given name. - -data BitmapFont - = Fixed8By13 -- ^ A fixed width font with every character fitting in an 8 - -- by 13 pixel rectangle. - -- (@-misc-fixed-medium-r-normal--13-120-75-75-C-80-iso8859-1@) - | Fixed9By15 -- ^ A fixed width font with every character fitting in an 9 - -- by 15 pixel rectangle. - -- (@-misc-fixed-medium-r-normal--15-140-75-75-C-90-iso8859-1@) - | TimesRoman10 -- ^ A 10-point proportional spaced Times Roman font. - -- (@-adobe-times-medium-r-normal--10-100-75-75-p-54-iso8859-1@) - | TimesRoman24 -- ^ A 24-point proportional spaced Times Roman font. - -- (@-adobe-times-medium-r-normal--24-240-75-75-p-124-iso8859-1@) - | Helvetica10 -- ^ A 10-point proportional spaced Helvetica font. - -- (@-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1@) - | Helvetica12 -- ^ A 12-point proportional spaced Helvetica font. - -- (@-adobe-helvetica-medium-r-normal--12-120-75-75-p-67-iso8859-1@) - | Helvetica18 -- ^ A 18-point proportional spaced Helvetica font. - -- (@-adobe-helvetica-medium-r-normal--18-180-75-75-p-98-iso8859-1@) - deriving ( Eq, Ord, Show ) - --- Alas, fonts in GLUT are not denoted by some integral value, but by opaque --- pointers on the C side. Even worse: For WinDoze, they are simply small ints, --- casted to void*, for other platforms addresses of global variables are used. --- And all is done via ugly #ifdef-ed #defines... Aaaaargl! So the only portable --- way is using integers on the Haskell side and doing the marshaling via some --- small C wrappers around those macros. *sigh* -type GLUTbitmapFont = Ptr () - -marhshalBitmapFont :: BitmapFont -> IO GLUTbitmapFont -marhshalBitmapFont x = case x of - Fixed8By13 -> hs_GLUT_marshalBitmapFont 0 - Fixed9By15 -> hs_GLUT_marshalBitmapFont 1 - TimesRoman10 -> hs_GLUT_marshalBitmapFont 2 - TimesRoman24 -> hs_GLUT_marshalBitmapFont 3 - Helvetica10 -> hs_GLUT_marshalBitmapFont 4 - Helvetica12 -> hs_GLUT_marshalBitmapFont 5 - Helvetica18 -> hs_GLUT_marshalBitmapFont 6 - --------------------------------------------------------------------------------- - --- | The stroke fonts available in GLUT. -data StrokeFont - = Roman -- ^ A proportionally spaced Roman Simplex font for ASCII - -- characters 32 through 127. The maximum top character in the - -- font is 119.05 units; the bottom descends 33.33 units. - | MonoRoman -- ^ A mono-spaced spaced Roman Simplex font (same characters as - -- 'Roman') for ASCII characters 32 through 127. The maximum - -- top character in the font is 119.05 units; the bottom - -- descends 33.33 units. Each character is 104.76 units wide. - deriving ( Eq, Ord, Show ) - --- Same remarks as for GLUTbitmapFont -type GLUTstrokeFont = Ptr () - -marhshalStrokeFont :: StrokeFont -> IO GLUTstrokeFont -marhshalStrokeFont x = case x of - Roman -> hs_GLUT_marshalStrokeFont 0 - MonoRoman -> hs_GLUT_marshalStrokeFont 1 - --------------------------------------------------------------------------------- - -bitmapString :: BitmapFont -> String -> IO () -bitmapString f s = do - i <- marhshalBitmapFont f - mapM_ (\c -> withChar c (glutBitmapCharacter i)) s - -withChar :: Char -> (CInt -> IO a) -> IO a -withChar c f = f . fromIntegral . ord $ c - --------------------------------------------------------------------------------- - -strokeString :: StrokeFont -> String -> IO () -strokeString f s = do - i <- marhshalStrokeFont f - mapM_ (\c -> withChar c (glutStrokeCharacter i)) s - --------------------------------------------------------------------------------- - -bitmapLength :: BitmapFont -- ^ Bitmap font to use. - -> String -- ^ String to return width of (not confined to 8 - -- bits). - -> IO GLint -- ^ Width in pixels. -bitmapLength f s = do - i <- marhshalBitmapFont f - fmap fromIntegral $ withCString s (glutBitmapLength i . castPtr) - --------------------------------------------------------------------------------- - -strokeLength :: StrokeFont -- ^ Stroke font to use. - -> String -- ^ String to return width of (not confined to 8 - -- bits). - -> IO GLint -- ^ Width in units. -strokeLength f s = do - i <- marhshalStrokeFont f - fmap fromIntegral $ withCString s (glutStrokeLength i . castPtr) - --------------------------------------------------------------------------------- - -bitmapHeight :: BitmapFont -- ^ Bitmap font to use. - -> IO GLfloat -- ^ Height in pixels. -bitmapHeight f = fmap fromIntegral $ glutBitmapHeight =<< marhshalBitmapFont f - --------------------------------------------------------------------------------- - -strokeHeight :: StrokeFont -- ^ Stroke font to use. - -> IO GLfloat -- ^ Height in units. -strokeHeight f = glutStrokeHeight =<< marhshalStrokeFont f +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Fonts +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- GLUT supports two types of font rendering: stroke fonts, meaning each +-- character is rendered as a set of line segments; and bitmap fonts, where each +-- character is a bitmap generated with +-- 'Graphics.Rendering.OpenGL.GL.Bitmaps.bitmap'. Stroke fonts have the +-- advantage that because they are geometry, they can be arbitrarily scale and +-- rendered. Bitmap fonts are less flexible since they are rendered as bitmaps +-- but are usually faster than stroke fonts. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Fonts ( + Font(..), BitmapFont(..), StrokeFont(..), +) where + +import Data.Char +import Foreign.C.String +import Foreign.C.Types +import Foreign.Ptr +import Graphics.Rendering.OpenGL ( GLint, GLfloat ) +import Graphics.UI.GLUT.Raw + +-------------------------------------------------------------------------------- + +class Font a where + -- | Render the string in the named font, without using any display lists. + -- Rendering a nonexistent character has no effect. + -- + -- If the font is a bitmap font, 'renderString' automatically sets the OpenGL + -- unpack pixel storage modes it needs appropriately and saves and restores + -- the previous modes before returning. The generated call to + -- 'Graphics.Rendering.OpenGL.GL.bitmap' will adjust the current raster + -- position based on the width of the string. + -- If the font is a stroke font, + -- 'Graphics.Rendering.OpenGL.GL.CoordTrans.translate' is used to translate + -- the current model view matrix to advance the width of the string. + + renderString :: a -> String -> IO () + + -- | For a bitmap font, return the width in pixels of a string. For a stroke + -- font, return the width in units. While the width of characters in a font + -- may vary (though fixed width fonts do not vary), the maximum height + -- characteristics of a particular font are fixed. + + stringWidth :: a -> String -> IO GLint + + -- | (/freeglut only/) For a bitmap font, return the maximum height of the + -- characters in the given font measured in pixels. For a stroke font, + -- return the width in units. + + fontHeight :: a -> IO GLfloat + +instance Font BitmapFont where + renderString = bitmapString + stringWidth = bitmapLength + fontHeight = bitmapHeight + + +instance Font StrokeFont where + renderString = strokeString + stringWidth = strokeLength + fontHeight = strokeHeight + +-------------------------------------------------------------------------------- + +-- | The bitmap fonts available in GLUT. The exact bitmap to be used is +-- defined by the standard X glyph bitmaps for the X font with the given name. + +data BitmapFont + = Fixed8By13 -- ^ A fixed width font with every character fitting in an 8 + -- by 13 pixel rectangle. + -- (@-misc-fixed-medium-r-normal--13-120-75-75-C-80-iso8859-1@) + | Fixed9By15 -- ^ A fixed width font with every character fitting in an 9 + -- by 15 pixel rectangle. + -- (@-misc-fixed-medium-r-normal--15-140-75-75-C-90-iso8859-1@) + | TimesRoman10 -- ^ A 10-point proportional spaced Times Roman font. + -- (@-adobe-times-medium-r-normal--10-100-75-75-p-54-iso8859-1@) + | TimesRoman24 -- ^ A 24-point proportional spaced Times Roman font. + -- (@-adobe-times-medium-r-normal--24-240-75-75-p-124-iso8859-1@) + | Helvetica10 -- ^ A 10-point proportional spaced Helvetica font. + -- (@-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1@) + | Helvetica12 -- ^ A 12-point proportional spaced Helvetica font. + -- (@-adobe-helvetica-medium-r-normal--12-120-75-75-p-67-iso8859-1@) + | Helvetica18 -- ^ A 18-point proportional spaced Helvetica font. + -- (@-adobe-helvetica-medium-r-normal--18-180-75-75-p-98-iso8859-1@) + deriving ( Eq, Ord, Show ) + +-- Alas, fonts in GLUT are not denoted by some integral value, but by opaque +-- pointers on the C side. Even worse: For WinDoze, they are simply small ints, +-- casted to void*, for other platforms addresses of global variables are used. +-- And all is done via ugly #ifdef-ed #defines... Aaaaargl! So the only portable +-- way is using integers on the Haskell side and doing the marshaling via some +-- small C wrappers around those macros. *sigh* +type GLUTbitmapFont = Ptr () + +marhshalBitmapFont :: BitmapFont -> IO GLUTbitmapFont +marhshalBitmapFont x = case x of + Fixed8By13 -> hs_GLUT_marshalBitmapFont 0 + Fixed9By15 -> hs_GLUT_marshalBitmapFont 1 + TimesRoman10 -> hs_GLUT_marshalBitmapFont 2 + TimesRoman24 -> hs_GLUT_marshalBitmapFont 3 + Helvetica10 -> hs_GLUT_marshalBitmapFont 4 + Helvetica12 -> hs_GLUT_marshalBitmapFont 5 + Helvetica18 -> hs_GLUT_marshalBitmapFont 6 + +-------------------------------------------------------------------------------- + +-- | The stroke fonts available in GLUT. +data StrokeFont + = Roman -- ^ A proportionally spaced Roman Simplex font for ASCII + -- characters 32 through 127. The maximum top character in the + -- font is 119.05 units; the bottom descends 33.33 units. + | MonoRoman -- ^ A mono-spaced spaced Roman Simplex font (same characters as + -- 'Roman') for ASCII characters 32 through 127. The maximum + -- top character in the font is 119.05 units; the bottom + -- descends 33.33 units. Each character is 104.76 units wide. + deriving ( Eq, Ord, Show ) + +-- Same remarks as for GLUTbitmapFont +type GLUTstrokeFont = Ptr () + +marhshalStrokeFont :: StrokeFont -> IO GLUTstrokeFont +marhshalStrokeFont x = case x of + Roman -> hs_GLUT_marshalStrokeFont 0 + MonoRoman -> hs_GLUT_marshalStrokeFont 1 + +-------------------------------------------------------------------------------- + +bitmapString :: BitmapFont -> String -> IO () +bitmapString f s = do + i <- marhshalBitmapFont f + mapM_ (\c -> withChar c (glutBitmapCharacter i)) s + +withChar :: Char -> (CInt -> IO a) -> IO a +withChar c f = f . fromIntegral . ord $ c + +-------------------------------------------------------------------------------- + +strokeString :: StrokeFont -> String -> IO () +strokeString f s = do + i <- marhshalStrokeFont f + mapM_ (\c -> withChar c (glutStrokeCharacter i)) s + +-------------------------------------------------------------------------------- + +bitmapLength :: BitmapFont -- ^ Bitmap font to use. + -> String -- ^ String to return width of (not confined to 8 + -- bits). + -> IO GLint -- ^ Width in pixels. +bitmapLength f s = do + i <- marhshalBitmapFont f + fmap fromIntegral $ withCString s (glutBitmapLength i . castPtr) + +-------------------------------------------------------------------------------- + +strokeLength :: StrokeFont -- ^ Stroke font to use. + -> String -- ^ String to return width of (not confined to 8 + -- bits). + -> IO GLint -- ^ Width in units. +strokeLength f s = do + i <- marhshalStrokeFont f + fmap fromIntegral $ withCString s (glutStrokeLength i . castPtr) + +-------------------------------------------------------------------------------- + +bitmapHeight :: BitmapFont -- ^ Bitmap font to use. + -> IO GLfloat -- ^ Height in pixels. +bitmapHeight f = fmap fromIntegral $ glutBitmapHeight =<< marhshalBitmapFont f + +-------------------------------------------------------------------------------- + +strokeHeight :: StrokeFont -- ^ Stroke font to use. + -> IO GLfloat -- ^ Height in units. +strokeHeight f = glutStrokeHeight =<< marhshalStrokeFont f diff --git a/Graphics/UI/GLUT/GameMode.hs b/Graphics/UI/GLUT/GameMode.hs --- a/Graphics/UI/GLUT/GameMode.hs +++ b/Graphics/UI/GLUT/GameMode.hs @@ -1,191 +1,191 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.GameMode --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- In addition to the functionality offered by --- 'Graphics.UI.GLUT.Window.fullScreen', GLUT offers an sub-API to change the --- screen resolution, color depth, and refresh rate of the display for a single --- full screen window. This mode of operation is called /game mode/, and is --- restricted in various ways: No pop-up menus are allowed for this full screen --- window, no other (sub-)windows can be created, and all other applications are --- hidden. --- --- /X Implementation Notes:/ Note that game mode is not fully supported in the --- original GLUT for X, it is essentially the same as using --- 'Graphics.UI.GLUT.Window.fullScreen'. The GLUT clone freeglut --- (see ) does not have this restriction. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.GameMode ( - GameModeCapability(..), GameModeCapabilityDescription(..), - gameModeCapabilities, enterGameMode, leaveGameMode, - BitsPerPlane, RefreshRate, GameModeInfo(..), gameModeInfo, - gameModeActive -) where - -import Data.List -import Foreign.C.String -import Graphics.Rendering.OpenGL ( GLenum, Size(..) - , GettableStateVar - , SettableStateVar - , makeGettableStateVar - , makeSettableStateVar ) -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.Types - --------------------------------------------------------------------------------- - --- | Capabilities for 'gameModeCapabilities' - -data GameModeCapability - = GameModeWidth -- ^ Width of the screen resolution in pixels - | GameModeHeight -- ^ Height of the screen resolution in pixels - | GameModeBitsPerPlane -- ^ Color depth of the screen in bits - | GameModeRefreshRate -- ^ Refresh rate in Hertz - | GameModeNum -- ^ Match the Nth frame buffer configuration - -- compatible with the given capabilities - -- (numbering starts at 1) - deriving ( Eq, Ord, Show ) - -gameModeCapabilityToString :: GameModeCapability -> String -gameModeCapabilityToString x = case x of - GameModeWidth -> "width" - GameModeHeight -> "height" - GameModeBitsPerPlane -> "bpp" - GameModeRefreshRate -> "hertz" - GameModeNum -> "num" - --- | A single capability description for 'gameModeCapabilities'. - -data GameModeCapabilityDescription = Where' GameModeCapability Relation Int - deriving ( Eq, Ord, Show ) - -gameModeCapabilityDescriptionToString :: GameModeCapabilityDescription -> String -gameModeCapabilityDescriptionToString (Where' c r i) = - gameModeCapabilityToString c ++ relationToString r ++ show i - --------------------------------------------------------------------------------- - --- | Controls the /game mode/ to be used when 'enterGameMode' is called. It is --- described by a list of zero or more capability descriptions, which are --- translated into a set of criteria used to select the appropriate screen --- configuration. The criteria are matched in strict left to right order of --- precdence. That is, the first specified criterion (leftmost) takes precedence --- over the later criteria for non-exact criteria --- ('Graphics.UI.GLUT.Initialization.IsGreaterThan', --- 'Graphics.UI.GLUT.Initialization.IsLessThan', etc.). Exact criteria --- ('Graphics.UI.GLUT.Initialization.IsEqualTo', --- 'Graphics.UI.GLUT.Initialization.IsNotEqualTo') must match exactly so --- precedence is not relevant. --- --- To determine which configuration will actually be tried by 'enterGameMode' --- (if any), use 'gameModeInfo'. --- --- Note that even for game mode the current values of --- 'Graphics.UI.GLUT.Initialization.initialDisplayMode'or --- 'Graphics.UI.GLUT.Initialization.initialDisplayCapabilities' will --- determine which buffers are available, if double buffering is used or not, --- etc. - -gameModeCapabilities :: SettableStateVar [GameModeCapabilityDescription] -gameModeCapabilities = makeSettableStateVar $ \ds -> - withCString (descriptionsToString ds) glutGameModeString - --- freeglut currently handles only simple game mode descriptions like "WxH:B@R", --- so we try hard to use this format instead of the more general format allowed --- by the "real" GLUT. -descriptionsToString :: [GameModeCapabilityDescription] -> String -descriptionsToString ds = - let ws = [ x | Where' GameModeWidth IsEqualTo x <- ds ] - hs = [ x | Where' GameModeHeight IsEqualTo x <- ds ] - bs = [ x | Where' GameModeBitsPerPlane IsEqualTo x <- ds ] - rs = [ x | Where' GameModeRefreshRate IsEqualTo x <- ds ] - allSimple = (length ws + length hs + length bs + length rs) == (length ds) - dimensionsOK = (null ws) == (null hs) - in if allSimple && dimensionsOK - then simpleCapStr ws hs bs rs - else generalCapStr ds - -simpleCapStr :: [Int] -> [Int] -> [Int] -> [Int] -> String -simpleCapStr ws hs bs rs = - showCap "" ws ++ showCap "x" hs ++ showCap ":" bs ++ showCap "@" rs - where showCap _ [] = "" - showCap prefix (x:_) = prefix ++ show x - -generalCapStr :: [GameModeCapabilityDescription] -> String -generalCapStr = - concat . intersperse " " . map gameModeCapabilityDescriptionToString - --------------------------------------------------------------------------------- - --- | Enter /game mode/, trying to change resolution, refresh rate, etc., as --- specified by the current value of 'gameModeCapabilities'. An identifier for --- the game mode window and a flag, indicating if the display mode actually --- changed, are returned. The game mode window is made the /current window/. --- --- Re-entering /game mode/ is allowed, the previous game mode window gets --- destroyed by this, and a new one is created. - -enterGameMode :: IO (Window, Bool) -enterGameMode = do - w <- glutEnterGameMode - c <- getBool glut_GAME_MODE_DISPLAY_CHANGED - return (Window w, c) - --------------------------------------------------------------------------------- - --- | Leave /game mode/, restoring the old display mode and destroying the game --- mode window. - -leaveGameMode :: IO () -leaveGameMode = glutLeaveGameMode - --------------------------------------------------------------------------------- - --- | The color depth of the screen, measured in bits (e.g. 8, 16, 24, 32, ...) - -type BitsPerPlane = Int - --- | The refresh rate of the screen, measured in Hertz (e.g. 60, 75, 100, ...) - -type RefreshRate = Int - -data GameModeInfo = GameModeInfo Size BitsPerPlane RefreshRate - deriving ( Eq, Ord, Show ) - --------------------------------------------------------------------------------- - --- | Return 'Just' the mode which would be tried by the next call to --- 'enterGameMode'. Returns 'Nothing' if the mode requested by the current value --- of 'gameModeCapabilities' is not possible, in which case 'enterGameMode' --- would simply create a full screen window using the current mode. - -gameModeInfo :: GettableStateVar (Maybe GameModeInfo) -gameModeInfo = makeGettableStateVar $ do - possible <- getBool glut_GAME_MODE_POSSIBLE - if possible - then do - w <- glutGameModeGet glut_GAME_MODE_WIDTH - h <- glutGameModeGet glut_GAME_MODE_HEIGHT - let size = Size (fromIntegral w) (fromIntegral h) - b <- glutGameModeGet glut_GAME_MODE_PIXEL_DEPTH - r <- glutGameModeGet glut_GAME_MODE_REFRESH_RATE - return $ Just $ GameModeInfo size (fromIntegral b) (fromIntegral r) - else return Nothing - -getBool :: GLenum -> IO Bool -getBool = fmap (/= 0) . glutGameModeGet - --------------------------------------------------------------------------------- - --- | Contains 'True' when the /game mode/ is active, 'False' otherwise. - -gameModeActive :: GettableStateVar Bool -gameModeActive = makeGettableStateVar $ getBool glut_GAME_MODE_ACTIVE +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.GameMode +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- In addition to the functionality offered by +-- 'Graphics.UI.GLUT.Window.fullScreen', GLUT offers an sub-API to change the +-- screen resolution, color depth, and refresh rate of the display for a single +-- full screen window. This mode of operation is called /game mode/, and is +-- restricted in various ways: No pop-up menus are allowed for this full screen +-- window, no other (sub-)windows can be created, and all other applications are +-- hidden. +-- +-- /X Implementation Notes:/ Note that game mode is not fully supported in the +-- original GLUT for X, it is essentially the same as using +-- 'Graphics.UI.GLUT.Window.fullScreen'. The GLUT clone freeglut +-- (see ) does not have this restriction. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.GameMode ( + GameModeCapability(..), GameModeCapabilityDescription(..), + gameModeCapabilities, enterGameMode, leaveGameMode, + BitsPerPlane, RefreshRate, GameModeInfo(..), gameModeInfo, + gameModeActive +) where + +import Data.List +import Foreign.C.String +import Graphics.Rendering.OpenGL ( GLenum, Size(..) + , GettableStateVar + , SettableStateVar + , makeGettableStateVar + , makeSettableStateVar ) +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.Types + +-------------------------------------------------------------------------------- + +-- | Capabilities for 'gameModeCapabilities' + +data GameModeCapability + = GameModeWidth -- ^ Width of the screen resolution in pixels + | GameModeHeight -- ^ Height of the screen resolution in pixels + | GameModeBitsPerPlane -- ^ Color depth of the screen in bits + | GameModeRefreshRate -- ^ Refresh rate in Hertz + | GameModeNum -- ^ Match the Nth frame buffer configuration + -- compatible with the given capabilities + -- (numbering starts at 1) + deriving ( Eq, Ord, Show ) + +gameModeCapabilityToString :: GameModeCapability -> String +gameModeCapabilityToString x = case x of + GameModeWidth -> "width" + GameModeHeight -> "height" + GameModeBitsPerPlane -> "bpp" + GameModeRefreshRate -> "hertz" + GameModeNum -> "num" + +-- | A single capability description for 'gameModeCapabilities'. + +data GameModeCapabilityDescription = Where' GameModeCapability Relation Int + deriving ( Eq, Ord, Show ) + +gameModeCapabilityDescriptionToString :: GameModeCapabilityDescription -> String +gameModeCapabilityDescriptionToString (Where' c r i) = + gameModeCapabilityToString c ++ relationToString r ++ show i + +-------------------------------------------------------------------------------- + +-- | Controls the /game mode/ to be used when 'enterGameMode' is called. It is +-- described by a list of zero or more capability descriptions, which are +-- translated into a set of criteria used to select the appropriate screen +-- configuration. The criteria are matched in strict left to right order of +-- precdence. That is, the first specified criterion (leftmost) takes precedence +-- over the later criteria for non-exact criteria +-- ('Graphics.UI.GLUT.Initialization.IsGreaterThan', +-- 'Graphics.UI.GLUT.Initialization.IsLessThan', etc.). Exact criteria +-- ('Graphics.UI.GLUT.Initialization.IsEqualTo', +-- 'Graphics.UI.GLUT.Initialization.IsNotEqualTo') must match exactly so +-- precedence is not relevant. +-- +-- To determine which configuration will actually be tried by 'enterGameMode' +-- (if any), use 'gameModeInfo'. +-- +-- Note that even for game mode the current values of +-- 'Graphics.UI.GLUT.Initialization.initialDisplayMode'or +-- 'Graphics.UI.GLUT.Initialization.initialDisplayCapabilities' will +-- determine which buffers are available, if double buffering is used or not, +-- etc. + +gameModeCapabilities :: SettableStateVar [GameModeCapabilityDescription] +gameModeCapabilities = makeSettableStateVar $ \ds -> + withCString (descriptionsToString ds) glutGameModeString + +-- freeglut currently handles only simple game mode descriptions like "WxH:B@R", +-- so we try hard to use this format instead of the more general format allowed +-- by the "real" GLUT. +descriptionsToString :: [GameModeCapabilityDescription] -> String +descriptionsToString ds = + let ws = [ x | Where' GameModeWidth IsEqualTo x <- ds ] + hs = [ x | Where' GameModeHeight IsEqualTo x <- ds ] + bs = [ x | Where' GameModeBitsPerPlane IsEqualTo x <- ds ] + rs = [ x | Where' GameModeRefreshRate IsEqualTo x <- ds ] + allSimple = (length ws + length hs + length bs + length rs) == (length ds) + dimensionsOK = (null ws) == (null hs) + in if allSimple && dimensionsOK + then simpleCapStr ws hs bs rs + else generalCapStr ds + +simpleCapStr :: [Int] -> [Int] -> [Int] -> [Int] -> String +simpleCapStr ws hs bs rs = + showCap "" ws ++ showCap "x" hs ++ showCap ":" bs ++ showCap "@" rs + where showCap _ [] = "" + showCap prefix (x:_) = prefix ++ show x + +generalCapStr :: [GameModeCapabilityDescription] -> String +generalCapStr = + concat . intersperse " " . map gameModeCapabilityDescriptionToString + +-------------------------------------------------------------------------------- + +-- | Enter /game mode/, trying to change resolution, refresh rate, etc., as +-- specified by the current value of 'gameModeCapabilities'. An identifier for +-- the game mode window and a flag, indicating if the display mode actually +-- changed, are returned. The game mode window is made the /current window/. +-- +-- Re-entering /game mode/ is allowed, the previous game mode window gets +-- destroyed by this, and a new one is created. + +enterGameMode :: IO (Window, Bool) +enterGameMode = do + w <- glutEnterGameMode + c <- getBool glut_GAME_MODE_DISPLAY_CHANGED + return (Window w, c) + +-------------------------------------------------------------------------------- + +-- | Leave /game mode/, restoring the old display mode and destroying the game +-- mode window. + +leaveGameMode :: IO () +leaveGameMode = glutLeaveGameMode + +-------------------------------------------------------------------------------- + +-- | The color depth of the screen, measured in bits (e.g. 8, 16, 24, 32, ...) + +type BitsPerPlane = Int + +-- | The refresh rate of the screen, measured in Hertz (e.g. 60, 75, 100, ...) + +type RefreshRate = Int + +data GameModeInfo = GameModeInfo Size BitsPerPlane RefreshRate + deriving ( Eq, Ord, Show ) + +-------------------------------------------------------------------------------- + +-- | Return 'Just' the mode which would be tried by the next call to +-- 'enterGameMode'. Returns 'Nothing' if the mode requested by the current value +-- of 'gameModeCapabilities' is not possible, in which case 'enterGameMode' +-- would simply create a full screen window using the current mode. + +gameModeInfo :: GettableStateVar (Maybe GameModeInfo) +gameModeInfo = makeGettableStateVar $ do + possible <- getBool glut_GAME_MODE_POSSIBLE + if possible + then do + w <- glutGameModeGet glut_GAME_MODE_WIDTH + h <- glutGameModeGet glut_GAME_MODE_HEIGHT + let size = Size (fromIntegral w) (fromIntegral h) + b <- glutGameModeGet glut_GAME_MODE_PIXEL_DEPTH + r <- glutGameModeGet glut_GAME_MODE_REFRESH_RATE + return $ Just $ GameModeInfo size (fromIntegral b) (fromIntegral r) + else return Nothing + +getBool :: GLenum -> IO Bool +getBool = fmap (/= 0) . glutGameModeGet + +-------------------------------------------------------------------------------- + +-- | Contains 'True' when the /game mode/ is active, 'False' otherwise. + +gameModeActive :: GettableStateVar Bool +gameModeActive = makeGettableStateVar $ getBool glut_GAME_MODE_ACTIVE diff --git a/Graphics/UI/GLUT/Initialization.hs b/Graphics/UI/GLUT/Initialization.hs --- a/Graphics/UI/GLUT/Initialization.hs +++ b/Graphics/UI/GLUT/Initialization.hs @@ -1,773 +1,773 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Initialization --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- Actions and state variables in this module are used to initialize GLUT state. --- The primary initialization routine is 'initialize', which should only be --- called exactly once in a GLUT program. No other GLUT or OpenGL actions should --- be called before 'initialize', apart from getting or setting the state --- variables in this module. --- --- The reason is that these state variables can be used to set default window --- initialization state that might be modified by the command processing done in --- 'initialize'. For example, 'initialWindowSize' can be set to @('Size' --- 400 400)@ before 'initialize' is called to indicate 400 by 400 is the --- program\'s default window size. Setting the initial window size or position --- before 'initialize' allows the GLUT program user to specify the initial size --- or position using command line arguments. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Initialization ( - -- * Primary initialization - initialize, getArgsAndInitialize, exit, - - -- * Initial window geometry - initialWindowPosition, initialWindowSize, - - -- * Setting the initial display mode (I) - DisplayMode(..), initialDisplayMode, displayModePossible, - - -- * Setting the initial display mode (II) - DisplayCapability(..), Relation(..), DisplayCapabilityDescription(..), - initialDisplayCapabilities, - - -- * Controlling the creation of rendering contexts - RenderingContext(..), renderingContext, - - -- * Direct\/indirect rendering - DirectRendering(..), directRendering, - - -- * OpenGL 3.x context support - initialContextVersion, ContextFlag(..), initialContextFlags, - ContextProfile(..), initialContextProfile -) where - -import Control.Monad -import Data.Bits -import Data.List -import Foreign.C.String -import Foreign.C.Types -import Foreign.Marshal.Array -import Foreign.Marshal.Utils -import Foreign.Ptr -import Foreign.Storable -import Graphics.Rendering.OpenGL ( Position(..), Size(..) - , StateVar, GettableStateVar, get - , SettableStateVar, makeStateVar, ($=) - , makeGettableStateVar - , makeSettableStateVar ) -import Graphics.UI.GLUT.QueryUtils -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.Types -import System.Environment - --------------------------------------------------------------------------------- - --- | Given the program name and command line arguments, initialize the GLUT --- library and negotiate a session with the window system. During this --- process, 'initialize' may cause the termination of the GLUT program with an --- error message to the user if GLUT cannot be properly initialized. --- Examples of this situation include the failure to connect to the window --- system, the lack of window system support for OpenGL, and invalid command --- line options. --- --- 'initialize' also processes command line options, but the specific options --- parsed are window system dependent. Any command line arguments which are --- not GLUT-specific are returned. --- --- /X Implementation Notes:/ The X Window System specific options parsed by --- 'initialize' are as follows: --- --- * @-display /DISPLAY/@: Specify the X server to connect to. If not specified, --- the value of the @DISPLAY@ environment variable is used. --- --- * @-geometry /WxH+X+Y/@: Determines where windows should be created on the --- screen. The parameter following @-geometry@ should be formatted as a --- standard X geometry specification. The effect of using this option is to --- change the GLUT initial size and initial position the same as if --- 'initialWindowSize' or 'initialWindowPosition' were modified directly. --- --- * @-iconic@: Requests all top-level windows be created in an iconic state. --- --- * @-indirect@: Force the use of indirect OpenGL rendering contexts. --- --- * @-direct@: Force the use of direct OpenGL rendering contexts (not all GLX --- implementations support direct rendering contexts). A fatal error is --- generated if direct rendering is not supported by the OpenGL --- implementation. If neither @-indirect@ or @-direct@ are used to force a --- particular behavior, GLUT will attempt to use direct rendering if --- possible and otherwise fallback to indirect rendering. --- --- * @-gldebug@: After processing callbacks and\/or events, call --- 'Graphics.UI.GLUT.Debugging.reportErrors' to check if there are any pending --- OpenGL errors. Using this option is helpful in detecting OpenGL run-time --- errors. --- --- * @-sync@: Enable synchronous X protocol transactions. This option makes --- it easier to track down potential X protocol errors. - -initialize :: String -- ^ The program name. - -> [String] -- ^ The command line arguments - -> IO [String] -- ^ Non-GLUT command line arguments -initialize prog args = - with (1 + genericLength args) $ \argcBuf -> - withMany withCString (prog : args) $ \argvPtrs -> - withArray0 nullPtr argvPtrs $ \argvBuf -> do - glutInit argcBuf argvBuf - newArgc <- peek argcBuf - newArgvPtrs <- peekArray (fromIntegral newArgc) argvBuf - newArgv <- mapM peekCString newArgvPtrs - return $ tail newArgv - --- | Convenience action: Initialize GLUT, returning the program name and any --- non-GLUT command line arguments. - -getArgsAndInitialize :: IO (String, [String]) -getArgsAndInitialize = do - prog <- getProgName - args <- getArgs - nonGLUTArgs <- initialize prog args - return (prog, nonGLUTArgs) - ------------------------------------------------------------------------------ - --- | (/freeglut only/) De-initialize GLUT. After this, one has to use --- 'initialize' or 'getArgsAndInitialize' to initialize GLUT again. - -exit :: IO () -exit = glutExit - --------------------------------------------------------------------------------- - --- | Controls the /initial window position/. Windows created by --- 'Graphics.UI.GLUT.Window.createWindow' will be requested to be created with --- the current /initial window position/. The initial value of the /initial --- window position/ GLUT state is @'Position' (-1) (-1)@. If either the X or Y --- component of the /initial window position/ is negative, the actual window --- position is left to the window system to determine. --- --- The intent of the /initial window position/ is to provide a suggestion to --- the window system for a window\'s initial position. The window system is --- not obligated to use this information. Therefore, GLUT programs should not --- assume the window was created at the specified position. - -initialWindowPosition :: StateVar Position -initialWindowPosition = - makeStateVar getInitialWindowPosition setInitialWindowPosition - -getInitialWindowPosition :: IO Position -getInitialWindowPosition = do - x <- simpleGet fromIntegral glut_INIT_WINDOW_X - y <- simpleGet fromIntegral glut_INIT_WINDOW_Y - return $ Position x y - -setInitialWindowPosition :: Position -> IO () -setInitialWindowPosition (Position x y) = - glutInitWindowPosition (fromIntegral x) (fromIntegral y) - --------------------------------------------------------------------------------- - --- | Controls the /initial window size/. Windows created by --- 'Graphics.UI.GLUT.Window.createWindow' will be requested to be created with --- the current /initial window size/. The initial value of the /initial window --- size/ GLUT state is @'Size' 300 300@. If either the width or the height --- component of the /initial window size/ is non-positive, the actual window --- size is left to the window system to determine. --- --- The intent of the /initial window size/ is to provide a suggestion to the --- window system for a window\'s initial size. The window system is not --- obligated to use this information. Therefore, GLUT programs should not --- assume the window was created at the specified size. A GLUT program should --- use the window\'s reshape callback to determine the true size of the --- window. - -initialWindowSize :: StateVar Size -initialWindowSize = makeStateVar getInitialWindowSize setInitialWindowSize - -getInitialWindowSize :: IO Size -getInitialWindowSize = do - w <- simpleGet fromIntegral glut_INIT_WINDOW_WIDTH - h <- simpleGet fromIntegral glut_INIT_WINDOW_HEIGHT - return $ Size w h - -setInitialWindowSize :: Size -> IO () -setInitialWindowSize (Size w h) = - glutInitWindowSize (fromIntegral w) (fromIntegral h) - --------------------------------------------------------------------------------- - --- | A single aspect of a window which is to be created, used in conjunction --- with 'initialDisplayMode'. - -data DisplayMode - = RGBAMode - -- ^ Select an RGBA mode window. This is the default if neither 'RGBAMode' - -- nor 'IndexMode' are specified. - | RGBMode - -- ^ An alias for 'RGBAMode'. - | IndexMode - -- ^ Select a color index mode window. This overrides 'RGBAMode' if it is - -- also specified. - | LuminanceMode - -- ^ Select a window with a \"luminance\" color model. This model provides - -- the functionality of OpenGL\'s RGBA color model, but the green and blue - -- components are not maintained in the frame buffer. Instead each pixel\'s - -- red component is converted to an index between zero and - -- 'Graphics.UI.GLUT.Colormap.numColorMapEntries' and looked up in a - -- per-window color map to determine the color of pixels within the window. - -- The initial colormap of 'LuminanceMode' windows is initialized to be a - -- linear gray ramp, but can be modified with GLUT\'s colormap actions. - -- /Implementation Notes:/ 'LuminanceMode' is not supported on most OpenGL - -- platforms. - | WithAlphaComponent - -- ^ Select a window with an alpha component to the color buffer(s). - | WithAccumBuffer - -- ^ Select a window with an accumulation buffer. - | WithDepthBuffer - -- ^ Select a window with a depth buffer. - | WithStencilBuffer - -- ^ Select a window with a stencil buffer. - | WithAuxBuffers Int - -- ^ (/freeglut only/) Select a window with /n/ (1 .. 4) auxiliary buffers. - -- Any /n/ outside the range 1 .. 4 is a fatal error. - | SingleBuffered - -- ^ Select a single buffered window. This is the default if neither - -- 'DoubleBuffered' nor 'SingleBuffered' are specified. - | DoubleBuffered - -- ^ Select a double buffered window. This overrides 'SingleBuffered' if it - -- is also specified. - | Multisampling - -- ^ Select a window with multisampling support. If multisampling is not - -- available, a non-multisampling window will automatically be chosen. - -- Note: both the OpenGL client-side and server-side implementations must - -- support the @GLX_SAMPLE_SGIS@ extension for multisampling to be - -- available. Deprecated, use 'WithSamplesPerPixel'. - | WithSamplesPerPixel Int - -- ^ Select a window with multisampling, using the given samples per pixel. - | Stereoscopic - -- ^ Select a stereo window. - | Captionless - -- ^ Select a window without a caption (/freeglut only/). - | Borderless - -- ^ Select a window without any borders (/freeglut only/). - | SRGBMode - -- ^ Select an sRGB mode window (/freeglut only/). - deriving ( Eq, Ord, Show ) - -marshalDisplayMode :: DisplayMode -> CUInt -marshalDisplayMode m = case m of - RGBAMode -> glut_RGBA - RGBMode -> glut_RGB - IndexMode -> glut_INDEX - LuminanceMode -> glut_LUMINANCE - WithAlphaComponent -> glut_ALPHA - WithAccumBuffer -> glut_ACCUM - WithDepthBuffer -> glut_DEPTH - WithStencilBuffer -> glut_STENCIL - WithAuxBuffers 1 -> glut_AUX1 - WithAuxBuffers 2 -> glut_AUX2 - WithAuxBuffers 3 -> glut_AUX3 - WithAuxBuffers 4 -> glut_AUX4 - WithAuxBuffers n -> - error ("marshalDisplayMode: illegal number of auxiliary buffers: " ++ show n) - SingleBuffered -> glut_SINGLE - DoubleBuffered -> glut_DOUBLE - Multisampling -> glut_MULTISAMPLE - WithSamplesPerPixel _ -> error ("marshalDisplayMode: this should not happen") - Stereoscopic -> glut_STEREO - Captionless -> glut_CAPTIONLESS - Borderless -> glut_BORDERLESS - SRGBMode -> glut_SRGB - --------------------------------------------------------------------------------- - --- | Controls the /initial display mode/ used when creating top-level windows, --- subwindows, and overlays to determine the OpenGL display mode for the --- to-be-created window or overlay. --- --- Note that 'RGBAMode' selects the RGBA color model, but it does not request any --- bits of alpha (sometimes called an /alpha buffer/ or /destination alpha/) --- be allocated. To request alpha, specify 'WithAlphaComponent'. The same --- applies to 'LuminanceMode'. - -initialDisplayMode :: StateVar [DisplayMode] -initialDisplayMode = makeStateVar getInitialDisplayMode setInitialDisplayMode - -getInitialDisplayMode :: IO [DisplayMode] -getInitialDisplayMode = do - mode <- simpleGet fromIntegral glut_INIT_DISPLAY_MODE - let displayModes = i2dms (mode .&. complement glut_MULTISAMPLE) - if mode .&. glut_MULTISAMPLE == 0 - then return displayModes - else do - n <- get samplesPerPixel - return $ WithSamplesPerPixel n : displayModes - -i2dms :: CUInt -> [DisplayMode] -i2dms bitfield | IndexMode `elem` modes || LuminanceMode `elem` modes = modes - | otherwise = RGBAMode : modes - where modes = i2dmsWithoutRGBA bitfield - -i2dmsWithoutRGBA :: CUInt -> [DisplayMode] -i2dmsWithoutRGBA bitfield = - [ c | c <- [ IndexMode, LuminanceMode, WithAlphaComponent, - WithAccumBuffer, WithDepthBuffer, WithStencilBuffer, - WithAuxBuffers 1, WithAuxBuffers 2, WithAuxBuffers 3, - WithAuxBuffers 4, SingleBuffered, DoubleBuffered, Multisampling, - Stereoscopic, Captionless, Borderless, SRGBMode ] - , (bitfield .&. marshalDisplayMode c) /= 0 ] - -setInitialDisplayMode :: [DisplayMode] -> IO () -setInitialDisplayMode modes = do - let (spps, transformedModes) = mapAccumR handleMultisampling [] modes - mapM_ (samplesPerPixel $=) spps - glutInitDisplayMode (toBitfield marshalDisplayMode transformedModes) - -handleMultisampling :: [Int] -> DisplayMode -> ([Int], DisplayMode) -handleMultisampling spps (WithSamplesPerPixel spp) = (spp : spps, Multisampling) -handleMultisampling spps mode = (spps, mode) - -toBitfield :: (Num b, Bits b) => (a -> b) -> [a] -> b -toBitfield marshal = foldl (.|.) 0 . map marshal - --- | Contains 'True' if the /current display mode/ is supported, 'False' --- otherwise. - -displayModePossible :: GettableStateVar Bool -displayModePossible = - makeGettableStateVar $ simpleGet (/= 0) glut_DISPLAY_MODE_POSSIBLE - --------------------------------------------------------------------------------- - -samplesPerPixel :: StateVar Int -samplesPerPixel = makeStateVar getSamplesPerPixel setSamplesPerPixel - -getSamplesPerPixel :: IO Int -getSamplesPerPixel = do - m <- multisamplingSupported - if m - then simpleGet fromIntegral (fromIntegral glut_MULTISAMPLE) - else return defaultSamplesPerPixels - -defaultSamplesPerPixels :: Int -defaultSamplesPerPixels = 4 - -setSamplesPerPixel :: Int -> IO () -setSamplesPerPixel spp = do - m <- multisamplingSupported - when m $ - glutSetOption (fromIntegral glut_MULTISAMPLE) (fromIntegral spp) - -multisamplingSupported :: IO Bool -multisamplingSupported = isKnown "glutGetModeValues" - where isKnown = fmap (/= nullFunPtr) . getAPIEntryInternal - --------------------------------------------------------------------------------- - --- | Capabilities for 'initialDisplayCapabilities', most of them are extensions --- of the constructors of 'DisplayMode'. - -data DisplayCapability - = DisplayRGBA -- ^ Number of bits of red, green, blue, and alpha in the RGBA - -- color buffer. Default is \"'IsAtLeast' @1@\" for red, - -- green, blue, and alpha capabilities, and \"'IsEqualTo' - -- @1@\" for the RGBA color model capability. - | DisplayRGB -- ^ Number of bits of red, green, and blue in the RGBA color - -- buffer and zero bits of alpha color buffer precision. - -- Default is \"'IsAtLeast' @1@\" for the red, green, and - -- blue capabilities, and \"'IsNotLessThan' @0@\" for alpha - -- capability, and \"'IsEqualTo' @1@\" for the RGBA color - -- model capability. - | DisplayRed -- ^ Red color buffer precision in bits. Default is - -- \"'IsAtLeast' @1@\". - | DisplayGreen -- ^ Green color buffer precision in bits. Default is - -- \"'IsAtLeast' @1@\". - | DisplayBlue -- ^ Blue color buffer precision in bits. Default is - -- \"'IsAtLeast' @1@\". - | DisplayIndex -- ^ Boolean if the color model is color index or not. True is - -- color index. Default is \"'IsAtLeast' @1@\". - | DisplayBuffer -- ^ Number of bits in the color index color buffer. Default - -- is \"'IsAtLeast' @1@\". - | DisplaySingle -- ^ Boolean indicate the color buffer is single buffered. - -- Default is \"'IsEqualTo' @1@\". - | DisplayDouble -- ^ Boolean indicating if the color buffer is double - -- buffered. Default is \"'IsEqualTo' @1@\". - | DisplayAccA -- ^ Red, green, blue, and alpha accumulation buffer precision - -- in bits. Default is \"'IsAtLeast' @1@\" for red, green, - -- blue, and alpha capabilities. - | DisplayAcc -- ^ Red, green, and green accumulation buffer precision in - -- bits and zero bits of alpha accumulation buffer precision. - -- Default is \"'IsAtLeast' @1@\" for red, green, and blue - -- capabilities, and \"'IsNotLessThan' @0@\" for the alpha - -- capability. - | DisplayAlpha -- ^ Alpha color buffer precision in bits. Default is - -- \"'IsAtLeast' @1@\". - | DisplayDepth -- ^ Number of bits of precsion in the depth buffer. Default - -- is \"'IsAtLeast' @12@\". - | DisplayStencil -- ^ Number of bits in the stencil buffer. Default is - -- \"'IsNotLessThan' @1@\". - | DisplaySamples -- ^ Indicates the number of multisamples to use based on - -- GLX\'s @SGIS_multisample@ extension (for antialiasing). - -- Default is \"'IsNotGreaterThan' @4@\". This default means - -- that a GLUT application can request multisampling if - -- available by simply specifying \"'With' 'DisplaySamples'\". - | DisplayStereo -- ^ Boolean indicating the color buffer is supports - -- OpenGL-style stereo. Default is \"'IsEqualTo' @1@\". - | DisplayLuminance -- ^ Number of bits of red in the RGBA and zero bits of green, - -- blue (alpha not specified) of color buffer precision. - -- Default is \"'IsAtLeast' @1@\" for the red capabilitis, - -- and \"'IsEqualTo' @0@\" for the green and blue - -- capabilities, and \"'IsEqualTo' @1@\" for the RGBA color - -- model capability, and, for X11, \"'IsEqualTo' @1@\" for - -- the 'DisplayXStaticGray' capability. SGI InfiniteReality (and - -- other future machines) support a 16-bit luminance (single - -- channel) display mode (an additional 16-bit alpha channel - -- can also be requested). The red channel maps to gray - -- scale and green and blue channels are not available. A - -- 16-bit precision luminance display mode is often - -- appropriate for medical imaging applications. Do not - -- expect many machines to support extended precision - -- luminance display modes. - | DisplayAux -- ^ (/freeglut only/) Number of auxiliary buffers. Default is - -- \"'IsEqualTo' @1@\". - | DisplayNum -- ^ A special capability name indicating where the value - -- represents the Nth frame buffer configuration matching - -- the description string. When not specified, - -- 'initialDisplayCapabilities' also uses the first - -- (best matching) configuration. 'Num' requires a relation - -- and numeric value. - | DisplayConformant -- ^ Boolean indicating if the frame buffer configuration is - -- conformant or not. Conformance information is based on - -- GLX\'s @EXT_visual_rating@ extension if supported. If the - -- extension is not supported, all visuals are assumed - -- conformant. Default is \"'IsEqualTo' @1@\". - | DisplaySlow -- ^ Boolean indicating if the frame buffer configuration is - -- slow or not. Slowness information is based on GLX\'s - -- @EXT_visual_rating@ extension if supported. If the - -- extension is not supported, all visuals are assumed fast. - -- Note that slowness is a relative designation relative to - -- other frame buffer configurations available. The intent - -- of the slow capability is to help programs avoid frame - -- buffer configurations that are slower (but perhaps higher - -- precision) for the current machine. Default is - -- \"'IsAtLeast' @0@\". This default means that slow visuals - -- are used in preference to fast visuals, but fast visuals - -- will still be allowed. - | DisplayWin32PFD -- ^ Only recognized on GLUT implementations for Win32, this - -- capability name matches the Win32 Pixel Format Descriptor - -- by number. 'DisplayWin32PFD' can only be used with 'Where'. - | DisplayXVisual -- ^ Only recongized on GLUT implementations for the X Window - -- System, this capability name matches the X visual ID by - -- number. 'DisplayXVisual' requires a relation and numeric value. - | DisplayXStaticGray -- ^ Only recongized on GLUT implementations for the X Window - -- System, boolean indicating if the frame buffer - -- configuration\'s X visual is of type @StaticGray@. - -- Default is \"'IsEqualTo' @1@\". - | DisplayXGrayScale -- ^ Only recongized on GLUT implementations for the X Window - -- System, boolean indicating if the frame buffer - -- configuration\'s X visual is of type @GrayScale@. Default - -- is \"'IsEqualTo' @1@\". - | DisplayXStaticColor -- ^ Only recongized on GLUT implementations for the X Window - -- System, boolean indicating if the frame buffer - -- configuration\'s X visual is of type @StaticColor@. - -- Default is \"'IsEqualTo' @1@\". - | DisplayXPseudoColor -- ^ Only recongized on GLUT implementations for the X Window - -- System, boolean indicating if the frame buffer - -- configuration\'s X visual is of type @PsuedoColor@. - -- Default is \"'IsEqualTo' @1@\". - | DisplayXTrueColor -- ^ Only recongized on GLUT implementations for the X Window - -- System, boolean indicating if the frame buffer - -- configuration\'s X visual is of type @TrueColor@. Default - -- is \"'IsEqualTo' @1@\". - | DisplayXDirectColor -- ^ Only recongized on GLUT implementations for the X Window - -- System, boolean indicating if the frame buffer - -- configuration\'s X visual is of type @DirectColor@. - -- Default is \"'IsEqualTo' @1@\". - deriving ( Eq, Ord, Show ) - -displayCapabilityToString :: DisplayCapability -> String -displayCapabilityToString x = case x of - DisplayRGBA -> "rgba" - DisplayRGB -> "rgb" - DisplayRed -> "red" - DisplayGreen -> "green" - DisplayBlue -> "blue" - DisplayIndex -> "index" - DisplayBuffer -> "buffer" - DisplaySingle -> "single" - DisplayDouble -> "double" - DisplayAccA -> "acca" - DisplayAcc -> "acc" - DisplayAlpha -> "alpha" - DisplayDepth -> "depth" - DisplayStencil -> "stencil" - DisplaySamples -> "samples" - DisplayStereo -> "stereo" - DisplayLuminance -> "luminance" - DisplayAux -> "aux" - DisplayNum -> "num" - DisplayConformant -> "conformant" - DisplaySlow -> "slow" - DisplayWin32PFD -> "win32pfd" - DisplayXVisual -> "xvisual" - DisplayXStaticGray -> "xstaticgray" - DisplayXGrayScale -> "xgrayscale" - DisplayXStaticColor -> "xstaticcolor" - DisplayXPseudoColor -> "xpseudocolor" - DisplayXTrueColor -> "xtruecolor" - DisplayXDirectColor -> "xdirectcolor" - --- | A single capability description for 'initialDisplayCapabilities'. - -data DisplayCapabilityDescription - = Where DisplayCapability Relation Int - -- ^ A description of a capability with a specific relation to a numeric - -- value. - | With DisplayCapability - -- ^ When the relation and numeric value are not specified, each capability - -- has a different default, see the different constructors of - -- 'DisplayCapability'. - deriving ( Eq, Ord, Show ) - -displayCapabilityDescriptionToString :: DisplayCapabilityDescription -> String -displayCapabilityDescriptionToString (Where c r i) = - displayCapabilityToString c ++ relationToString r ++ show i -displayCapabilityDescriptionToString (With c) = displayCapabilityToString c - --- | Controls the /initial display mode/ used when creating top-level windows, --- subwindows, and overlays to determine the OpenGL display mode for the --- to-be-created window or overlay. It is described by a list of zero or more --- capability descriptions, which are translated into a set of criteria used to --- select the appropriate frame buffer configuration. The criteria are matched --- in strict left to right order of precdence. That is, the first specified --- criterion (leftmost) takes precedence over the later criteria for non-exact --- criteria ('IsGreaterThan', 'IsLessThan', etc.). Exact criteria ('IsEqualTo', --- 'IsNotEqualTo') must match exactly so precedence is not relevant. --- --- Unspecified capability descriptions will result in unspecified criteria being --- generated. These unspecified criteria help 'initialDisplayCapabilities' --- behave sensibly with terse display mode descriptions. --- --- Here is an example using 'initialDisplayCapabilities': --- --- @ --- initialDisplayCapabilities $= [ With DisplayRGB, --- Where DisplayDepth IsAtLeast 16, --- With DisplaySamples, --- Where DisplayStencil IsNotLessThan 2, --- With DisplayDouble ] --- @ --- --- The above call requests a window with an RGBA color model (but requesting --- no bits of alpha), a depth buffer with at least 16 bits of precision but --- preferring more, multisampling if available, at least 2 bits of stencil --- (favoring less stencil to more as long as 2 bits are available), and double --- buffering. - -initialDisplayCapabilities :: SettableStateVar [DisplayCapabilityDescription] -initialDisplayCapabilities = - makeSettableStateVar $ \caps -> - withCString - (concat . intersperse " " . map displayCapabilityDescriptionToString $ - caps) - glutInitDisplayString - ------------------------------------------------------------------------------ - --- | How rendering context for new windows are created. - -data RenderingContext - = -- | Create a new context via @glXCreateContext@ or @wglCreateContext@ - -- (default). - CreateNewContext - | -- | Re-use the current rendering context. - UseCurrentContext - deriving ( Eq, Ord, Show ) - -marshalRenderingContext :: RenderingContext -> CInt -marshalRenderingContext CreateNewContext = glut_CREATE_NEW_CONTEXT -marshalRenderingContext UseCurrentContext = glut_USE_CURRENT_CONTEXT - -unmarshalRenderingContext :: CInt -> RenderingContext -unmarshalRenderingContext r - | r == glut_CREATE_NEW_CONTEXT = CreateNewContext - | r == glut_USE_CURRENT_CONTEXT = UseCurrentContext - | otherwise = error "unmarshalRenderingContext" - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Controls the creation of rendering contexts for new --- windows. - -renderingContext :: StateVar RenderingContext -renderingContext = - makeStateVar - (simpleGet unmarshalRenderingContext glut_RENDERING_CONTEXT) - (glutSetOption glut_RENDERING_CONTEXT . marshalRenderingContext) - ------------------------------------------------------------------------------ - --- | The kind of GLX rendering context used. Direct rendering provides a --- performance advantage in some implementations. However, direct rendering --- contexts cannot be shared outside a single process, and they may be unable --- to render to GLX pixmaps. - -data DirectRendering - = -- | Rendering is always done through the X server. This corresponds to - -- the command line argument @-indirect@, see 'initialize'. - ForceIndirectContext - | -- | Try to use direct rendering, silently using indirect rendering if this - -- is not possible. - AllowDirectContext - | -- | Try to use direct rendering, issue a warning and use indirect - -- rendering if this is not possible. - TryDirectContext - | -- | Try to use direct rendering, issue an error and terminate the program - -- if this is not possible.This corresponds to the command line argument - -- @-direct@, see 'initialize'. - ForceDirectContext - deriving ( Eq, Ord, Show ) - -marshalDirectRendering :: DirectRendering -> CInt -marshalDirectRendering x = case x of - ForceIndirectContext -> glut_FORCE_INDIRECT_CONTEXT - AllowDirectContext -> glut_ALLOW_DIRECT_CONTEXT - TryDirectContext -> glut_TRY_DIRECT_CONTEXT - ForceDirectContext -> glut_FORCE_DIRECT_CONTEXT - -unmarshalDirectRendering :: CInt -> DirectRendering -unmarshalDirectRendering x - | x == glut_FORCE_INDIRECT_CONTEXT = ForceIndirectContext - | x == glut_ALLOW_DIRECT_CONTEXT = AllowDirectContext - | x == glut_TRY_DIRECT_CONTEXT = TryDirectContext - | x == glut_FORCE_DIRECT_CONTEXT = ForceDirectContext - | otherwise = error ("unmarshalDirectRendering: illegal value " ++ show x) - ------------------------------------------------------------------------------ - --- | (/freeglut on X11 only/) Controls which kind of rendering context is --- created when a new one is required. - -directRendering :: StateVar DirectRendering -directRendering = - makeStateVar - (simpleGet unmarshalDirectRendering glut_DIRECT_RENDERING) - (glutSetOption glut_DIRECT_RENDERING . marshalDirectRendering) - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Controls the API major\/minor version of the OpenGL --- context. If a version less than or equal to 2.1 is requested, the context --- returned may implement any version no less than that requested and no --- greater than 2.1. If version 3.0 is requested, the context returned must --- implement exactly version 3.0. Versioning behavior once GL versions beyond --- 3.0 are defined will be defined by an amendment to the OpenGL specification --- to define dependencies on such GL versions. --- --- 'Graphics.Rendering.OpenGL.GL.StringQueries.glVersion' and --- 'Graphics.Rendering.OpenGL.GL.StringQueries.majorMinor' will return the --- actual version supported by a context. --- --- The default context version is (1, 0), which will typically return an --- OpenGL 2.1 context, if one is available. - -initialContextVersion :: StateVar (Int, Int) -initialContextVersion = makeStateVar getContextVersion setContextVersion - -getContextVersion :: IO (Int, Int) -getContextVersion = do - major <- simpleGet fromIntegral glut_INIT_MAJOR_VERSION - minor <- simpleGet fromIntegral glut_INIT_MINOR_VERSION - return (major, minor) - -setContextVersion :: (Int, Int) -> IO () -setContextVersion (major, minor) = - glutInitContextVersion (fromIntegral major) (fromIntegral minor) - ------------------------------------------------------------------------------ - --- | A flag affecting the rendering context to create, used in conjunction --- with 'initialContextFlags'. - -data ContextFlag - = -- | Debug contexts are intended for use during application development, - -- and provide additional runtime checking, validation, and logging - -- functionality while possibly incurring performance penalties. The - -- additional functionality provided by debug contexts may vary according - -- to the implementation. In some cases a debug context may be identical - -- to a non-debug context. - DebugContext - | -- | Forward-compatible contexts are defined only for OpenGL versions 3.0 - -- and later. They must not support functionality marked as /deprecated/ - -- by that version of the API, while a non-forward-compatible context must - -- support all functionality in that version, deprecated or not. - ForwardCompatibleContext - deriving ( Eq, Ord, Show ) - -marshalContextFlag :: ContextFlag -> CInt -marshalContextFlag x = case x of - DebugContext -> glut_DEBUG - ForwardCompatibleContext -> glut_FORWARD_COMPATIBLE - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Controls the set of flags for the rendering context. - -initialContextFlags :: StateVar [ContextFlag] -initialContextFlags = makeStateVar getContextFlags setContextFlags - -getContextFlags :: IO [ContextFlag] -getContextFlags = simpleGet i2cfs glut_INIT_FLAGS - -i2cfs :: CInt -> [ContextFlag] -i2cfs bitfield = - [ c | c <- [ DebugContext, ForwardCompatibleContext ] - , (fromIntegral bitfield .&. marshalContextFlag c) /= 0 ] - -setContextFlags :: [ContextFlag] -> IO () -setContextFlags = glutInitContextFlags . toBitfield marshalContextFlag - - ------------------------------------------------------------------------------ - --- | An OpenGL API profile, affecting the rendering context to create, used --- in conjunction with 'initialContextProfile'. - -data ContextProfile - = -- | The OpenGL /core/ profile, which all OpenGL 3.2 implementations - -- are required to support. - CoreProfile - | -- | The OpenGL /compatibility/ profile, which is optional for OpenGL - -- 3.2 implementations. - CompatibilityProfile - deriving ( Eq, Ord, Show ) - -marshalContextProfile :: ContextProfile -> CInt -marshalContextProfile x = case x of - CoreProfile -> glut_CORE_PROFILE - CompatibilityProfile -> glut_COMPATIBILITY_PROFILE - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Controls the set of profiles for the rendering context. - -initialContextProfile :: StateVar [ContextProfile] -initialContextProfile = makeStateVar getContextProfiles setContextProfiles - -getContextProfiles :: IO [ContextProfile] -getContextProfiles = simpleGet i2cps glut_INIT_PROFILE - -i2cps :: CInt -> [ContextProfile] -i2cps bitfield = - [ c | c <- [ CoreProfile, CompatibilityProfile ] - , (fromIntegral bitfield .&. marshalContextProfile c) /= 0 ] - -setContextProfiles :: [ContextProfile] -> IO () -setContextProfiles = glutInitContextProfile . toBitfield marshalContextProfile +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Initialization +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- Actions and state variables in this module are used to initialize GLUT state. +-- The primary initialization routine is 'initialize', which should only be +-- called exactly once in a GLUT program. No other GLUT or OpenGL actions should +-- be called before 'initialize', apart from getting or setting the state +-- variables in this module. +-- +-- The reason is that these state variables can be used to set default window +-- initialization state that might be modified by the command processing done in +-- 'initialize'. For example, 'initialWindowSize' can be set to @('Size' +-- 400 400)@ before 'initialize' is called to indicate 400 by 400 is the +-- program\'s default window size. Setting the initial window size or position +-- before 'initialize' allows the GLUT program user to specify the initial size +-- or position using command line arguments. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Initialization ( + -- * Primary initialization + initialize, getArgsAndInitialize, exit, + + -- * Initial window geometry + initialWindowPosition, initialWindowSize, + + -- * Setting the initial display mode (I) + DisplayMode(..), initialDisplayMode, displayModePossible, + + -- * Setting the initial display mode (II) + DisplayCapability(..), Relation(..), DisplayCapabilityDescription(..), + initialDisplayCapabilities, + + -- * Controlling the creation of rendering contexts + RenderingContext(..), renderingContext, + + -- * Direct\/indirect rendering + DirectRendering(..), directRendering, + + -- * OpenGL 3.x context support + initialContextVersion, ContextFlag(..), initialContextFlags, + ContextProfile(..), initialContextProfile +) where + +import Control.Monad +import Data.Bits +import Data.List +import Foreign.C.String +import Foreign.C.Types +import Foreign.Marshal.Array +import Foreign.Marshal.Utils +import Foreign.Ptr +import Foreign.Storable +import Graphics.Rendering.OpenGL ( Position(..), Size(..) + , StateVar, GettableStateVar, get + , SettableStateVar, makeStateVar, ($=) + , makeGettableStateVar + , makeSettableStateVar ) +import Graphics.UI.GLUT.QueryUtils +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.Types +import System.Environment + +-------------------------------------------------------------------------------- + +-- | Given the program name and command line arguments, initialize the GLUT +-- library and negotiate a session with the window system. During this +-- process, 'initialize' may cause the termination of the GLUT program with an +-- error message to the user if GLUT cannot be properly initialized. +-- Examples of this situation include the failure to connect to the window +-- system, the lack of window system support for OpenGL, and invalid command +-- line options. +-- +-- 'initialize' also processes command line options, but the specific options +-- parsed are window system dependent. Any command line arguments which are +-- not GLUT-specific are returned. +-- +-- /X Implementation Notes:/ The X Window System specific options parsed by +-- 'initialize' are as follows: +-- +-- * @-display /DISPLAY/@: Specify the X server to connect to. If not specified, +-- the value of the @DISPLAY@ environment variable is used. +-- +-- * @-geometry /WxH+X+Y/@: Determines where windows should be created on the +-- screen. The parameter following @-geometry@ should be formatted as a +-- standard X geometry specification. The effect of using this option is to +-- change the GLUT initial size and initial position the same as if +-- 'initialWindowSize' or 'initialWindowPosition' were modified directly. +-- +-- * @-iconic@: Requests all top-level windows be created in an iconic state. +-- +-- * @-indirect@: Force the use of indirect OpenGL rendering contexts. +-- +-- * @-direct@: Force the use of direct OpenGL rendering contexts (not all GLX +-- implementations support direct rendering contexts). A fatal error is +-- generated if direct rendering is not supported by the OpenGL +-- implementation. If neither @-indirect@ or @-direct@ are used to force a +-- particular behavior, GLUT will attempt to use direct rendering if +-- possible and otherwise fallback to indirect rendering. +-- +-- * @-gldebug@: After processing callbacks and\/or events, call +-- 'Graphics.UI.GLUT.Debugging.reportErrors' to check if there are any pending +-- OpenGL errors. Using this option is helpful in detecting OpenGL run-time +-- errors. +-- +-- * @-sync@: Enable synchronous X protocol transactions. This option makes +-- it easier to track down potential X protocol errors. + +initialize :: String -- ^ The program name. + -> [String] -- ^ The command line arguments + -> IO [String] -- ^ Non-GLUT command line arguments +initialize prog args = + with (1 + genericLength args) $ \argcBuf -> + withMany withCString (prog : args) $ \argvPtrs -> + withArray0 nullPtr argvPtrs $ \argvBuf -> do + glutInit argcBuf argvBuf + newArgc <- peek argcBuf + newArgvPtrs <- peekArray (fromIntegral newArgc) argvBuf + newArgv <- mapM peekCString newArgvPtrs + return $ tail newArgv + +-- | Convenience action: Initialize GLUT, returning the program name and any +-- non-GLUT command line arguments. + +getArgsAndInitialize :: IO (String, [String]) +getArgsAndInitialize = do + prog <- getProgName + args <- getArgs + nonGLUTArgs <- initialize prog args + return (prog, nonGLUTArgs) + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) De-initialize GLUT. After this, one has to use +-- 'initialize' or 'getArgsAndInitialize' to initialize GLUT again. + +exit :: IO () +exit = glutExit + +-------------------------------------------------------------------------------- + +-- | Controls the /initial window position/. Windows created by +-- 'Graphics.UI.GLUT.Window.createWindow' will be requested to be created with +-- the current /initial window position/. The initial value of the /initial +-- window position/ GLUT state is @'Position' (-1) (-1)@. If either the X or Y +-- component of the /initial window position/ is negative, the actual window +-- position is left to the window system to determine. +-- +-- The intent of the /initial window position/ is to provide a suggestion to +-- the window system for a window\'s initial position. The window system is +-- not obligated to use this information. Therefore, GLUT programs should not +-- assume the window was created at the specified position. + +initialWindowPosition :: StateVar Position +initialWindowPosition = + makeStateVar getInitialWindowPosition setInitialWindowPosition + +getInitialWindowPosition :: IO Position +getInitialWindowPosition = do + x <- simpleGet fromIntegral glut_INIT_WINDOW_X + y <- simpleGet fromIntegral glut_INIT_WINDOW_Y + return $ Position x y + +setInitialWindowPosition :: Position -> IO () +setInitialWindowPosition (Position x y) = + glutInitWindowPosition (fromIntegral x) (fromIntegral y) + +-------------------------------------------------------------------------------- + +-- | Controls the /initial window size/. Windows created by +-- 'Graphics.UI.GLUT.Window.createWindow' will be requested to be created with +-- the current /initial window size/. The initial value of the /initial window +-- size/ GLUT state is @'Size' 300 300@. If either the width or the height +-- component of the /initial window size/ is non-positive, the actual window +-- size is left to the window system to determine. +-- +-- The intent of the /initial window size/ is to provide a suggestion to the +-- window system for a window\'s initial size. The window system is not +-- obligated to use this information. Therefore, GLUT programs should not +-- assume the window was created at the specified size. A GLUT program should +-- use the window\'s reshape callback to determine the true size of the +-- window. + +initialWindowSize :: StateVar Size +initialWindowSize = makeStateVar getInitialWindowSize setInitialWindowSize + +getInitialWindowSize :: IO Size +getInitialWindowSize = do + w <- simpleGet fromIntegral glut_INIT_WINDOW_WIDTH + h <- simpleGet fromIntegral glut_INIT_WINDOW_HEIGHT + return $ Size w h + +setInitialWindowSize :: Size -> IO () +setInitialWindowSize (Size w h) = + glutInitWindowSize (fromIntegral w) (fromIntegral h) + +-------------------------------------------------------------------------------- + +-- | A single aspect of a window which is to be created, used in conjunction +-- with 'initialDisplayMode'. + +data DisplayMode + = RGBAMode + -- ^ Select an RGBA mode window. This is the default if neither 'RGBAMode' + -- nor 'IndexMode' are specified. + | RGBMode + -- ^ An alias for 'RGBAMode'. + | IndexMode + -- ^ Select a color index mode window. This overrides 'RGBAMode' if it is + -- also specified. + | LuminanceMode + -- ^ Select a window with a \"luminance\" color model. This model provides + -- the functionality of OpenGL\'s RGBA color model, but the green and blue + -- components are not maintained in the frame buffer. Instead each pixel\'s + -- red component is converted to an index between zero and + -- 'Graphics.UI.GLUT.Colormap.numColorMapEntries' and looked up in a + -- per-window color map to determine the color of pixels within the window. + -- The initial colormap of 'LuminanceMode' windows is initialized to be a + -- linear gray ramp, but can be modified with GLUT\'s colormap actions. + -- /Implementation Notes:/ 'LuminanceMode' is not supported on most OpenGL + -- platforms. + | WithAlphaComponent + -- ^ Select a window with an alpha component to the color buffer(s). + | WithAccumBuffer + -- ^ Select a window with an accumulation buffer. + | WithDepthBuffer + -- ^ Select a window with a depth buffer. + | WithStencilBuffer + -- ^ Select a window with a stencil buffer. + | WithAuxBuffers Int + -- ^ (/freeglut only/) Select a window with /n/ (1 .. 4) auxiliary buffers. + -- Any /n/ outside the range 1 .. 4 is a fatal error. + | SingleBuffered + -- ^ Select a single buffered window. This is the default if neither + -- 'DoubleBuffered' nor 'SingleBuffered' are specified. + | DoubleBuffered + -- ^ Select a double buffered window. This overrides 'SingleBuffered' if it + -- is also specified. + | Multisampling + -- ^ Select a window with multisampling support. If multisampling is not + -- available, a non-multisampling window will automatically be chosen. + -- Note: both the OpenGL client-side and server-side implementations must + -- support the @GLX_SAMPLE_SGIS@ extension for multisampling to be + -- available. Deprecated, use 'WithSamplesPerPixel'. + | WithSamplesPerPixel Int + -- ^ Select a window with multisampling, using the given samples per pixel. + | Stereoscopic + -- ^ Select a stereo window. + | Captionless + -- ^ Select a window without a caption (/freeglut only/). + | Borderless + -- ^ Select a window without any borders (/freeglut only/). + | SRGBMode + -- ^ Select an sRGB mode window (/freeglut only/). + deriving ( Eq, Ord, Show ) + +marshalDisplayMode :: DisplayMode -> CUInt +marshalDisplayMode m = case m of + RGBAMode -> glut_RGBA + RGBMode -> glut_RGB + IndexMode -> glut_INDEX + LuminanceMode -> glut_LUMINANCE + WithAlphaComponent -> glut_ALPHA + WithAccumBuffer -> glut_ACCUM + WithDepthBuffer -> glut_DEPTH + WithStencilBuffer -> glut_STENCIL + WithAuxBuffers 1 -> glut_AUX1 + WithAuxBuffers 2 -> glut_AUX2 + WithAuxBuffers 3 -> glut_AUX3 + WithAuxBuffers 4 -> glut_AUX4 + WithAuxBuffers n -> + error ("marshalDisplayMode: illegal number of auxiliary buffers: " ++ show n) + SingleBuffered -> glut_SINGLE + DoubleBuffered -> glut_DOUBLE + Multisampling -> glut_MULTISAMPLE + WithSamplesPerPixel _ -> error ("marshalDisplayMode: this should not happen") + Stereoscopic -> glut_STEREO + Captionless -> glut_CAPTIONLESS + Borderless -> glut_BORDERLESS + SRGBMode -> glut_SRGB + +-------------------------------------------------------------------------------- + +-- | Controls the /initial display mode/ used when creating top-level windows, +-- subwindows, and overlays to determine the OpenGL display mode for the +-- to-be-created window or overlay. +-- +-- Note that 'RGBAMode' selects the RGBA color model, but it does not request any +-- bits of alpha (sometimes called an /alpha buffer/ or /destination alpha/) +-- be allocated. To request alpha, specify 'WithAlphaComponent'. The same +-- applies to 'LuminanceMode'. + +initialDisplayMode :: StateVar [DisplayMode] +initialDisplayMode = makeStateVar getInitialDisplayMode setInitialDisplayMode + +getInitialDisplayMode :: IO [DisplayMode] +getInitialDisplayMode = do + mode <- simpleGet fromIntegral glut_INIT_DISPLAY_MODE + let displayModes = i2dms (mode .&. complement glut_MULTISAMPLE) + if mode .&. glut_MULTISAMPLE == 0 + then return displayModes + else do + n <- get samplesPerPixel + return $ WithSamplesPerPixel n : displayModes + +i2dms :: CUInt -> [DisplayMode] +i2dms bitfield | IndexMode `elem` modes || LuminanceMode `elem` modes = modes + | otherwise = RGBAMode : modes + where modes = i2dmsWithoutRGBA bitfield + +i2dmsWithoutRGBA :: CUInt -> [DisplayMode] +i2dmsWithoutRGBA bitfield = + [ c | c <- [ IndexMode, LuminanceMode, WithAlphaComponent, + WithAccumBuffer, WithDepthBuffer, WithStencilBuffer, + WithAuxBuffers 1, WithAuxBuffers 2, WithAuxBuffers 3, + WithAuxBuffers 4, SingleBuffered, DoubleBuffered, Multisampling, + Stereoscopic, Captionless, Borderless, SRGBMode ] + , (bitfield .&. marshalDisplayMode c) /= 0 ] + +setInitialDisplayMode :: [DisplayMode] -> IO () +setInitialDisplayMode modes = do + let (spps, transformedModes) = mapAccumR handleMultisampling [] modes + mapM_ (samplesPerPixel $=) spps + glutInitDisplayMode (toBitfield marshalDisplayMode transformedModes) + +handleMultisampling :: [Int] -> DisplayMode -> ([Int], DisplayMode) +handleMultisampling spps (WithSamplesPerPixel spp) = (spp : spps, Multisampling) +handleMultisampling spps mode = (spps, mode) + +toBitfield :: (Num b, Bits b) => (a -> b) -> [a] -> b +toBitfield marshal = foldl (.|.) 0 . map marshal + +-- | Contains 'True' if the /current display mode/ is supported, 'False' +-- otherwise. + +displayModePossible :: GettableStateVar Bool +displayModePossible = + makeGettableStateVar $ simpleGet (/= 0) glut_DISPLAY_MODE_POSSIBLE + +-------------------------------------------------------------------------------- + +samplesPerPixel :: StateVar Int +samplesPerPixel = makeStateVar getSamplesPerPixel setSamplesPerPixel + +getSamplesPerPixel :: IO Int +getSamplesPerPixel = do + m <- multisamplingSupported + if m + then simpleGet fromIntegral (fromIntegral glut_MULTISAMPLE) + else return defaultSamplesPerPixels + +defaultSamplesPerPixels :: Int +defaultSamplesPerPixels = 4 + +setSamplesPerPixel :: Int -> IO () +setSamplesPerPixel spp = do + m <- multisamplingSupported + when m $ + glutSetOption (fromIntegral glut_MULTISAMPLE) (fromIntegral spp) + +multisamplingSupported :: IO Bool +multisamplingSupported = isKnown "glutGetModeValues" + where isKnown = fmap (/= nullFunPtr) . getAPIEntryInternal + +-------------------------------------------------------------------------------- + +-- | Capabilities for 'initialDisplayCapabilities', most of them are extensions +-- of the constructors of 'DisplayMode'. + +data DisplayCapability + = DisplayRGBA -- ^ Number of bits of red, green, blue, and alpha in the RGBA + -- color buffer. Default is \"'IsAtLeast' @1@\" for red, + -- green, blue, and alpha capabilities, and \"'IsEqualTo' + -- @1@\" for the RGBA color model capability. + | DisplayRGB -- ^ Number of bits of red, green, and blue in the RGBA color + -- buffer and zero bits of alpha color buffer precision. + -- Default is \"'IsAtLeast' @1@\" for the red, green, and + -- blue capabilities, and \"'IsNotLessThan' @0@\" for alpha + -- capability, and \"'IsEqualTo' @1@\" for the RGBA color + -- model capability. + | DisplayRed -- ^ Red color buffer precision in bits. Default is + -- \"'IsAtLeast' @1@\". + | DisplayGreen -- ^ Green color buffer precision in bits. Default is + -- \"'IsAtLeast' @1@\". + | DisplayBlue -- ^ Blue color buffer precision in bits. Default is + -- \"'IsAtLeast' @1@\". + | DisplayIndex -- ^ Boolean if the color model is color index or not. True is + -- color index. Default is \"'IsAtLeast' @1@\". + | DisplayBuffer -- ^ Number of bits in the color index color buffer. Default + -- is \"'IsAtLeast' @1@\". + | DisplaySingle -- ^ Boolean indicate the color buffer is single buffered. + -- Default is \"'IsEqualTo' @1@\". + | DisplayDouble -- ^ Boolean indicating if the color buffer is double + -- buffered. Default is \"'IsEqualTo' @1@\". + | DisplayAccA -- ^ Red, green, blue, and alpha accumulation buffer precision + -- in bits. Default is \"'IsAtLeast' @1@\" for red, green, + -- blue, and alpha capabilities. + | DisplayAcc -- ^ Red, green, and green accumulation buffer precision in + -- bits and zero bits of alpha accumulation buffer precision. + -- Default is \"'IsAtLeast' @1@\" for red, green, and blue + -- capabilities, and \"'IsNotLessThan' @0@\" for the alpha + -- capability. + | DisplayAlpha -- ^ Alpha color buffer precision in bits. Default is + -- \"'IsAtLeast' @1@\". + | DisplayDepth -- ^ Number of bits of precsion in the depth buffer. Default + -- is \"'IsAtLeast' @12@\". + | DisplayStencil -- ^ Number of bits in the stencil buffer. Default is + -- \"'IsNotLessThan' @1@\". + | DisplaySamples -- ^ Indicates the number of multisamples to use based on + -- GLX\'s @SGIS_multisample@ extension (for antialiasing). + -- Default is \"'IsNotGreaterThan' @4@\". This default means + -- that a GLUT application can request multisampling if + -- available by simply specifying \"'With' 'DisplaySamples'\". + | DisplayStereo -- ^ Boolean indicating the color buffer is supports + -- OpenGL-style stereo. Default is \"'IsEqualTo' @1@\". + | DisplayLuminance -- ^ Number of bits of red in the RGBA and zero bits of green, + -- blue (alpha not specified) of color buffer precision. + -- Default is \"'IsAtLeast' @1@\" for the red capabilitis, + -- and \"'IsEqualTo' @0@\" for the green and blue + -- capabilities, and \"'IsEqualTo' @1@\" for the RGBA color + -- model capability, and, for X11, \"'IsEqualTo' @1@\" for + -- the 'DisplayXStaticGray' capability. SGI InfiniteReality (and + -- other future machines) support a 16-bit luminance (single + -- channel) display mode (an additional 16-bit alpha channel + -- can also be requested). The red channel maps to gray + -- scale and green and blue channels are not available. A + -- 16-bit precision luminance display mode is often + -- appropriate for medical imaging applications. Do not + -- expect many machines to support extended precision + -- luminance display modes. + | DisplayAux -- ^ (/freeglut only/) Number of auxiliary buffers. Default is + -- \"'IsEqualTo' @1@\". + | DisplayNum -- ^ A special capability name indicating where the value + -- represents the Nth frame buffer configuration matching + -- the description string. When not specified, + -- 'initialDisplayCapabilities' also uses the first + -- (best matching) configuration. 'Num' requires a relation + -- and numeric value. + | DisplayConformant -- ^ Boolean indicating if the frame buffer configuration is + -- conformant or not. Conformance information is based on + -- GLX\'s @EXT_visual_rating@ extension if supported. If the + -- extension is not supported, all visuals are assumed + -- conformant. Default is \"'IsEqualTo' @1@\". + | DisplaySlow -- ^ Boolean indicating if the frame buffer configuration is + -- slow or not. Slowness information is based on GLX\'s + -- @EXT_visual_rating@ extension if supported. If the + -- extension is not supported, all visuals are assumed fast. + -- Note that slowness is a relative designation relative to + -- other frame buffer configurations available. The intent + -- of the slow capability is to help programs avoid frame + -- buffer configurations that are slower (but perhaps higher + -- precision) for the current machine. Default is + -- \"'IsAtLeast' @0@\". This default means that slow visuals + -- are used in preference to fast visuals, but fast visuals + -- will still be allowed. + | DisplayWin32PFD -- ^ Only recognized on GLUT implementations for Win32, this + -- capability name matches the Win32 Pixel Format Descriptor + -- by number. 'DisplayWin32PFD' can only be used with 'Where'. + | DisplayXVisual -- ^ Only recongized on GLUT implementations for the X Window + -- System, this capability name matches the X visual ID by + -- number. 'DisplayXVisual' requires a relation and numeric value. + | DisplayXStaticGray -- ^ Only recongized on GLUT implementations for the X Window + -- System, boolean indicating if the frame buffer + -- configuration\'s X visual is of type @StaticGray@. + -- Default is \"'IsEqualTo' @1@\". + | DisplayXGrayScale -- ^ Only recongized on GLUT implementations for the X Window + -- System, boolean indicating if the frame buffer + -- configuration\'s X visual is of type @GrayScale@. Default + -- is \"'IsEqualTo' @1@\". + | DisplayXStaticColor -- ^ Only recongized on GLUT implementations for the X Window + -- System, boolean indicating if the frame buffer + -- configuration\'s X visual is of type @StaticColor@. + -- Default is \"'IsEqualTo' @1@\". + | DisplayXPseudoColor -- ^ Only recongized on GLUT implementations for the X Window + -- System, boolean indicating if the frame buffer + -- configuration\'s X visual is of type @PsuedoColor@. + -- Default is \"'IsEqualTo' @1@\". + | DisplayXTrueColor -- ^ Only recongized on GLUT implementations for the X Window + -- System, boolean indicating if the frame buffer + -- configuration\'s X visual is of type @TrueColor@. Default + -- is \"'IsEqualTo' @1@\". + | DisplayXDirectColor -- ^ Only recongized on GLUT implementations for the X Window + -- System, boolean indicating if the frame buffer + -- configuration\'s X visual is of type @DirectColor@. + -- Default is \"'IsEqualTo' @1@\". + deriving ( Eq, Ord, Show ) + +displayCapabilityToString :: DisplayCapability -> String +displayCapabilityToString x = case x of + DisplayRGBA -> "rgba" + DisplayRGB -> "rgb" + DisplayRed -> "red" + DisplayGreen -> "green" + DisplayBlue -> "blue" + DisplayIndex -> "index" + DisplayBuffer -> "buffer" + DisplaySingle -> "single" + DisplayDouble -> "double" + DisplayAccA -> "acca" + DisplayAcc -> "acc" + DisplayAlpha -> "alpha" + DisplayDepth -> "depth" + DisplayStencil -> "stencil" + DisplaySamples -> "samples" + DisplayStereo -> "stereo" + DisplayLuminance -> "luminance" + DisplayAux -> "aux" + DisplayNum -> "num" + DisplayConformant -> "conformant" + DisplaySlow -> "slow" + DisplayWin32PFD -> "win32pfd" + DisplayXVisual -> "xvisual" + DisplayXStaticGray -> "xstaticgray" + DisplayXGrayScale -> "xgrayscale" + DisplayXStaticColor -> "xstaticcolor" + DisplayXPseudoColor -> "xpseudocolor" + DisplayXTrueColor -> "xtruecolor" + DisplayXDirectColor -> "xdirectcolor" + +-- | A single capability description for 'initialDisplayCapabilities'. + +data DisplayCapabilityDescription + = Where DisplayCapability Relation Int + -- ^ A description of a capability with a specific relation to a numeric + -- value. + | With DisplayCapability + -- ^ When the relation and numeric value are not specified, each capability + -- has a different default, see the different constructors of + -- 'DisplayCapability'. + deriving ( Eq, Ord, Show ) + +displayCapabilityDescriptionToString :: DisplayCapabilityDescription -> String +displayCapabilityDescriptionToString (Where c r i) = + displayCapabilityToString c ++ relationToString r ++ show i +displayCapabilityDescriptionToString (With c) = displayCapabilityToString c + +-- | Controls the /initial display mode/ used when creating top-level windows, +-- subwindows, and overlays to determine the OpenGL display mode for the +-- to-be-created window or overlay. It is described by a list of zero or more +-- capability descriptions, which are translated into a set of criteria used to +-- select the appropriate frame buffer configuration. The criteria are matched +-- in strict left to right order of precdence. That is, the first specified +-- criterion (leftmost) takes precedence over the later criteria for non-exact +-- criteria ('IsGreaterThan', 'IsLessThan', etc.). Exact criteria ('IsEqualTo', +-- 'IsNotEqualTo') must match exactly so precedence is not relevant. +-- +-- Unspecified capability descriptions will result in unspecified criteria being +-- generated. These unspecified criteria help 'initialDisplayCapabilities' +-- behave sensibly with terse display mode descriptions. +-- +-- Here is an example using 'initialDisplayCapabilities': +-- +-- @ +-- initialDisplayCapabilities $= [ With DisplayRGB, +-- Where DisplayDepth IsAtLeast 16, +-- With DisplaySamples, +-- Where DisplayStencil IsNotLessThan 2, +-- With DisplayDouble ] +-- @ +-- +-- The above call requests a window with an RGBA color model (but requesting +-- no bits of alpha), a depth buffer with at least 16 bits of precision but +-- preferring more, multisampling if available, at least 2 bits of stencil +-- (favoring less stencil to more as long as 2 bits are available), and double +-- buffering. + +initialDisplayCapabilities :: SettableStateVar [DisplayCapabilityDescription] +initialDisplayCapabilities = + makeSettableStateVar $ \caps -> + withCString + (concat . intersperse " " . map displayCapabilityDescriptionToString $ + caps) + glutInitDisplayString + +----------------------------------------------------------------------------- + +-- | How rendering context for new windows are created. + +data RenderingContext + = -- | Create a new context via @glXCreateContext@ or @wglCreateContext@ + -- (default). + CreateNewContext + | -- | Re-use the current rendering context. + UseCurrentContext + deriving ( Eq, Ord, Show ) + +marshalRenderingContext :: RenderingContext -> CInt +marshalRenderingContext CreateNewContext = glut_CREATE_NEW_CONTEXT +marshalRenderingContext UseCurrentContext = glut_USE_CURRENT_CONTEXT + +unmarshalRenderingContext :: CInt -> RenderingContext +unmarshalRenderingContext r + | r == glut_CREATE_NEW_CONTEXT = CreateNewContext + | r == glut_USE_CURRENT_CONTEXT = UseCurrentContext + | otherwise = error "unmarshalRenderingContext" + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Controls the creation of rendering contexts for new +-- windows. + +renderingContext :: StateVar RenderingContext +renderingContext = + makeStateVar + (simpleGet unmarshalRenderingContext glut_RENDERING_CONTEXT) + (glutSetOption glut_RENDERING_CONTEXT . marshalRenderingContext) + +----------------------------------------------------------------------------- + +-- | The kind of GLX rendering context used. Direct rendering provides a +-- performance advantage in some implementations. However, direct rendering +-- contexts cannot be shared outside a single process, and they may be unable +-- to render to GLX pixmaps. + +data DirectRendering + = -- | Rendering is always done through the X server. This corresponds to + -- the command line argument @-indirect@, see 'initialize'. + ForceIndirectContext + | -- | Try to use direct rendering, silently using indirect rendering if this + -- is not possible. + AllowDirectContext + | -- | Try to use direct rendering, issue a warning and use indirect + -- rendering if this is not possible. + TryDirectContext + | -- | Try to use direct rendering, issue an error and terminate the program + -- if this is not possible.This corresponds to the command line argument + -- @-direct@, see 'initialize'. + ForceDirectContext + deriving ( Eq, Ord, Show ) + +marshalDirectRendering :: DirectRendering -> CInt +marshalDirectRendering x = case x of + ForceIndirectContext -> glut_FORCE_INDIRECT_CONTEXT + AllowDirectContext -> glut_ALLOW_DIRECT_CONTEXT + TryDirectContext -> glut_TRY_DIRECT_CONTEXT + ForceDirectContext -> glut_FORCE_DIRECT_CONTEXT + +unmarshalDirectRendering :: CInt -> DirectRendering +unmarshalDirectRendering x + | x == glut_FORCE_INDIRECT_CONTEXT = ForceIndirectContext + | x == glut_ALLOW_DIRECT_CONTEXT = AllowDirectContext + | x == glut_TRY_DIRECT_CONTEXT = TryDirectContext + | x == glut_FORCE_DIRECT_CONTEXT = ForceDirectContext + | otherwise = error ("unmarshalDirectRendering: illegal value " ++ show x) + +----------------------------------------------------------------------------- + +-- | (/freeglut on X11 only/) Controls which kind of rendering context is +-- created when a new one is required. + +directRendering :: StateVar DirectRendering +directRendering = + makeStateVar + (simpleGet unmarshalDirectRendering glut_DIRECT_RENDERING) + (glutSetOption glut_DIRECT_RENDERING . marshalDirectRendering) + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Controls the API major\/minor version of the OpenGL +-- context. If a version less than or equal to 2.1 is requested, the context +-- returned may implement any version no less than that requested and no +-- greater than 2.1. If version 3.0 is requested, the context returned must +-- implement exactly version 3.0. Versioning behavior once GL versions beyond +-- 3.0 are defined will be defined by an amendment to the OpenGL specification +-- to define dependencies on such GL versions. +-- +-- 'Graphics.Rendering.OpenGL.GL.StringQueries.glVersion' and +-- 'Graphics.Rendering.OpenGL.GL.StringQueries.majorMinor' will return the +-- actual version supported by a context. +-- +-- The default context version is (1, 0), which will typically return an +-- OpenGL 2.1 context, if one is available. + +initialContextVersion :: StateVar (Int, Int) +initialContextVersion = makeStateVar getContextVersion setContextVersion + +getContextVersion :: IO (Int, Int) +getContextVersion = do + major <- simpleGet fromIntegral glut_INIT_MAJOR_VERSION + minor <- simpleGet fromIntegral glut_INIT_MINOR_VERSION + return (major, minor) + +setContextVersion :: (Int, Int) -> IO () +setContextVersion (major, minor) = + glutInitContextVersion (fromIntegral major) (fromIntegral minor) + +----------------------------------------------------------------------------- + +-- | A flag affecting the rendering context to create, used in conjunction +-- with 'initialContextFlags'. + +data ContextFlag + = -- | Debug contexts are intended for use during application development, + -- and provide additional runtime checking, validation, and logging + -- functionality while possibly incurring performance penalties. The + -- additional functionality provided by debug contexts may vary according + -- to the implementation. In some cases a debug context may be identical + -- to a non-debug context. + DebugContext + | -- | Forward-compatible contexts are defined only for OpenGL versions 3.0 + -- and later. They must not support functionality marked as /deprecated/ + -- by that version of the API, while a non-forward-compatible context must + -- support all functionality in that version, deprecated or not. + ForwardCompatibleContext + deriving ( Eq, Ord, Show ) + +marshalContextFlag :: ContextFlag -> CInt +marshalContextFlag x = case x of + DebugContext -> glut_DEBUG + ForwardCompatibleContext -> glut_FORWARD_COMPATIBLE + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Controls the set of flags for the rendering context. + +initialContextFlags :: StateVar [ContextFlag] +initialContextFlags = makeStateVar getContextFlags setContextFlags + +getContextFlags :: IO [ContextFlag] +getContextFlags = simpleGet i2cfs glut_INIT_FLAGS + +i2cfs :: CInt -> [ContextFlag] +i2cfs bitfield = + [ c | c <- [ DebugContext, ForwardCompatibleContext ] + , (fromIntegral bitfield .&. marshalContextFlag c) /= 0 ] + +setContextFlags :: [ContextFlag] -> IO () +setContextFlags = glutInitContextFlags . toBitfield marshalContextFlag + + +----------------------------------------------------------------------------- + +-- | An OpenGL API profile, affecting the rendering context to create, used +-- in conjunction with 'initialContextProfile'. + +data ContextProfile + = -- | The OpenGL /core/ profile, which all OpenGL 3.2 implementations + -- are required to support. + CoreProfile + | -- | The OpenGL /compatibility/ profile, which is optional for OpenGL + -- 3.2 implementations. + CompatibilityProfile + deriving ( Eq, Ord, Show ) + +marshalContextProfile :: ContextProfile -> CInt +marshalContextProfile x = case x of + CoreProfile -> glut_CORE_PROFILE + CompatibilityProfile -> glut_COMPATIBILITY_PROFILE + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Controls the set of profiles for the rendering context. + +initialContextProfile :: StateVar [ContextProfile] +initialContextProfile = makeStateVar getContextProfiles setContextProfiles + +getContextProfiles :: IO [ContextProfile] +getContextProfiles = simpleGet i2cps glut_INIT_PROFILE + +i2cps :: CInt -> [ContextProfile] +i2cps bitfield = + [ c | c <- [ CoreProfile, CompatibilityProfile ] + , (fromIntegral bitfield .&. marshalContextProfile c) /= 0 ] + +setContextProfiles :: [ContextProfile] -> IO () +setContextProfiles = glutInitContextProfile . toBitfield marshalContextProfile diff --git a/Graphics/UI/GLUT/Menu.hs b/Graphics/UI/GLUT/Menu.hs --- a/Graphics/UI/GLUT/Menu.hs +++ b/Graphics/UI/GLUT/Menu.hs @@ -1,248 +1,248 @@ -{-# OPTIONS_GHC -fno-cse #-} - --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Menu --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- GLUT supports simple cascading pop-up menus. They are designed to let a user --- select various modes within a program. The functionality is simple and --- minimalistic and is meant to be that way. Do not mistake GLUT\'s pop-up menu --- facility with an attempt to create a full-featured user interface. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Menu ( - Menu(..), MenuItem(..), MenuCallback, attachMenu, - numMenuItems -) where - -import Data.Array -import Data.IORef -import qualified Data.Map as Map ( empty, lookup, insert, delete ) -import Control.Monad -import Data.Map ( Map ) -import Foreign.C.String -import Foreign.C.Types -import Foreign.Ptr -import Graphics.Rendering.OpenGL ( get, ($=), StateVar - , makeStateVar, GettableStateVar - , makeGettableStateVar ) -import Graphics.UI.GLUT.Callbacks.Registration -import Graphics.UI.GLUT.QueryUtils -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.Types - --------------------------------------------------------------------------------- - --- | A menu is simply a list of menu items. -newtype Menu = Menu [MenuItem] - --- | A single item within a menu can either be a plain menu entry or a sub-menu --- entry, allowing for arbitrarily deep nested menus. -data MenuItem - = MenuEntry String MenuCallback -- ^ A plain menu entry with an associated - -- callback, which is triggered when the - -- user selects the entry - | SubMenu String Menu -- ^ A sub-menu, which is cascaded when the - -- user selects the entry, allowing - -- sub-menu entries to be selected - -type MenuCallback = IO () - --- | Create a new pop-up menu for the /current window,/ attaching it to the --- given mouse button. A previously attached menu (if any), is detached before --- and won\'t receive callbacks anymore. --- --- It is illegal to call 'attachMenu' while any (sub-)menu is in use, i.e. --- popped up. --- --- /X Implementation Notes:/ If available, GLUT for X will take advantage of --- overlay planes for implementing pop-up menus. The use of overlay planes can --- eliminate display callbacks when pop-up menus are deactivated. The --- @SERVER_OVERLAY_VISUALS@ convention is used to determine if overlay visuals --- are available. - -attachMenu :: MouseButton -> Menu -> IO () -attachMenu mouseButton menu@(Menu items) = do - win <- getCurrentWindow "attachMenu" - let hook = MenuHook win mouseButton - detachMenu hook - unless (null items) $ do - (_, destructor) <- traverseMenu menu - addToMenuTable hook destructor - attachMenu_ mouseButton - -detachMenu :: MenuHook -> IO () -detachMenu hook@(MenuHook _ mouseButton) = do - maybeDestructor <- lookupInMenuTable hook - case maybeDestructor of - Nothing -> return () - Just destructor -> do detachMenu_ mouseButton - destructor - deleteFromMenuTable hook - -traverseMenu :: Menu -> IO (MenuID, Destructor) -traverseMenu (Menu items) = do - let callbackArray = listArray (1, length items) (map makeCallback items) - cb <- makeMenuFunc (\i -> callbackArray ! (fromIntegral i)) - menuID <- glutCreateMenu cb - destructors <- zipWithM addMenuItem items [1..] - let destructor = do sequence_ destructors - glutDestroyMenu menuID - freeHaskellFunPtr cb - return (menuID, destructor) - -makeCallback :: MenuItem -> MenuCallback -makeCallback (MenuEntry _ cb) = cb -makeCallback _ = error "shouldn't receive a callback for submenus" - -addMenuItem :: MenuItem -> Value -> IO Destructor -addMenuItem (MenuEntry s _) v = do - addMenuEntry s v - return $ glutRemoveMenuItem 1 -addMenuItem (SubMenu s m) _ = do - (menuID, destructor) <- saveExcursion (traverseMenu m) - addSubMenu s menuID - return $ do glutRemoveMenuItem 1 - destructor - --- Perform an action, saving/restoring the current menu around it -saveExcursion :: IO a -> IO a -saveExcursion act = do - menuID <- get currentMenu - returnValue <- act - when (isRealMenu menuID) $ - currentMenu $= menuID - return returnValue - --------------------------------------------------------------------------------- --- This seems to be a common Haskell hack nowadays: A plain old global variable --- with an associated mutator. Perhaps some language/library support is needed? - -{-# NOINLINE theMenuTable #-} -theMenuTable :: IORef MenuTable -theMenuTable = unsafePerformIO (newIORef emptyMenuTable) - -getMenuTable :: IO MenuTable -getMenuTable = readIORef theMenuTable - -modifyMenuTable :: (MenuTable -> MenuTable) -> IO () -modifyMenuTable = modifyIORef theMenuTable - --------------------------------------------------------------------------------- --- To facilitate cleanup, we have to keep track how to destroy menus which are --- currently attached in a window to a mouse button. - -data MenuHook = MenuHook Window MouseButton - deriving ( Eq, Ord ) - -type Destructor = IO () - -type MenuTable = Map MenuHook Destructor - -emptyMenuTable :: MenuTable -emptyMenuTable = Map.empty - -lookupInMenuTable :: MenuHook -> IO (Maybe Destructor) -lookupInMenuTable callbackID = - fmap (Map.lookup callbackID) getMenuTable - -deleteFromMenuTable :: MenuHook -> IO () -deleteFromMenuTable callbackID = - modifyMenuTable (Map.delete callbackID) - -addToMenuTable :: MenuHook -> Destructor -> IO () -addToMenuTable callbackID funPtr = - modifyMenuTable (Map.insert callbackID funPtr) - --------------------------------------------------------------------------------- - -type MenuID = CInt -type Value = CInt - --------------------------------------------------------------------------------- - --- | Controls the /current menu./ If no menus exist or the previous /current --- menu/ was destroyed, a pseudo menu is returned. - -currentMenu :: StateVar MenuID -currentMenu = makeStateVar glutGetMenu glutSetMenu - --- | Returns 'True' if the given menu identifier refers to a real menu, not --- a pseudo one. - -isRealMenu :: MenuID -> Bool -isRealMenu = (/= 0) - --------------------------------------------------------------------------------- - --- | Add a menu entry to the bottom of the /current menu./ The given string will --- be displayed for the newly added menu entry. If the menu entry is selected by --- the user, the menu\'s callback will be called passing the given value as the --- callback\'s parameter. - -addMenuEntry :: String -> Value -> IO () -addMenuEntry name value = withCString name $ \n -> glutAddMenuEntry n value - --- | Add a sub-menu trigger to the bottom of the /current menu./ The given --- string will be displayed for the newly added sub-menu trigger. If the --- sub-menu trigger is entered, the sub-menu specified by the given menu --- identifier will be cascaded, allowing sub-menu menu items to be selected. - -addSubMenu :: String -> MenuID -> IO () -addSubMenu name menuID = withCString name $ \n -> glutAddSubMenu n menuID - --------------------------------------------------------------------------------- - -{- UNUSED --- | Change the specified menu entry in the /current menu/ into a menu entry. --- The given position determines which menu item should be changed and must be --- between 1 (the topmost menu item) and --- 'Graphics.UI.GLUT.State.getNumMenuItems' inclusive. The menu item to change --- does not have to be a menu entry already. The given string will be displayed --- for the newly changed menu entry. The given value will be returned to the --- menu\'s callback if this menu entry is selected. - -foreign import CALLCONV unsafe "glutChangeToMenuEntry" glutChangeToMenuEntry :: - Item -> CString -> Value -> IO () - --- | Change the specified menu item in the /current menu/ into a sub-menu --- trigger. The given position determines which menu item should be changed and --- must be between 1 and 'Graphics.UI.GLUT.State.getNumMenuItems' inclusive. The --- menu item to change does not have to be a sub-menu trigger already. The --- given name will be displayed for the newly changed sub-menu trigger. The --- given menu identifier names the sub-menu to cascade from the newly added --- sub-menu trigger. - -foreign import CALLCONV unsafe "glutChangeToSubMenu" glutChangeToSubMenu :: - Item -> CString -> MenuID -> IO () --} - --------------------------------------------------------------------------------- - --- | Attach a mouse button for the /current window/ to the identifier of the --- /current menu./ By attaching a menu identifier to a button, the named menu --- will be popped up when the user presses the specified button. Note that the --- menu is attached to the button by identifier, not by reference. - - -attachMenu_ :: MouseButton -> IO () -attachMenu_ = glutAttachMenu . marshalMouseButton - --- | Detach an attached mouse button from the /current window./ - -detachMenu_ :: MouseButton -> IO () -detachMenu_ = glutDetachMenu . marshalMouseButton - --------------------------------------------------------------------------------- - --- | Contains the number of menu items in the /current menu./ - -numMenuItems :: GettableStateVar Int -numMenuItems = makeGettableStateVar $ simpleGet fromIntegral glut_MENU_NUM_ITEMS +{-# OPTIONS_GHC -fno-cse #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Menu +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- GLUT supports simple cascading pop-up menus. They are designed to let a user +-- select various modes within a program. The functionality is simple and +-- minimalistic and is meant to be that way. Do not mistake GLUT\'s pop-up menu +-- facility with an attempt to create a full-featured user interface. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Menu ( + Menu(..), MenuItem(..), MenuCallback, attachMenu, + numMenuItems +) where + +import Data.Array +import Data.IORef +import qualified Data.Map as Map ( empty, lookup, insert, delete ) +import Control.Monad +import Data.Map ( Map ) +import Foreign.C.String +import Foreign.C.Types +import Foreign.Ptr +import Graphics.Rendering.OpenGL ( get, ($=), StateVar + , makeStateVar, GettableStateVar + , makeGettableStateVar ) +import Graphics.UI.GLUT.Callbacks.Registration +import Graphics.UI.GLUT.QueryUtils +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.Types + +-------------------------------------------------------------------------------- + +-- | A menu is simply a list of menu items. +newtype Menu = Menu [MenuItem] + +-- | A single item within a menu can either be a plain menu entry or a sub-menu +-- entry, allowing for arbitrarily deep nested menus. +data MenuItem + = MenuEntry String MenuCallback -- ^ A plain menu entry with an associated + -- callback, which is triggered when the + -- user selects the entry + | SubMenu String Menu -- ^ A sub-menu, which is cascaded when the + -- user selects the entry, allowing + -- sub-menu entries to be selected + +type MenuCallback = IO () + +-- | Create a new pop-up menu for the /current window,/ attaching it to the +-- given mouse button. A previously attached menu (if any), is detached before +-- and won\'t receive callbacks anymore. +-- +-- It is illegal to call 'attachMenu' while any (sub-)menu is in use, i.e. +-- popped up. +-- +-- /X Implementation Notes:/ If available, GLUT for X will take advantage of +-- overlay planes for implementing pop-up menus. The use of overlay planes can +-- eliminate display callbacks when pop-up menus are deactivated. The +-- @SERVER_OVERLAY_VISUALS@ convention is used to determine if overlay visuals +-- are available. + +attachMenu :: MouseButton -> Menu -> IO () +attachMenu mouseButton menu@(Menu items) = do + win <- getCurrentWindow "attachMenu" + let hook = MenuHook win mouseButton + detachMenu hook + unless (null items) $ do + (_, destructor) <- traverseMenu menu + addToMenuTable hook destructor + attachMenu_ mouseButton + +detachMenu :: MenuHook -> IO () +detachMenu hook@(MenuHook _ mouseButton) = do + maybeDestructor <- lookupInMenuTable hook + case maybeDestructor of + Nothing -> return () + Just destructor -> do detachMenu_ mouseButton + destructor + deleteFromMenuTable hook + +traverseMenu :: Menu -> IO (MenuID, Destructor) +traverseMenu (Menu items) = do + let callbackArray = listArray (1, length items) (map makeCallback items) + cb <- makeMenuFunc (\i -> callbackArray ! (fromIntegral i)) + menuID <- glutCreateMenu cb + destructors <- zipWithM addMenuItem items [1..] + let destructor = do sequence_ destructors + glutDestroyMenu menuID + freeHaskellFunPtr cb + return (menuID, destructor) + +makeCallback :: MenuItem -> MenuCallback +makeCallback (MenuEntry _ cb) = cb +makeCallback _ = error "shouldn't receive a callback for submenus" + +addMenuItem :: MenuItem -> Value -> IO Destructor +addMenuItem (MenuEntry s _) v = do + addMenuEntry s v + return $ glutRemoveMenuItem 1 +addMenuItem (SubMenu s m) _ = do + (menuID, destructor) <- saveExcursion (traverseMenu m) + addSubMenu s menuID + return $ do glutRemoveMenuItem 1 + destructor + +-- Perform an action, saving/restoring the current menu around it +saveExcursion :: IO a -> IO a +saveExcursion act = do + menuID <- get currentMenu + returnValue <- act + when (isRealMenu menuID) $ + currentMenu $= menuID + return returnValue + +-------------------------------------------------------------------------------- +-- This seems to be a common Haskell hack nowadays: A plain old global variable +-- with an associated mutator. Perhaps some language/library support is needed? + +{-# NOINLINE theMenuTable #-} +theMenuTable :: IORef MenuTable +theMenuTable = unsafePerformIO (newIORef emptyMenuTable) + +getMenuTable :: IO MenuTable +getMenuTable = readIORef theMenuTable + +modifyMenuTable :: (MenuTable -> MenuTable) -> IO () +modifyMenuTable = modifyIORef theMenuTable + +-------------------------------------------------------------------------------- +-- To facilitate cleanup, we have to keep track how to destroy menus which are +-- currently attached in a window to a mouse button. + +data MenuHook = MenuHook Window MouseButton + deriving ( Eq, Ord ) + +type Destructor = IO () + +type MenuTable = Map MenuHook Destructor + +emptyMenuTable :: MenuTable +emptyMenuTable = Map.empty + +lookupInMenuTable :: MenuHook -> IO (Maybe Destructor) +lookupInMenuTable callbackID = + fmap (Map.lookup callbackID) getMenuTable + +deleteFromMenuTable :: MenuHook -> IO () +deleteFromMenuTable callbackID = + modifyMenuTable (Map.delete callbackID) + +addToMenuTable :: MenuHook -> Destructor -> IO () +addToMenuTable callbackID funPtr = + modifyMenuTable (Map.insert callbackID funPtr) + +-------------------------------------------------------------------------------- + +type MenuID = CInt +type Value = CInt + +-------------------------------------------------------------------------------- + +-- | Controls the /current menu./ If no menus exist or the previous /current +-- menu/ was destroyed, a pseudo menu is returned. + +currentMenu :: StateVar MenuID +currentMenu = makeStateVar glutGetMenu glutSetMenu + +-- | Returns 'True' if the given menu identifier refers to a real menu, not +-- a pseudo one. + +isRealMenu :: MenuID -> Bool +isRealMenu = (/= 0) + +-------------------------------------------------------------------------------- + +-- | Add a menu entry to the bottom of the /current menu./ The given string will +-- be displayed for the newly added menu entry. If the menu entry is selected by +-- the user, the menu\'s callback will be called passing the given value as the +-- callback\'s parameter. + +addMenuEntry :: String -> Value -> IO () +addMenuEntry name value = withCString name $ \n -> glutAddMenuEntry n value + +-- | Add a sub-menu trigger to the bottom of the /current menu./ The given +-- string will be displayed for the newly added sub-menu trigger. If the +-- sub-menu trigger is entered, the sub-menu specified by the given menu +-- identifier will be cascaded, allowing sub-menu menu items to be selected. + +addSubMenu :: String -> MenuID -> IO () +addSubMenu name menuID = withCString name $ \n -> glutAddSubMenu n menuID + +-------------------------------------------------------------------------------- + +{- UNUSED +-- | Change the specified menu entry in the /current menu/ into a menu entry. +-- The given position determines which menu item should be changed and must be +-- between 1 (the topmost menu item) and +-- 'Graphics.UI.GLUT.State.getNumMenuItems' inclusive. The menu item to change +-- does not have to be a menu entry already. The given string will be displayed +-- for the newly changed menu entry. The given value will be returned to the +-- menu\'s callback if this menu entry is selected. + +foreign import CALLCONV unsafe "glutChangeToMenuEntry" glutChangeToMenuEntry :: + Item -> CString -> Value -> IO () + +-- | Change the specified menu item in the /current menu/ into a sub-menu +-- trigger. The given position determines which menu item should be changed and +-- must be between 1 and 'Graphics.UI.GLUT.State.getNumMenuItems' inclusive. The +-- menu item to change does not have to be a sub-menu trigger already. The +-- given name will be displayed for the newly changed sub-menu trigger. The +-- given menu identifier names the sub-menu to cascade from the newly added +-- sub-menu trigger. + +foreign import CALLCONV unsafe "glutChangeToSubMenu" glutChangeToSubMenu :: + Item -> CString -> MenuID -> IO () +-} + +-------------------------------------------------------------------------------- + +-- | Attach a mouse button for the /current window/ to the identifier of the +-- /current menu./ By attaching a menu identifier to a button, the named menu +-- will be popped up when the user presses the specified button. Note that the +-- menu is attached to the button by identifier, not by reference. + + +attachMenu_ :: MouseButton -> IO () +attachMenu_ = glutAttachMenu . marshalMouseButton + +-- | Detach an attached mouse button from the /current window./ + +detachMenu_ :: MouseButton -> IO () +detachMenu_ = glutDetachMenu . marshalMouseButton + +-------------------------------------------------------------------------------- + +-- | Contains the number of menu items in the /current menu./ + +numMenuItems :: GettableStateVar Int +numMenuItems = makeGettableStateVar $ simpleGet fromIntegral glut_MENU_NUM_ITEMS diff --git a/Graphics/UI/GLUT/Objects.hs b/Graphics/UI/GLUT/Objects.hs --- a/Graphics/UI/GLUT/Objects.hs +++ b/Graphics/UI/GLUT/Objects.hs @@ -1,337 +1,337 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Objects --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- GLUT includes a number of routines for generating easily recognizable 3D --- geometric objects. These routines reflect functionality available in the --- @aux@ toolkit described in the /OpenGL Programmer\'s Guide/ and are included --- in GLUT to allow the construction of simple GLUT programs that render --- recognizable objects. These routines can be implemented as pure OpenGL --- rendering routines. The routines do not generate display lists for the --- objects they create. The routines generate normals appropriate for lighting --- but do not generate texture coordinates (except for the teapot). --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Objects ( - -- * Rendering flavour - Flavour(..), - - -- * Object description - Object(..), - - -- * Type synonyms - Sides, Rings, NumLevels, - - -- * Rendering - renderObject -) where - -import Foreign.C.Types -import Foreign.Marshal.Utils -import Foreign.Ptr -import Graphics.Rendering.OpenGL ( Height, Radius, Slices, Stacks, GLint, GLdouble, Vertex3(..) ) -import Graphics.UI.GLUT.Raw - --------------------------------------------------------------------------------- - --- | Flavour of object rendering - -data Flavour - = -- | Object is rendered as a solid with shading and surface normals. - Solid - | -- | Object is rendered as a wireframe without surface normals. - Wireframe - deriving ( Eq, Ord, Show ) - --------------------------------------------------------------------------------- - --- | GLUT offers five types of objects: --- --- * The five Platonic solids, see --- . --- --- * A rhombic dodecahedron, see --- . --- --- * Approximations to rounded objects. --- --- * The classic teapot modeled by Martin Newell in 1975. Both surface normals --- and texture coordinates for the teapot are generated. The teapot is --- generated with OpenGL evaluators. --- --- * A Sierpinski sponge, see --- . - -data Object - = -- | A cube centered at the modeling coordinates origin with sides of the - -- given length. - Cube Height - | -- | A dodecahedron (12-sided regular solid) centered at the modeling - -- coordinates origin with a radius of @sqrt 3@. - Dodecahedron - | -- | A icosahedron (20-sided regular solid) centered at the modeling - -- coordinates origin with a radius of 1.0. - Icosahedron - | -- | Render a solid octahedron (8-sided regular solid) centered at the - -- modeling coordinates origin with a radius of 1.0. - Octahedron - | -- | Render a solid tetrahedron (4-sided regular solid) centered at the - -- modeling coordinates origin with a radius of @sqrt 3@. - Tetrahedron - | -- | (/freeglut only/) A rhombic dodecahedron whose corners are at most a - -- distance of one from the origin. The rhombic dodecahedron has faces - -- which are identical rhombi, but which have some vertices at which three - -- faces meet and some vertices at which four faces meet. The length of - -- each side is @(sqrt 3)\/2@. Vertices at which four faces meet are found - -- at @(0, 0, +\/-1)@ and @(+\/-(sqrt 2)\/2, +\/-(sqrt 2)\/2, 0)@. - RhombicDodecahedron - | -- | A sphere centered at the modeling coordinates origin of the specified - -- radius. The sphere is subdivided around the Z axis into slices - -- (similar to lines of longitude) and along the Z axis into stacks - -- (similar to lines of latitude). - Sphere' Radius Slices Stacks - | -- | A cone oriented along the Z axis. The base of the cone is placed at Z - -- = 0, and the top at Z = the given height. The cone is subdivided - -- around the Z axis into slices, and along the Z axis into stacks. - Cone Radius Height Slices Stacks - | -- |(/freeglut only/) A cylinder oriented along the Z axis. The base of the - -- cylinder is placed at Z = 0, and the top at Z = the given height. The - -- cylinder is subdivided around the Z axis into slices, and along the Z - -- axis into stacks. - Cylinder' Radius Height Slices Stacks - | -- | A torus (doughnut) centered at the modeling coordinates origin - -- whose axis is aligned with the Z axis. The torus is described by its - -- inner and outer radius, the number of sides for each radial section, - -- and the number of radial divisions (rings). - Torus Radius Radius Sides Rings - | -- | A teapot with a given relative size. - Teapot Height - | -- |(/freeglut only/) A Sierpinski sponge of a given level, where a level - -- 0 sponge is the same as a 'Tetrahedron'. - SierpinskiSponge NumLevels - deriving ( Eq, Ord, Show ) - --------------------------------------------------------------------------------- - -type Sides = GLint -type Rings = GLint -type NumLevels = GLint - --------------------------------------------------------------------------------- - --- | Render an object in the given flavour. - -renderObject :: Flavour -> Object -> IO () -renderObject Solid (Cube h) = solidCube h -renderObject Wireframe (Cube h) = wireCube h -renderObject Solid Dodecahedron = solidDodecahedron -renderObject Wireframe Dodecahedron = wireDodecahedron -renderObject Solid Icosahedron = solidIcosahedron -renderObject Wireframe Icosahedron = wireIcosahedron -renderObject Solid Octahedron = solidOctahedron -renderObject Wireframe Octahedron = wireOctahedron -renderObject Solid Tetrahedron = solidTetrahedron -renderObject Wireframe Tetrahedron = wireTetrahedron -renderObject Solid RhombicDodecahedron = glutSolidRhombicDodecahedron -renderObject Wireframe RhombicDodecahedron = glutWireRhombicDodecahedron -renderObject Solid (Sphere' r s t) = solidSphere r s t -renderObject Wireframe (Sphere' r s t) = wireSphere r s t -renderObject Solid (Cone r h s t) = solidCone r h s t -renderObject Wireframe (Cone r h s t) = wireCone r h s t -renderObject Solid (Cylinder' r h s t) = glutSolidCylinder r h s t -renderObject Wireframe (Cylinder' r h s t) = glutWireCylinder r h s t -renderObject Solid (Torus i o s r) = solidTorus i o s r -renderObject Wireframe (Torus i o s r) = wireTorus i o s r -renderObject Solid (Teapot h) = solidTeapot h -renderObject Wireframe (Teapot h) = wireTeapot h -renderObject Solid (SierpinskiSponge n) = solidSierpinskiSponge n -renderObject Wireframe (SierpinskiSponge n) = wireSierpinskiSponge n - --------------------------------------------------------------------------------- - --- | Render a solid cube centered at the modeling coordinates origin with sides --- of the given length. - -solidCube - :: Height -- ^ Length of the cube sides - -> IO () -solidCube = glutSolidCube - --- | Render a wireframe cube centered at the modeling coordinates origin with --- sides of the given length. - -wireCube - :: Height -- ^ Length of the cube sides - -> IO () -wireCube = glutWireCube - --------------------------------------------------------------------------------- - --- | Render a solid dodecahedron (12-sided regular solid) centered at the --- modeling coordinates origin with a radius of @sqrt 3@. - -solidDodecahedron :: IO () -solidDodecahedron = glutSolidDodecahedron - --- | Render a wireframe dodecahedron (12-sided regular solid) centered at the --- modeling coordinates origin with a radius of @sqrt 3@. - -wireDodecahedron :: IO () -wireDodecahedron = glutWireDodecahedron - --------------------------------------------------------------------------------- - --- | Render a solid icosahedron (20-sided regular solid) centered at the --- modeling coordinates origin with a radius of 1.0. - -wireIcosahedron :: IO () -wireIcosahedron = glutWireIcosahedron - --- | Render a wireframe icosahedron (20-sided regular solid) centered at the --- modeling coordinates origin with a radius of 1.0. - -solidIcosahedron :: IO () -solidIcosahedron = glutSolidIcosahedron - --------------------------------------------------------------------------------- - --- | Render a solid octahedron (8-sided regular solid) centered at the modeling --- coordinates origin with a radius of 1.0. - -solidOctahedron :: IO () -solidOctahedron = glutSolidOctahedron - --- | Render a wireframe octahedron (8-sided regular solid) centered at the --- modeling coordinates origin with a radius of 1.0. - -wireOctahedron :: IO () -wireOctahedron = glutWireOctahedron - --------------------------------------------------------------------------------- - --- | Render a solid tetrahedron (4-sided regular solid) centered at the modeling --- coordinates origin with a radius of @sqrt 3@. - -wireTetrahedron :: IO () -wireTetrahedron = glutWireTetrahedron - --- | Render a wireframe tetrahedron (4-sided regular solid) centered at the --- modeling coordinates origin with a radius of @sqrt 3@. - -solidTetrahedron :: IO () -solidTetrahedron = glutSolidTetrahedron - --------------------------------------------------------------------------------- - --- | Render a solid sphere centered at the modeling coordinates origin of the --- specified radius. The sphere is subdivided around the Z axis into slices --- and along the Z axis into stacks. - -solidSphere - :: Radius -- ^ Radius of the sphere. - -> Slices -- ^ Number of subdivisions (slices) around the Z axis, similar - -- to lines of longitude. - -> Stacks -- ^ The number of subdivisions (stacks) along the Z axis, - -- similar to lines of latitude. - -> IO () -solidSphere = glutSolidSphere - --- | Render a wireframe sphere centered at the modeling coordinates origin of --- the specified radius. The sphere is subdivided around the Z axis into slices --- and along the Z axis into stacks. - -wireSphere - :: Radius -- ^ Radius of the sphere. - -> Slices -- ^ Number of subdivisions (slices) around the Z axis, similar - -- to lines of longitude. - -> Stacks -- ^ The number of subdivisions (stacks) along the Z axis, - -- similar to lines of latitude. - -> IO () -wireSphere = glutWireSphere - --------------------------------------------------------------------------------- - --- | Render a solid cone oriented along the Z axis. The base of the cone is --- placed at Z = 0, and the top at Z = height. The cone is subdivided around the --- Z axis into slices, and along the Z axis into stacks. - -solidCone - :: Radius -- ^ Radius of the base of the cone. - -> Height -- ^ Height of the cone. - -> Slices -- ^ Number of subdivisions around the Z axis. - -> Stacks -- ^ The number of subdivisions along the Z axis. - -> IO () -solidCone = glutSolidCone - --- | Render a wireframe cone oriented along the Z axis. The base of the cone is --- placed at Z = 0, and the top at Z = height. The cone is subdivided around the --- Z axis into slices, and along the Z axis into stacks. - -wireCone - :: Radius -- ^ Radius of the base of the cone. - -> Height -- ^ Height of the cone. - -> Slices -- ^ Number of subdivisions around the Z axis. - -> Stacks -- ^ The number of subdivisions along the Z axis. - -> IO () -wireCone = glutWireCone - --------------------------------------------------------------------------------- - --- | Render a solid torus (doughnut) centered at the modeling coordinates origin --- whose axis is aligned with the Z axis. - -solidTorus - :: Radius -- ^ Inner radius of the torus. - -> Radius -- ^ Outer radius of the torus. - -> Slices -- ^ Number of sides for each radial section. - -> Stacks -- ^ Number of radial divisions for the torus. - -> IO () -solidTorus = glutSolidTorus - --- | Render a wireframe torus (doughnut) centered at the modeling coordinates --- origin whose axis is aligned with the Z axis. - -wireTorus - :: Radius -- ^ Inner radius of the torus. - -> Radius -- ^ Outer radius of the torus. - -> Slices -- ^ Number of sides for each radial section. - -> Stacks -- ^ Number of radial divisions for the torus. - -> IO () -wireTorus = glutWireTorus - --------------------------------------------------------------------------------- - --- | Render a solid teapot. - -solidTeapot - :: Height -- ^ Relative size of the teapot - -> IO () -solidTeapot = glutSolidTeapot - --- | Render a wireframe teapot. - -wireTeapot - :: Height -- ^ Relative size of the teapot - -> IO () -wireTeapot = glutWireTeapot - --------------------------------------------------------------------------------- - -solidSierpinskiSponge :: NumLevels -> IO () -solidSierpinskiSponge = sierpinskiSponge glutSolidSierpinskiSponge - -wireSierpinskiSponge :: NumLevels -> IO () -wireSierpinskiSponge = sierpinskiSponge glutWireSierpinskiSponge - --- for consistency, we hide the offset and scale on the Haskell side -sierpinskiSponge :: (CInt -> Ptr GLdouble -> Height -> IO ()) -> NumLevels -> IO () -sierpinskiSponge f n = - with (Vertex3 0 0 0) $ \offsetBuf -> - f (fromIntegral n) ((castPtr :: Ptr (Vertex3 GLdouble) -> Ptr GLdouble) offsetBuf) 1 +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Objects +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- GLUT includes a number of routines for generating easily recognizable 3D +-- geometric objects. These routines reflect functionality available in the +-- @aux@ toolkit described in the /OpenGL Programmer\'s Guide/ and are included +-- in GLUT to allow the construction of simple GLUT programs that render +-- recognizable objects. These routines can be implemented as pure OpenGL +-- rendering routines. The routines do not generate display lists for the +-- objects they create. The routines generate normals appropriate for lighting +-- but do not generate texture coordinates (except for the teapot). +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Objects ( + -- * Rendering flavour + Flavour(..), + + -- * Object description + Object(..), + + -- * Type synonyms + Sides, Rings, NumLevels, + + -- * Rendering + renderObject +) where + +import Foreign.C.Types +import Foreign.Marshal.Utils +import Foreign.Ptr +import Graphics.Rendering.OpenGL ( Height, Radius, Slices, Stacks, GLint, GLdouble, Vertex3(..) ) +import Graphics.UI.GLUT.Raw + +-------------------------------------------------------------------------------- + +-- | Flavour of object rendering + +data Flavour + = -- | Object is rendered as a solid with shading and surface normals. + Solid + | -- | Object is rendered as a wireframe without surface normals. + Wireframe + deriving ( Eq, Ord, Show ) + +-------------------------------------------------------------------------------- + +-- | GLUT offers five types of objects: +-- +-- * The five Platonic solids, see +-- . +-- +-- * A rhombic dodecahedron, see +-- . +-- +-- * Approximations to rounded objects. +-- +-- * The classic teapot modeled by Martin Newell in 1975. Both surface normals +-- and texture coordinates for the teapot are generated. The teapot is +-- generated with OpenGL evaluators. +-- +-- * A Sierpinski sponge, see +-- . + +data Object + = -- | A cube centered at the modeling coordinates origin with sides of the + -- given length. + Cube Height + | -- | A dodecahedron (12-sided regular solid) centered at the modeling + -- coordinates origin with a radius of @sqrt 3@. + Dodecahedron + | -- | A icosahedron (20-sided regular solid) centered at the modeling + -- coordinates origin with a radius of 1.0. + Icosahedron + | -- | Render a solid octahedron (8-sided regular solid) centered at the + -- modeling coordinates origin with a radius of 1.0. + Octahedron + | -- | Render a solid tetrahedron (4-sided regular solid) centered at the + -- modeling coordinates origin with a radius of @sqrt 3@. + Tetrahedron + | -- | (/freeglut only/) A rhombic dodecahedron whose corners are at most a + -- distance of one from the origin. The rhombic dodecahedron has faces + -- which are identical rhombi, but which have some vertices at which three + -- faces meet and some vertices at which four faces meet. The length of + -- each side is @(sqrt 3)\/2@. Vertices at which four faces meet are found + -- at @(0, 0, +\/-1)@ and @(+\/-(sqrt 2)\/2, +\/-(sqrt 2)\/2, 0)@. + RhombicDodecahedron + | -- | A sphere centered at the modeling coordinates origin of the specified + -- radius. The sphere is subdivided around the Z axis into slices + -- (similar to lines of longitude) and along the Z axis into stacks + -- (similar to lines of latitude). + Sphere' Radius Slices Stacks + | -- | A cone oriented along the Z axis. The base of the cone is placed at Z + -- = 0, and the top at Z = the given height. The cone is subdivided + -- around the Z axis into slices, and along the Z axis into stacks. + Cone Radius Height Slices Stacks + | -- |(/freeglut only/) A cylinder oriented along the Z axis. The base of the + -- cylinder is placed at Z = 0, and the top at Z = the given height. The + -- cylinder is subdivided around the Z axis into slices, and along the Z + -- axis into stacks. + Cylinder' Radius Height Slices Stacks + | -- | A torus (doughnut) centered at the modeling coordinates origin + -- whose axis is aligned with the Z axis. The torus is described by its + -- inner and outer radius, the number of sides for each radial section, + -- and the number of radial divisions (rings). + Torus Radius Radius Sides Rings + | -- | A teapot with a given relative size. + Teapot Height + | -- |(/freeglut only/) A Sierpinski sponge of a given level, where a level + -- 0 sponge is the same as a 'Tetrahedron'. + SierpinskiSponge NumLevels + deriving ( Eq, Ord, Show ) + +-------------------------------------------------------------------------------- + +type Sides = GLint +type Rings = GLint +type NumLevels = GLint + +-------------------------------------------------------------------------------- + +-- | Render an object in the given flavour. + +renderObject :: Flavour -> Object -> IO () +renderObject Solid (Cube h) = solidCube h +renderObject Wireframe (Cube h) = wireCube h +renderObject Solid Dodecahedron = solidDodecahedron +renderObject Wireframe Dodecahedron = wireDodecahedron +renderObject Solid Icosahedron = solidIcosahedron +renderObject Wireframe Icosahedron = wireIcosahedron +renderObject Solid Octahedron = solidOctahedron +renderObject Wireframe Octahedron = wireOctahedron +renderObject Solid Tetrahedron = solidTetrahedron +renderObject Wireframe Tetrahedron = wireTetrahedron +renderObject Solid RhombicDodecahedron = glutSolidRhombicDodecahedron +renderObject Wireframe RhombicDodecahedron = glutWireRhombicDodecahedron +renderObject Solid (Sphere' r s t) = solidSphere r s t +renderObject Wireframe (Sphere' r s t) = wireSphere r s t +renderObject Solid (Cone r h s t) = solidCone r h s t +renderObject Wireframe (Cone r h s t) = wireCone r h s t +renderObject Solid (Cylinder' r h s t) = glutSolidCylinder r h s t +renderObject Wireframe (Cylinder' r h s t) = glutWireCylinder r h s t +renderObject Solid (Torus i o s r) = solidTorus i o s r +renderObject Wireframe (Torus i o s r) = wireTorus i o s r +renderObject Solid (Teapot h) = solidTeapot h +renderObject Wireframe (Teapot h) = wireTeapot h +renderObject Solid (SierpinskiSponge n) = solidSierpinskiSponge n +renderObject Wireframe (SierpinskiSponge n) = wireSierpinskiSponge n + +-------------------------------------------------------------------------------- + +-- | Render a solid cube centered at the modeling coordinates origin with sides +-- of the given length. + +solidCube + :: Height -- ^ Length of the cube sides + -> IO () +solidCube = glutSolidCube + +-- | Render a wireframe cube centered at the modeling coordinates origin with +-- sides of the given length. + +wireCube + :: Height -- ^ Length of the cube sides + -> IO () +wireCube = glutWireCube + +-------------------------------------------------------------------------------- + +-- | Render a solid dodecahedron (12-sided regular solid) centered at the +-- modeling coordinates origin with a radius of @sqrt 3@. + +solidDodecahedron :: IO () +solidDodecahedron = glutSolidDodecahedron + +-- | Render a wireframe dodecahedron (12-sided regular solid) centered at the +-- modeling coordinates origin with a radius of @sqrt 3@. + +wireDodecahedron :: IO () +wireDodecahedron = glutWireDodecahedron + +-------------------------------------------------------------------------------- + +-- | Render a solid icosahedron (20-sided regular solid) centered at the +-- modeling coordinates origin with a radius of 1.0. + +wireIcosahedron :: IO () +wireIcosahedron = glutWireIcosahedron + +-- | Render a wireframe icosahedron (20-sided regular solid) centered at the +-- modeling coordinates origin with a radius of 1.0. + +solidIcosahedron :: IO () +solidIcosahedron = glutSolidIcosahedron + +-------------------------------------------------------------------------------- + +-- | Render a solid octahedron (8-sided regular solid) centered at the modeling +-- coordinates origin with a radius of 1.0. + +solidOctahedron :: IO () +solidOctahedron = glutSolidOctahedron + +-- | Render a wireframe octahedron (8-sided regular solid) centered at the +-- modeling coordinates origin with a radius of 1.0. + +wireOctahedron :: IO () +wireOctahedron = glutWireOctahedron + +-------------------------------------------------------------------------------- + +-- | Render a solid tetrahedron (4-sided regular solid) centered at the modeling +-- coordinates origin with a radius of @sqrt 3@. + +wireTetrahedron :: IO () +wireTetrahedron = glutWireTetrahedron + +-- | Render a wireframe tetrahedron (4-sided regular solid) centered at the +-- modeling coordinates origin with a radius of @sqrt 3@. + +solidTetrahedron :: IO () +solidTetrahedron = glutSolidTetrahedron + +-------------------------------------------------------------------------------- + +-- | Render a solid sphere centered at the modeling coordinates origin of the +-- specified radius. The sphere is subdivided around the Z axis into slices +-- and along the Z axis into stacks. + +solidSphere + :: Radius -- ^ Radius of the sphere. + -> Slices -- ^ Number of subdivisions (slices) around the Z axis, similar + -- to lines of longitude. + -> Stacks -- ^ The number of subdivisions (stacks) along the Z axis, + -- similar to lines of latitude. + -> IO () +solidSphere = glutSolidSphere + +-- | Render a wireframe sphere centered at the modeling coordinates origin of +-- the specified radius. The sphere is subdivided around the Z axis into slices +-- and along the Z axis into stacks. + +wireSphere + :: Radius -- ^ Radius of the sphere. + -> Slices -- ^ Number of subdivisions (slices) around the Z axis, similar + -- to lines of longitude. + -> Stacks -- ^ The number of subdivisions (stacks) along the Z axis, + -- similar to lines of latitude. + -> IO () +wireSphere = glutWireSphere + +-------------------------------------------------------------------------------- + +-- | Render a solid cone oriented along the Z axis. The base of the cone is +-- placed at Z = 0, and the top at Z = height. The cone is subdivided around the +-- Z axis into slices, and along the Z axis into stacks. + +solidCone + :: Radius -- ^ Radius of the base of the cone. + -> Height -- ^ Height of the cone. + -> Slices -- ^ Number of subdivisions around the Z axis. + -> Stacks -- ^ The number of subdivisions along the Z axis. + -> IO () +solidCone = glutSolidCone + +-- | Render a wireframe cone oriented along the Z axis. The base of the cone is +-- placed at Z = 0, and the top at Z = height. The cone is subdivided around the +-- Z axis into slices, and along the Z axis into stacks. + +wireCone + :: Radius -- ^ Radius of the base of the cone. + -> Height -- ^ Height of the cone. + -> Slices -- ^ Number of subdivisions around the Z axis. + -> Stacks -- ^ The number of subdivisions along the Z axis. + -> IO () +wireCone = glutWireCone + +-------------------------------------------------------------------------------- + +-- | Render a solid torus (doughnut) centered at the modeling coordinates origin +-- whose axis is aligned with the Z axis. + +solidTorus + :: Radius -- ^ Inner radius of the torus. + -> Radius -- ^ Outer radius of the torus. + -> Slices -- ^ Number of sides for each radial section. + -> Stacks -- ^ Number of radial divisions for the torus. + -> IO () +solidTorus = glutSolidTorus + +-- | Render a wireframe torus (doughnut) centered at the modeling coordinates +-- origin whose axis is aligned with the Z axis. + +wireTorus + :: Radius -- ^ Inner radius of the torus. + -> Radius -- ^ Outer radius of the torus. + -> Slices -- ^ Number of sides for each radial section. + -> Stacks -- ^ Number of radial divisions for the torus. + -> IO () +wireTorus = glutWireTorus + +-------------------------------------------------------------------------------- + +-- | Render a solid teapot. + +solidTeapot + :: Height -- ^ Relative size of the teapot + -> IO () +solidTeapot = glutSolidTeapot + +-- | Render a wireframe teapot. + +wireTeapot + :: Height -- ^ Relative size of the teapot + -> IO () +wireTeapot = glutWireTeapot + +-------------------------------------------------------------------------------- + +solidSierpinskiSponge :: NumLevels -> IO () +solidSierpinskiSponge = sierpinskiSponge glutSolidSierpinskiSponge + +wireSierpinskiSponge :: NumLevels -> IO () +wireSierpinskiSponge = sierpinskiSponge glutWireSierpinskiSponge + +-- for consistency, we hide the offset and scale on the Haskell side +sierpinskiSponge :: (CInt -> Ptr GLdouble -> Height -> IO ()) -> NumLevels -> IO () +sierpinskiSponge f n = + with (Vertex3 0 0 0) $ \offsetBuf -> + f (fromIntegral n) ((castPtr :: Ptr (Vertex3 GLdouble) -> Ptr GLdouble) offsetBuf) 1 diff --git a/Graphics/UI/GLUT/Overlay.hs b/Graphics/UI/GLUT/Overlay.hs --- a/Graphics/UI/GLUT/Overlay.hs +++ b/Graphics/UI/GLUT/Overlay.hs @@ -1,168 +1,168 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Overlay --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- When overlay hardware is available, GLUT provides a set of routines for --- establishing, using, and removing an overlay for GLUT windows. When an --- overlay is established, a separate OpenGL context is also established. A --- window\'s overlay OpenGL state is kept distinct from the normal planes\' --- OpenGL state. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Overlay ( - -- * Overlay creation and destruction - hasOverlay, overlayPossible, - - -- * Showing and hiding an overlay - overlayVisible, - - -- * Changing the /layer in use/ - Layer(..), layerInUse, - - -- * Re-displaying - postOverlayRedisplay -) where - -import Graphics.Rendering.OpenGL ( GLenum, StateVar, makeStateVar - , GettableStateVar, makeGettableStateVar - , SettableStateVar, makeSettableStateVar ) -import Graphics.UI.GLUT.QueryUtils -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.Types - --------------------------------------------------------------------------------- - --- | Controls the overlay for the /current window/. The requested display mode --- for the overlay is determined by the /initial display mode/. --- 'overlayPossible' can be used to determine if an overlay is possible for the --- /current window/ with the current /initial display mode/. Do not attempt to --- establish an overlay when one is not possible; GLUT will terminate the --- program. --- --- When 'hasOverlay' is set to 'True' when an overlay already exists, the --- existing overlay is first removed, and then a new overlay is established. The --- state of the old overlay\'s OpenGL context is discarded. Implicitly, the --- window\'s /layer in use/ changes to the overlay immediately after the overlay --- is established. --- --- The initial display state of an overlay is shown, however the overlay is only --- actually shown if the overlay\'s window is shown. --- --- Setting 'hasOverlay' to 'False' is safe even if no overlay is currently --- established, nothing happens in this case. Implicitly, the window\'s /layer --- in use/ changes to the normal plane immediately once the overlay is removed. --- --- If the program intends to re-establish the overlay later, it is typically --- faster and less resource intensive to use 'overlayVisible' to simply change --- the display status of the overlay. --- --- /X Implementation Notes:/ GLUT for X uses the @SERVER_OVERLAY_VISUALS@ --- convention to determine if overlay visuals are available. While the --- convention allows for opaque overlays (no transparency) and overlays with the --- transparency specified as a bitmask, GLUT overlay management only provides --- access to transparent pixel overlays. --- --- Until RGBA overlays are better understood, GLUT only supports color index --- overlays. - -hasOverlay :: StateVar Bool -hasOverlay = makeStateVar getHasOverlay setHasOverlay - -setHasOverlay :: Bool -> IO () -setHasOverlay False = glutRemoveOverlay -setHasOverlay True = glutEstablishOverlay - -getHasOverlay :: IO Bool -getHasOverlay = layerGet (/= 0) glut_HAS_OVERLAY - --------------------------------------------------------------------------------- - --- | Contains 'True' if an overlay could be established for the /current window/ --- given the current /initial display mode/. If it contains 'False', setting --- 'hasOverlay' will fail with a fatal error. - -overlayPossible :: GettableStateVar Bool -overlayPossible = makeGettableStateVar $ layerGet (/= 0) glut_OVERLAY_POSSIBLE - --------------------------------------------------------------------------------- - --- | Controls the visibility of the overlay of the /current window/. --- --- The effect of showing or hiding an overlay takes place immediately. Note that --- setting 'overlayVisible' to 'True' will not actually display the overlay --- unless the window is also shown (and even a shown window may be obscured by --- other windows, thereby obscuring the overlay). It is typically faster and --- less resource intensive to use the routines below to control the display --- status of an overlay as opposed to removing and re-establishing the overlay. - -overlayVisible :: SettableStateVar Bool -overlayVisible = - makeSettableStateVar $ \flag -> - if flag then glutShowOverlay else glutHideOverlay - --------------------------------------------------------------------------------- - --- | The /layer in use/. -data Layer - = Normal -- ^ The normal plane. - | Overlay -- ^ The overlay. - deriving ( Eq, Ord, Show ) - -marshalLayer :: Layer -> GLenum -marshalLayer x = case x of - Normal -> glut_NORMAL - Overlay -> glut_OVERLAY - -unmarshalLayer :: GLenum -> Layer -unmarshalLayer x - | x == glut_NORMAL = Normal - | x == glut_OVERLAY = Overlay - | otherwise = error ("unmarshalLayer: illegal value " ++ show x) - --------------------------------------------------------------------------------- - --- | Controls the per-window /layer in use/ for the /current window/, which can --- either be the normal plane or the overlay. Selecting the overlay should only --- be done if an overlay exists, however windows without an overlay may still --- set the /layer in use/ to 'Normal'. OpenGL commands for the window are --- directed to the current /layer in use/. - -layerInUse :: StateVar Layer -layerInUse = - makeStateVar getLayerInUse setLayerInUse - -setLayerInUse :: Layer -> IO () -setLayerInUse = glutUseLayer . marshalLayer - -getLayerInUse :: IO Layer -getLayerInUse = layerGet (unmarshalLayer . fromIntegral) glut_LAYER_IN_USE - --------------------------------------------------------------------------------- - --- | Mark the overlay of the given window (or the /current window/, if none is --- supplied) as needing to be redisplayed. The next iteration through --- 'Graphics.UI.GLUT.Begin.mainLoop', the window\'s overlay display callback --- (or simply the display callback if no overlay display callback is registered) --- will be called to redisplay the window\'s overlay plane. Multiple calls to --- 'postOverlayRedisplay' before the next display callback opportunity (or --- overlay display callback opportunity if one is registered) generate only a --- single redisplay. 'postOverlayRedisplay' may be called within a window\'s --- display or overlay display callback to re-mark that window for redisplay. --- --- Logically, overlay damage notification for a window is treated as a --- 'postOverlayRedisplay' on the damaged window. Unlike damage reported by the --- window system, 'postOverlayRedisplay' will not set to true the overlay\'s --- damaged status (see 'Graphics.UI.GLUT.State.damaged'). --- --- Also, see 'Graphics.UI.GLUT.Window.postRedisplay'. - -postOverlayRedisplay :: Maybe Window -> IO () -postOverlayRedisplay = - maybe glutPostOverlayRedisplay (\(Window win) -> glutPostWindowOverlayRedisplay win) +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Overlay +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- When overlay hardware is available, GLUT provides a set of routines for +-- establishing, using, and removing an overlay for GLUT windows. When an +-- overlay is established, a separate OpenGL context is also established. A +-- window\'s overlay OpenGL state is kept distinct from the normal planes\' +-- OpenGL state. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Overlay ( + -- * Overlay creation and destruction + hasOverlay, overlayPossible, + + -- * Showing and hiding an overlay + overlayVisible, + + -- * Changing the /layer in use/ + Layer(..), layerInUse, + + -- * Re-displaying + postOverlayRedisplay +) where + +import Graphics.Rendering.OpenGL ( GLenum, StateVar, makeStateVar + , GettableStateVar, makeGettableStateVar + , SettableStateVar, makeSettableStateVar ) +import Graphics.UI.GLUT.QueryUtils +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.Types + +-------------------------------------------------------------------------------- + +-- | Controls the overlay for the /current window/. The requested display mode +-- for the overlay is determined by the /initial display mode/. +-- 'overlayPossible' can be used to determine if an overlay is possible for the +-- /current window/ with the current /initial display mode/. Do not attempt to +-- establish an overlay when one is not possible; GLUT will terminate the +-- program. +-- +-- When 'hasOverlay' is set to 'True' when an overlay already exists, the +-- existing overlay is first removed, and then a new overlay is established. The +-- state of the old overlay\'s OpenGL context is discarded. Implicitly, the +-- window\'s /layer in use/ changes to the overlay immediately after the overlay +-- is established. +-- +-- The initial display state of an overlay is shown, however the overlay is only +-- actually shown if the overlay\'s window is shown. +-- +-- Setting 'hasOverlay' to 'False' is safe even if no overlay is currently +-- established, nothing happens in this case. Implicitly, the window\'s /layer +-- in use/ changes to the normal plane immediately once the overlay is removed. +-- +-- If the program intends to re-establish the overlay later, it is typically +-- faster and less resource intensive to use 'overlayVisible' to simply change +-- the display status of the overlay. +-- +-- /X Implementation Notes:/ GLUT for X uses the @SERVER_OVERLAY_VISUALS@ +-- convention to determine if overlay visuals are available. While the +-- convention allows for opaque overlays (no transparency) and overlays with the +-- transparency specified as a bitmask, GLUT overlay management only provides +-- access to transparent pixel overlays. +-- +-- Until RGBA overlays are better understood, GLUT only supports color index +-- overlays. + +hasOverlay :: StateVar Bool +hasOverlay = makeStateVar getHasOverlay setHasOverlay + +setHasOverlay :: Bool -> IO () +setHasOverlay False = glutRemoveOverlay +setHasOverlay True = glutEstablishOverlay + +getHasOverlay :: IO Bool +getHasOverlay = layerGet (/= 0) glut_HAS_OVERLAY + +-------------------------------------------------------------------------------- + +-- | Contains 'True' if an overlay could be established for the /current window/ +-- given the current /initial display mode/. If it contains 'False', setting +-- 'hasOverlay' will fail with a fatal error. + +overlayPossible :: GettableStateVar Bool +overlayPossible = makeGettableStateVar $ layerGet (/= 0) glut_OVERLAY_POSSIBLE + +-------------------------------------------------------------------------------- + +-- | Controls the visibility of the overlay of the /current window/. +-- +-- The effect of showing or hiding an overlay takes place immediately. Note that +-- setting 'overlayVisible' to 'True' will not actually display the overlay +-- unless the window is also shown (and even a shown window may be obscured by +-- other windows, thereby obscuring the overlay). It is typically faster and +-- less resource intensive to use the routines below to control the display +-- status of an overlay as opposed to removing and re-establishing the overlay. + +overlayVisible :: SettableStateVar Bool +overlayVisible = + makeSettableStateVar $ \flag -> + if flag then glutShowOverlay else glutHideOverlay + +-------------------------------------------------------------------------------- + +-- | The /layer in use/. +data Layer + = Normal -- ^ The normal plane. + | Overlay -- ^ The overlay. + deriving ( Eq, Ord, Show ) + +marshalLayer :: Layer -> GLenum +marshalLayer x = case x of + Normal -> glut_NORMAL + Overlay -> glut_OVERLAY + +unmarshalLayer :: GLenum -> Layer +unmarshalLayer x + | x == glut_NORMAL = Normal + | x == glut_OVERLAY = Overlay + | otherwise = error ("unmarshalLayer: illegal value " ++ show x) + +-------------------------------------------------------------------------------- + +-- | Controls the per-window /layer in use/ for the /current window/, which can +-- either be the normal plane or the overlay. Selecting the overlay should only +-- be done if an overlay exists, however windows without an overlay may still +-- set the /layer in use/ to 'Normal'. OpenGL commands for the window are +-- directed to the current /layer in use/. + +layerInUse :: StateVar Layer +layerInUse = + makeStateVar getLayerInUse setLayerInUse + +setLayerInUse :: Layer -> IO () +setLayerInUse = glutUseLayer . marshalLayer + +getLayerInUse :: IO Layer +getLayerInUse = layerGet (unmarshalLayer . fromIntegral) glut_LAYER_IN_USE + +-------------------------------------------------------------------------------- + +-- | Mark the overlay of the given window (or the /current window/, if none is +-- supplied) as needing to be redisplayed. The next iteration through +-- 'Graphics.UI.GLUT.Begin.mainLoop', the window\'s overlay display callback +-- (or simply the display callback if no overlay display callback is registered) +-- will be called to redisplay the window\'s overlay plane. Multiple calls to +-- 'postOverlayRedisplay' before the next display callback opportunity (or +-- overlay display callback opportunity if one is registered) generate only a +-- single redisplay. 'postOverlayRedisplay' may be called within a window\'s +-- display or overlay display callback to re-mark that window for redisplay. +-- +-- Logically, overlay damage notification for a window is treated as a +-- 'postOverlayRedisplay' on the damaged window. Unlike damage reported by the +-- window system, 'postOverlayRedisplay' will not set to true the overlay\'s +-- damaged status (see 'Graphics.UI.GLUT.State.damaged'). +-- +-- Also, see 'Graphics.UI.GLUT.Window.postRedisplay'. + +postOverlayRedisplay :: Maybe Window -> IO () +postOverlayRedisplay = + maybe glutPostOverlayRedisplay (\(Window win) -> glutPostWindowOverlayRedisplay win) diff --git a/Graphics/UI/GLUT/QueryUtils.hs b/Graphics/UI/GLUT/QueryUtils.hs --- a/Graphics/UI/GLUT/QueryUtils.hs +++ b/Graphics/UI/GLUT/QueryUtils.hs @@ -1,35 +1,35 @@ -{-# OPTIONS_HADDOCK hide #-} --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.QueryUtils --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- This is a purely internal module with utilities to query GLUT state. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.QueryUtils ( - Getter, simpleGet, layerGet, deviceGet -) where - -import Foreign.C.Types -import Graphics.Rendering.OpenGL ( GLenum ) -import Graphics.UI.GLUT.Raw - --------------------------------------------------------------------------------- - -type PrimGetter = GLenum -> IO CInt -type Getter a = (CInt -> a) -> GLenum -> IO a - -makeGetter :: PrimGetter -> Getter a -makeGetter g f = fmap f . g - -simpleGet, layerGet, deviceGet :: Getter a -simpleGet = makeGetter glutGet -layerGet = makeGetter glutLayerGet -deviceGet = makeGetter glutDeviceGet +{-# OPTIONS_HADDOCK hide #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.QueryUtils +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- This is a purely internal module with utilities to query GLUT state. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.QueryUtils ( + Getter, simpleGet, layerGet, deviceGet +) where + +import Foreign.C.Types +import Graphics.Rendering.OpenGL ( GLenum ) +import Graphics.UI.GLUT.Raw + +-------------------------------------------------------------------------------- + +type PrimGetter = GLenum -> IO CInt +type Getter a = (CInt -> a) -> GLenum -> IO a + +makeGetter :: PrimGetter -> Getter a +makeGetter g f = fmap f . g + +simpleGet, layerGet, deviceGet :: Getter a +simpleGet = makeGetter glutGet +layerGet = makeGetter glutLayerGet +deviceGet = makeGetter glutDeviceGet diff --git a/Graphics/UI/GLUT/Raw.hs b/Graphics/UI/GLUT/Raw.hs --- a/Graphics/UI/GLUT/Raw.hs +++ b/Graphics/UI/GLUT/Raw.hs @@ -1,28 +1,28 @@ -{-# OPTIONS_HADDOCK hide #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.UI.GLUT.Raw --- Copyright : (c) Sven Panne 2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- A convenience module, combining all raw GLUT modules. --- ------------------------------------------------------------------------------ - -module Graphics.UI.GLUT.Raw ( - module Graphics.UI.GLUT.Raw.APIEntry, - module Graphics.UI.GLUT.Raw.Callbacks, - module Graphics.UI.GLUT.Raw.Fonts, - module Graphics.UI.GLUT.Raw.Functions, - module Graphics.UI.GLUT.Raw.Tokens -) where - -import Graphics.UI.GLUT.Raw.APIEntry -import Graphics.UI.GLUT.Raw.Callbacks -import Graphics.UI.GLUT.Raw.Fonts -import Graphics.UI.GLUT.Raw.Functions -import Graphics.UI.GLUT.Raw.Tokens +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Raw +-- Copyright : (c) Sven Panne 2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- A convenience module, combining all raw GLUT modules. +-- +----------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Raw ( + module Graphics.UI.GLUT.Raw.APIEntry, + module Graphics.UI.GLUT.Raw.Callbacks, + module Graphics.UI.GLUT.Raw.Fonts, + module Graphics.UI.GLUT.Raw.Functions, + module Graphics.UI.GLUT.Raw.Tokens +) where + +import Graphics.UI.GLUT.Raw.APIEntry +import Graphics.UI.GLUT.Raw.Callbacks +import Graphics.UI.GLUT.Raw.Fonts +import Graphics.UI.GLUT.Raw.Functions +import Graphics.UI.GLUT.Raw.Tokens diff --git a/Graphics/UI/GLUT/Raw/APIEntry.hs b/Graphics/UI/GLUT/Raw/APIEntry.hs --- a/Graphics/UI/GLUT/Raw/APIEntry.hs +++ b/Graphics/UI/GLUT/Raw/APIEntry.hs @@ -1,51 +1,51 @@ -{-# LANGUAGE ForeignFunctionInterface, CPP #-} -{-# OPTIONS_HADDOCK hide #-} --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Raw.APIEntry --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- This is a purely internal module for handling an OpenGL-like extension --- mechanism for GLUT. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Raw.APIEntry ( - Invoker, getAPIEntry, getAPIEntryInternal, - FunPtr, unsafePerformIO -) where - -import Foreign.C.String -import Foreign.Marshal.Error -import Foreign.Ptr -import System.IO.Unsafe - -#ifdef __HUGS__ -{-# CFILES cbits/HsGLUT.c #-} -#endif - --------------------------------------------------------------------------------- - -type Invoker a = FunPtr a -> a - --- | Retrieve a GLUT API entry by name. Throws a userError when no entry with --- the given name was found. -getAPIEntry :: String -> IO (FunPtr a) -getAPIEntry extensionEntry = - throwIfNullFunPtr ("unknown GLUT entry " ++ extensionEntry) $ - getAPIEntryInternal extensionEntry - -throwIfNullFunPtr :: String -> IO (FunPtr a) -> IO (FunPtr a) -throwIfNullFunPtr = throwIf (== nullFunPtr) . const - -getAPIEntryInternal :: String -> IO (FunPtr a) -getAPIEntryInternal extensionEntry = - withCString extensionEntry hs_GLUT_getProcAddress - -foreign import ccall unsafe "hs_GLUT_getProcAddress" - hs_GLUT_getProcAddress :: CString -> IO (FunPtr a) +{-# LANGUAGE ForeignFunctionInterface, CPP #-} +{-# OPTIONS_HADDOCK hide #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Raw.APIEntry +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- This is a purely internal module for handling an OpenGL-like extension +-- mechanism for GLUT. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Raw.APIEntry ( + Invoker, getAPIEntry, getAPIEntryInternal, + FunPtr, unsafePerformIO +) where + +import Foreign.C.String +import Foreign.Marshal.Error +import Foreign.Ptr +import System.IO.Unsafe + +#ifdef __HUGS__ +{-# CFILES cbits/HsGLUT.c #-} +#endif + +-------------------------------------------------------------------------------- + +type Invoker a = FunPtr a -> a + +-- | Retrieve a GLUT API entry by name. Throws a userError when no entry with +-- the given name was found. +getAPIEntry :: String -> IO (FunPtr a) +getAPIEntry extensionEntry = + throwIfNullFunPtr ("unknown GLUT entry " ++ extensionEntry) $ + getAPIEntryInternal extensionEntry + +throwIfNullFunPtr :: String -> IO (FunPtr a) -> IO (FunPtr a) +throwIfNullFunPtr = throwIf (== nullFunPtr) . const + +getAPIEntryInternal :: String -> IO (FunPtr a) +getAPIEntryInternal extensionEntry = + withCString extensionEntry hs_GLUT_getProcAddress + +foreign import ccall unsafe "hs_GLUT_getProcAddress" + hs_GLUT_getProcAddress :: CString -> IO (FunPtr a) diff --git a/Graphics/UI/GLUT/Raw/Callbacks.hs b/Graphics/UI/GLUT/Raw/Callbacks.hs --- a/Graphics/UI/GLUT/Raw/Callbacks.hs +++ b/Graphics/UI/GLUT/Raw/Callbacks.hs @@ -1,201 +1,201 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# OPTIONS_HADDOCK hide #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.UI.GLUT.Raw.Callbacks --- Copyright : (c) Sven Panne 2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- All GLUT callbacks. --- ------------------------------------------------------------------------------ - -module Graphics.UI.GLUT.Raw.Callbacks ( - MenuFunc, makeMenuFunc, - ButtonBoxFunc, makeButtonBoxFunc, - CloseFunc, makeCloseFunc, - DialsFunc, makeDialsFunc, - DisplayFunc, makeDisplayFunc, - EntryFunc, makeEntryFunc, - IdleFunc, makeIdleFunc, - JoystickFunc, makeJoystickFunc, - KeyboardFunc, makeKeyboardFunc, - KeyboardUpFunc, makeKeyboardUpFunc, - MenuDestroyFunc, makeMenuDestroyFunc, - MenuStateFunc, makeMenuStateFunc, - MenuStatusFunc, makeMenuStatusFunc, - MotionFunc, makeMotionFunc, - MouseFunc, makeMouseFunc, - MouseWheelFunc, makeMouseWheelFunc, - OverlayDisplayFunc, makeOverlayDisplayFunc, - PassiveMotionFunc, makePassiveMotionFunc, - ReshapeFunc, makeReshapeFunc, - SpaceballButtonFunc, makeSpaceballButtonFunc, - SpaceballMotionFunc, makeSpaceballMotionFunc, - SpaceballRotateFunc, makeSpaceballRotateFunc, - SpecialFunc, makeSpecialFunc, - SpecialUpFunc, makeSpecialUpFunc, - TabletButtonFunc, makeTabletButtonFunc, - TabletMotionFunc, makeTabletMotionFunc, - TimerFunc, makeTimerFunc, - VisibilityFunc, makeVisibilityFunc, - WMCloseFunc, makeWMCloseFunc, - WindowStatusFunc, makeWindowStatusFunc -) where - -import Foreign.C.Types -import Foreign.Ptr - -type MenuFunc = CInt -> IO () - -foreign import ccall "wrapper" - makeMenuFunc :: MenuFunc -> IO (FunPtr MenuFunc) - -type ButtonBoxFunc = CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeButtonBoxFunc :: ButtonBoxFunc -> IO (FunPtr ButtonBoxFunc) - -type CloseFunc = IO () - -foreign import ccall "wrapper" - makeCloseFunc :: CloseFunc -> IO (FunPtr CloseFunc) - -type DialsFunc = CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeDialsFunc :: DialsFunc -> IO (FunPtr DialsFunc) - -type DisplayFunc = IO () - -foreign import ccall "wrapper" - makeDisplayFunc :: DisplayFunc -> IO (FunPtr DisplayFunc) - -type EntryFunc = CInt -> IO () - -foreign import ccall "wrapper" - makeEntryFunc :: EntryFunc -> IO (FunPtr EntryFunc) - -type IdleFunc = IO () - -foreign import ccall "wrapper" - makeIdleFunc :: IdleFunc -> IO (FunPtr IdleFunc) - -type JoystickFunc = CUInt -> CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeJoystickFunc :: JoystickFunc -> IO (FunPtr JoystickFunc) - -type KeyboardFunc = CUChar -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeKeyboardFunc :: KeyboardFunc -> IO (FunPtr KeyboardFunc) - -type KeyboardUpFunc = CUChar -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeKeyboardUpFunc :: KeyboardUpFunc -> IO (FunPtr KeyboardUpFunc) - -type MenuDestroyFunc = IO () - -foreign import ccall "wrapper" - makeMenuDestroyFunc :: MenuDestroyFunc -> IO (FunPtr MenuDestroyFunc) - -type MenuStateFunc = CInt -> IO () - -foreign import ccall "wrapper" - makeMenuStateFunc :: MenuStateFunc -> IO (FunPtr MenuStateFunc) - -type MenuStatusFunc = CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeMenuStatusFunc :: MenuStatusFunc -> IO (FunPtr MenuStatusFunc) - -type MotionFunc = CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeMotionFunc :: MotionFunc -> IO (FunPtr MotionFunc) - -type MouseFunc = CInt -> CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeMouseFunc :: MouseFunc -> IO (FunPtr MouseFunc) - -type MouseWheelFunc = CInt -> CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeMouseWheelFunc :: MouseWheelFunc -> IO (FunPtr MouseWheelFunc) - -type OverlayDisplayFunc = IO () - -foreign import ccall "wrapper" - makeOverlayDisplayFunc :: OverlayDisplayFunc -> IO (FunPtr OverlayDisplayFunc) - -type PassiveMotionFunc = CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makePassiveMotionFunc :: PassiveMotionFunc -> IO (FunPtr PassiveMotionFunc) - -type ReshapeFunc = CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeReshapeFunc :: ReshapeFunc -> IO (FunPtr ReshapeFunc) - -type SpaceballButtonFunc = CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeSpaceballButtonFunc :: SpaceballButtonFunc -> IO (FunPtr SpaceballButtonFunc) - -type SpaceballMotionFunc = CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeSpaceballMotionFunc :: SpaceballMotionFunc -> IO (FunPtr SpaceballMotionFunc) - -type SpaceballRotateFunc = CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeSpaceballRotateFunc :: SpaceballRotateFunc -> IO (FunPtr SpaceballRotateFunc) - -type SpecialFunc = CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeSpecialFunc :: SpecialFunc -> IO (FunPtr SpecialFunc) - -type SpecialUpFunc = CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeSpecialUpFunc :: SpecialUpFunc -> IO (FunPtr SpecialUpFunc) - -type TabletButtonFunc = CInt -> CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeTabletButtonFunc :: TabletButtonFunc -> IO (FunPtr TabletButtonFunc) - -type TabletMotionFunc = CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeTabletMotionFunc :: TabletMotionFunc -> IO (FunPtr TabletMotionFunc) - -type TimerFunc = CInt -> IO () - -foreign import ccall "wrapper" - makeTimerFunc :: TimerFunc -> IO (FunPtr TimerFunc) - -type VisibilityFunc = CInt -> IO () - -foreign import ccall "wrapper" - makeVisibilityFunc :: VisibilityFunc -> IO (FunPtr VisibilityFunc) - -type WMCloseFunc = IO () - -foreign import ccall "wrapper" - makeWMCloseFunc :: WMCloseFunc -> IO (FunPtr WMCloseFunc) - -type WindowStatusFunc = CInt -> IO () - -foreign import ccall "wrapper" - makeWindowStatusFunc :: WindowStatusFunc -> IO (FunPtr WindowStatusFunc) +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Raw.Callbacks +-- Copyright : (c) Sven Panne 2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- All GLUT callbacks. +-- +----------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Raw.Callbacks ( + MenuFunc, makeMenuFunc, + ButtonBoxFunc, makeButtonBoxFunc, + CloseFunc, makeCloseFunc, + DialsFunc, makeDialsFunc, + DisplayFunc, makeDisplayFunc, + EntryFunc, makeEntryFunc, + IdleFunc, makeIdleFunc, + JoystickFunc, makeJoystickFunc, + KeyboardFunc, makeKeyboardFunc, + KeyboardUpFunc, makeKeyboardUpFunc, + MenuDestroyFunc, makeMenuDestroyFunc, + MenuStateFunc, makeMenuStateFunc, + MenuStatusFunc, makeMenuStatusFunc, + MotionFunc, makeMotionFunc, + MouseFunc, makeMouseFunc, + MouseWheelFunc, makeMouseWheelFunc, + OverlayDisplayFunc, makeOverlayDisplayFunc, + PassiveMotionFunc, makePassiveMotionFunc, + ReshapeFunc, makeReshapeFunc, + SpaceballButtonFunc, makeSpaceballButtonFunc, + SpaceballMotionFunc, makeSpaceballMotionFunc, + SpaceballRotateFunc, makeSpaceballRotateFunc, + SpecialFunc, makeSpecialFunc, + SpecialUpFunc, makeSpecialUpFunc, + TabletButtonFunc, makeTabletButtonFunc, + TabletMotionFunc, makeTabletMotionFunc, + TimerFunc, makeTimerFunc, + VisibilityFunc, makeVisibilityFunc, + WMCloseFunc, makeWMCloseFunc, + WindowStatusFunc, makeWindowStatusFunc +) where + +import Foreign.C.Types +import Foreign.Ptr + +type MenuFunc = CInt -> IO () + +foreign import ccall "wrapper" + makeMenuFunc :: MenuFunc -> IO (FunPtr MenuFunc) + +type ButtonBoxFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeButtonBoxFunc :: ButtonBoxFunc -> IO (FunPtr ButtonBoxFunc) + +type CloseFunc = IO () + +foreign import ccall "wrapper" + makeCloseFunc :: CloseFunc -> IO (FunPtr CloseFunc) + +type DialsFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeDialsFunc :: DialsFunc -> IO (FunPtr DialsFunc) + +type DisplayFunc = IO () + +foreign import ccall "wrapper" + makeDisplayFunc :: DisplayFunc -> IO (FunPtr DisplayFunc) + +type EntryFunc = CInt -> IO () + +foreign import ccall "wrapper" + makeEntryFunc :: EntryFunc -> IO (FunPtr EntryFunc) + +type IdleFunc = IO () + +foreign import ccall "wrapper" + makeIdleFunc :: IdleFunc -> IO (FunPtr IdleFunc) + +type JoystickFunc = CUInt -> CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeJoystickFunc :: JoystickFunc -> IO (FunPtr JoystickFunc) + +type KeyboardFunc = CUChar -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeKeyboardFunc :: KeyboardFunc -> IO (FunPtr KeyboardFunc) + +type KeyboardUpFunc = CUChar -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeKeyboardUpFunc :: KeyboardUpFunc -> IO (FunPtr KeyboardUpFunc) + +type MenuDestroyFunc = IO () + +foreign import ccall "wrapper" + makeMenuDestroyFunc :: MenuDestroyFunc -> IO (FunPtr MenuDestroyFunc) + +type MenuStateFunc = CInt -> IO () + +foreign import ccall "wrapper" + makeMenuStateFunc :: MenuStateFunc -> IO (FunPtr MenuStateFunc) + +type MenuStatusFunc = CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeMenuStatusFunc :: MenuStatusFunc -> IO (FunPtr MenuStatusFunc) + +type MotionFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeMotionFunc :: MotionFunc -> IO (FunPtr MotionFunc) + +type MouseFunc = CInt -> CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeMouseFunc :: MouseFunc -> IO (FunPtr MouseFunc) + +type MouseWheelFunc = CInt -> CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeMouseWheelFunc :: MouseWheelFunc -> IO (FunPtr MouseWheelFunc) + +type OverlayDisplayFunc = IO () + +foreign import ccall "wrapper" + makeOverlayDisplayFunc :: OverlayDisplayFunc -> IO (FunPtr OverlayDisplayFunc) + +type PassiveMotionFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makePassiveMotionFunc :: PassiveMotionFunc -> IO (FunPtr PassiveMotionFunc) + +type ReshapeFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeReshapeFunc :: ReshapeFunc -> IO (FunPtr ReshapeFunc) + +type SpaceballButtonFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeSpaceballButtonFunc :: SpaceballButtonFunc -> IO (FunPtr SpaceballButtonFunc) + +type SpaceballMotionFunc = CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeSpaceballMotionFunc :: SpaceballMotionFunc -> IO (FunPtr SpaceballMotionFunc) + +type SpaceballRotateFunc = CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeSpaceballRotateFunc :: SpaceballRotateFunc -> IO (FunPtr SpaceballRotateFunc) + +type SpecialFunc = CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeSpecialFunc :: SpecialFunc -> IO (FunPtr SpecialFunc) + +type SpecialUpFunc = CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeSpecialUpFunc :: SpecialUpFunc -> IO (FunPtr SpecialUpFunc) + +type TabletButtonFunc = CInt -> CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeTabletButtonFunc :: TabletButtonFunc -> IO (FunPtr TabletButtonFunc) + +type TabletMotionFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeTabletMotionFunc :: TabletMotionFunc -> IO (FunPtr TabletMotionFunc) + +type TimerFunc = CInt -> IO () + +foreign import ccall "wrapper" + makeTimerFunc :: TimerFunc -> IO (FunPtr TimerFunc) + +type VisibilityFunc = CInt -> IO () + +foreign import ccall "wrapper" + makeVisibilityFunc :: VisibilityFunc -> IO (FunPtr VisibilityFunc) + +type WMCloseFunc = IO () + +foreign import ccall "wrapper" + makeWMCloseFunc :: WMCloseFunc -> IO (FunPtr WMCloseFunc) + +type WindowStatusFunc = CInt -> IO () + +foreign import ccall "wrapper" + makeWindowStatusFunc :: WindowStatusFunc -> IO (FunPtr WindowStatusFunc) diff --git a/Graphics/UI/GLUT/Raw/Fonts.hs b/Graphics/UI/GLUT/Raw/Fonts.hs --- a/Graphics/UI/GLUT/Raw/Fonts.hs +++ b/Graphics/UI/GLUT/Raw/Fonts.hs @@ -1,29 +1,29 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# OPTIONS_HADDOCK hide #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.UI.GLUT.Raw.Fonts --- Copyright : (c) Sven Panne 2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- Our own functions to access font identifiers in a portable way. --- ------------------------------------------------------------------------------ - -module Graphics.UI.GLUT.Raw.Fonts ( - hs_GLUT_marshalBitmapFont, - hs_GLUT_marshalStrokeFont -) where - -import Foreign.C.Types -import Foreign.Ptr - -foreign import ccall unsafe "hs_GLUT_marshalBitmapFont" - hs_GLUT_marshalBitmapFont :: CInt -> IO (Ptr a) - -foreign import ccall unsafe "hs_GLUT_marshalStrokeFont" - hs_GLUT_marshalStrokeFont :: CInt -> IO (Ptr a) +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Raw.Fonts +-- Copyright : (c) Sven Panne 2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- Our own functions to access font identifiers in a portable way. +-- +----------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Raw.Fonts ( + hs_GLUT_marshalBitmapFont, + hs_GLUT_marshalStrokeFont +) where + +import Foreign.C.Types +import Foreign.Ptr + +foreign import ccall unsafe "hs_GLUT_marshalBitmapFont" + hs_GLUT_marshalBitmapFont :: CInt -> IO (Ptr a) + +foreign import ccall unsafe "hs_GLUT_marshalStrokeFont" + hs_GLUT_marshalStrokeFont :: CInt -> IO (Ptr a) diff --git a/Graphics/UI/GLUT/Raw/Functions.hs b/Graphics/UI/GLUT/Raw/Functions.hs --- a/Graphics/UI/GLUT/Raw/Functions.hs +++ b/Graphics/UI/GLUT/Raw/Functions.hs @@ -1,311 +1,311 @@ -{-# LANGUAGE ForeignFunctionInterface, CPP #-} -{-# OPTIONS_HADDOCK hide #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.UI.GLUT.Raw.Functions --- Copyright : (c) Sven Panne 2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- All raw functions from GLUT and freeglut. --- ------------------------------------------------------------------------------ - -module Graphics.UI.GLUT.Raw.Functions ( - glutGetProcAddress, - glutGetColor, - glutStrokeHeight, - glutBitmapHeight, - glutBitmapLength, - glutBitmapWidth, - glutCreateMenu, - glutCreateSubWindow, - glutCreateWindow, - glutDeviceGet, - glutEnterGameMode, - glutExtensionSupported, - glutGameModeGet, - glutGet, - glutGetMenu, - glutGetModifiers, - glutGetWindow, - glutLayerGet, - glutStrokeLength, - glutStrokeWidth, - glutVideoResizeGet, - glutGetModeValues, - glutAddMenuEntry, - glutAddSubMenu, - glutAttachMenu, - glutBitmapCharacter, - glutBitmapString, - glutButtonBoxFunc, - glutChangeToMenuEntry, - glutChangeToSubMenu, - glutCloseFunc, - glutCopyColormap, - glutDestroyMenu, - glutDestroyWindow, - glutDetachMenu, - glutDialsFunc, - glutDisplayFunc, - glutEntryFunc, - glutEstablishOverlay, - glutExit, - glutForceJoystickFunc, - glutFullScreen, - glutFullScreenToggle, - glutGameModeString, - glutHideOverlay, - glutHideWindow, - glutIconifyWindow, - glutIdleFunc, - glutIgnoreKeyRepeat, - glutInit, - glutInitContextFlags, - glutInitContextVersion, - glutInitContextProfile, - glutInitDisplayMode, - glutInitDisplayString, - glutInitWindowPosition, - glutInitWindowSize, - glutJoystickFunc, - glutKeyboardFunc, - glutKeyboardUpFunc, - glutLeaveGameMode, - glutLeaveMainLoop, - glutMainLoop, - glutMainLoopEvent, - glutMenuDestroyFunc, - glutMenuStateFunc, - glutMenuStatusFunc, - glutMotionFunc, - glutMouseFunc, - glutMouseWheelFunc, - glutOverlayDisplayFunc, - glutPassiveMotionFunc, - glutPopWindow, - glutPositionWindow, - glutPostOverlayRedisplay, - glutPostRedisplay, - glutPostWindowOverlayRedisplay, - glutPostWindowRedisplay, - glutPushWindow, - glutRemoveMenuItem, - glutRemoveOverlay, - glutReportErrors, - glutReshapeFunc, - glutReshapeWindow, - glutSetColor, - glutSetCursor, - glutSetIconTitle, - glutSetKeyRepeat, - glutSetMenu, - glutSetMenuData, - glutSetOption, - glutSetWindow, - glutSetWindowData, - glutSetWindowTitle, - glutSetupVideoResizing, - glutShowOverlay, - glutShowWindow, - glutSolidCone, - glutSolidCube, - glutSolidCylinder, - glutSolidDodecahedron, - glutSolidIcosahedron, - glutSolidOctahedron, - glutSolidRhombicDodecahedron, - glutSolidSierpinskiSponge, - glutSolidSphere, - glutSolidTeapot, - glutSolidTetrahedron, - glutSolidTorus, - glutSpaceballButtonFunc, - glutSpaceballMotionFunc, - glutSpaceballRotateFunc, - glutSpecialFunc, - glutSpecialUpFunc, - glutStopVideoResizing, - glutStrokeCharacter, - glutStrokeString, - glutSwapBuffers, - glutTabletButtonFunc, - glutTabletMotionFunc, - glutTimerFunc, - glutUseLayer, - glutVideoPan, - glutVideoResize, - glutVisibilityFunc, - glutWMCloseFunc, - glutWarpPointer, - glutWindowStatusFunc, - glutWireCone, - glutWireCube, - glutWireCylinder, - glutWireDodecahedron, - glutWireIcosahedron, - glutWireOctahedron, - glutWireRhombicDodecahedron, - glutWireSierpinskiSponge, - glutWireSphere, - glutWireTeapot, - glutWireTetrahedron, - glutWireTorus, - glutGetMenuData, - glutGetWindowData -) where - -import Foreign.C.Types -import Foreign.Ptr -import Graphics.Rendering.OpenGL.Raw.Core31.Types -import Graphics.UI.GLUT.Raw.APIEntry -import Graphics.UI.GLUT.Raw.Callbacks - -#include "HsGLUTExt.h" - -API_ENTRY(glutGetProcAddress,Ptr CChar -> IO (FunPtr a)) -API_ENTRY(glutGetColor,CInt -> CInt -> IO GLfloat) -API_ENTRY(glutStrokeHeight,Ptr a -> IO GLfloat) -API_ENTRY(glutBitmapHeight,Ptr a -> IO CInt) -API_ENTRY(glutBitmapLength,Ptr a -> Ptr CUChar -> IO CInt) -API_ENTRY(glutBitmapWidth,Ptr a -> CInt -> IO CInt) -API_ENTRY(glutCreateMenu,FunPtr MenuFunc -> IO CInt) -API_ENTRY(glutCreateSubWindow,CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt) -API_ENTRY(glutCreateWindow,Ptr CChar -> IO CInt) -API_ENTRY(glutDeviceGet,GLenum -> IO CInt) -API_ENTRY(glutEnterGameMode,IO CInt) -API_ENTRY(glutExtensionSupported,Ptr CChar -> IO CInt) -API_ENTRY(glutGameModeGet,GLenum -> IO CInt) -API_ENTRY(glutGet,GLenum -> IO CInt) -API_ENTRY(glutGetMenu,IO CInt) -API_ENTRY(glutGetModifiers,IO CInt) -API_ENTRY(glutGetWindow,IO CInt) -API_ENTRY(glutLayerGet,GLenum -> IO CInt) -API_ENTRY(glutStrokeLength,Ptr a -> Ptr CUChar -> IO CInt) -API_ENTRY(glutStrokeWidth,Ptr a -> CInt -> IO CInt) -API_ENTRY(glutVideoResizeGet,GLenum -> IO CInt) -API_ENTRY(glutGetModeValues,GLenum -> Ptr CInt -> IO (Ptr CInt)) -API_ENTRY(glutAddMenuEntry,Ptr CChar -> CInt -> IO ()) -API_ENTRY(glutAddSubMenu,Ptr CChar -> CInt -> IO ()) -API_ENTRY(glutAttachMenu,CInt -> IO ()) -API_ENTRY(glutBitmapCharacter,Ptr a -> CInt -> IO ()) -API_ENTRY(glutBitmapString,Ptr a -> Ptr CUChar -> IO ()) -API_ENTRY(glutButtonBoxFunc,FunPtr ButtonBoxFunc -> IO ()) -API_ENTRY(glutChangeToMenuEntry,CInt -> Ptr CChar -> CInt -> IO ()) -API_ENTRY(glutChangeToSubMenu,CInt -> Ptr CChar -> CInt -> IO ()) -API_ENTRY(glutCloseFunc,FunPtr CloseFunc -> IO ()) -API_ENTRY(glutCopyColormap,CInt -> IO ()) -API_ENTRY(glutDestroyMenu,CInt -> IO ()) -API_ENTRY(glutDestroyWindow,CInt -> IO ()) -API_ENTRY(glutDetachMenu,CInt -> IO ()) -API_ENTRY(glutDialsFunc,FunPtr DialsFunc -> IO ()) -API_ENTRY(glutDisplayFunc,FunPtr DisplayFunc -> IO ()) -API_ENTRY(glutEntryFunc,FunPtr EntryFunc -> IO ()) -API_ENTRY_SAFE(glutEstablishOverlay,IO ()) -API_ENTRY(glutExit,IO ()) -API_ENTRY(glutForceJoystickFunc,IO ()) -API_ENTRY(glutFullScreen,IO ()) -API_ENTRY(glutFullScreenToggle,IO ()) -API_ENTRY(glutGameModeString,Ptr CChar -> IO ()) -API_ENTRY_SAFE(glutHideOverlay,IO ()) -API_ENTRY(glutHideWindow,IO ()) -API_ENTRY(glutIconifyWindow,IO ()) -API_ENTRY(glutIdleFunc,FunPtr IdleFunc -> IO ()) -API_ENTRY(glutIgnoreKeyRepeat,CInt -> IO ()) -API_ENTRY(glutInit,Ptr CInt -> Ptr (Ptr CChar) -> IO ()) -API_ENTRY(glutInitContextFlags,CInt -> IO ()) -API_ENTRY(glutInitContextVersion,CInt -> CInt -> IO ()) -API_ENTRY(glutInitContextProfile,CInt -> IO ()) -API_ENTRY(glutInitDisplayMode,CUInt -> IO ()) -API_ENTRY(glutInitDisplayString,Ptr CChar -> IO ()) -API_ENTRY(glutInitWindowPosition,CInt -> CInt -> IO ()) -API_ENTRY(glutInitWindowSize,CInt -> CInt -> IO ()) -API_ENTRY(glutJoystickFunc,FunPtr JoystickFunc -> CInt -> IO ()) -API_ENTRY(glutKeyboardFunc,FunPtr KeyboardFunc -> IO ()) -API_ENTRY(glutKeyboardUpFunc,FunPtr KeyboardUpFunc -> IO ()) -API_ENTRY(glutLeaveGameMode,IO ()) -API_ENTRY_SAFE(glutLeaveMainLoop,IO ()) -API_ENTRY_SAFE(glutMainLoop,IO ()) -API_ENTRY_SAFE(glutMainLoopEvent,IO ()) -API_ENTRY(glutMenuDestroyFunc,FunPtr MenuDestroyFunc -> IO ()) -API_ENTRY(glutMenuStateFunc,FunPtr MenuStateFunc -> IO ()) -API_ENTRY(glutMenuStatusFunc,FunPtr MenuStatusFunc -> IO ()) -API_ENTRY(glutMotionFunc,FunPtr MotionFunc -> IO ()) -API_ENTRY(glutMouseFunc,FunPtr MouseFunc -> IO ()) -API_ENTRY(glutMouseWheelFunc,FunPtr MouseWheelFunc -> IO ()) -API_ENTRY(glutOverlayDisplayFunc,FunPtr OverlayDisplayFunc -> IO ()) -API_ENTRY(glutPassiveMotionFunc,FunPtr PassiveMotionFunc -> IO ()) -API_ENTRY(glutPopWindow,IO ()) -API_ENTRY(glutPositionWindow,CInt -> CInt -> IO ()) -API_ENTRY_SAFE(glutPostOverlayRedisplay,IO ()) -API_ENTRY(glutPostRedisplay,IO ()) -API_ENTRY_SAFE(glutPostWindowOverlayRedisplay,CInt -> IO ()) -API_ENTRY(glutPostWindowRedisplay,CInt -> IO ()) -API_ENTRY(glutPushWindow,IO ()) -API_ENTRY(glutRemoveMenuItem,CInt -> IO ()) -API_ENTRY_SAFE(glutRemoveOverlay,IO ()) -API_ENTRY(glutReportErrors,IO ()) -API_ENTRY(glutReshapeFunc,FunPtr ReshapeFunc -> IO ()) -API_ENTRY(glutReshapeWindow,CInt -> CInt -> IO ()) -API_ENTRY(glutSetColor,CInt -> GLfloat -> GLfloat -> GLfloat -> IO ()) -API_ENTRY(glutSetCursor,CInt -> IO ()) -API_ENTRY(glutSetIconTitle,Ptr CChar -> IO ()) -API_ENTRY(glutSetKeyRepeat,CInt -> IO ()) -API_ENTRY(glutSetMenu,CInt -> IO ()) -API_ENTRY(glutSetMenuData,Ptr a -> IO ()) -API_ENTRY(glutSetOption,GLenum -> CInt -> IO ()) -API_ENTRY(glutSetWindow,CInt -> IO ()) -API_ENTRY(glutSetWindowData,Ptr a -> IO ()) -API_ENTRY(glutSetWindowTitle,Ptr CChar -> IO ()) -API_ENTRY(glutSetupVideoResizing,IO ()) -API_ENTRY_SAFE(glutShowOverlay,IO ()) -API_ENTRY(glutShowWindow,IO ()) -API_ENTRY(glutSolidCone,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(glutSolidCube,GLdouble -> IO ()) -API_ENTRY(glutSolidCylinder,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(glutSolidDodecahedron,IO ()) -API_ENTRY(glutSolidIcosahedron,IO ()) -API_ENTRY(glutSolidOctahedron,IO ()) -API_ENTRY(glutSolidRhombicDodecahedron,IO ()) -API_ENTRY(glutSolidSierpinskiSponge,CInt -> Ptr GLdouble -> GLdouble -> IO ()) -API_ENTRY(glutSolidSphere,GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(glutSolidTeapot,GLdouble -> IO ()) -API_ENTRY(glutSolidTetrahedron,IO ()) -API_ENTRY(glutSolidTorus,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(glutSpaceballButtonFunc,FunPtr SpaceballButtonFunc -> IO ()) -API_ENTRY(glutSpaceballMotionFunc,FunPtr SpaceballMotionFunc -> IO ()) -API_ENTRY(glutSpaceballRotateFunc,FunPtr SpaceballRotateFunc -> IO ()) -API_ENTRY(glutSpecialFunc,FunPtr SpecialFunc -> IO ()) -API_ENTRY(glutSpecialUpFunc,FunPtr SpecialUpFunc -> IO ()) -API_ENTRY(glutStopVideoResizing,IO ()) -API_ENTRY(glutStrokeCharacter,Ptr a -> CInt -> IO ()) -API_ENTRY(glutStrokeString,Ptr a -> Ptr CUChar -> IO ()) -API_ENTRY(glutSwapBuffers,IO ()) -API_ENTRY(glutTabletButtonFunc,FunPtr TabletButtonFunc -> IO ()) -API_ENTRY(glutTabletMotionFunc,FunPtr TabletMotionFunc -> IO ()) -API_ENTRY(glutTimerFunc,CUInt -> FunPtr TimerFunc -> CInt -> IO ()) -API_ENTRY_SAFE(glutUseLayer,GLenum -> IO ()) -API_ENTRY(glutVideoPan,CInt -> CInt -> CInt -> CInt -> IO ()) -API_ENTRY(glutVideoResize,CInt -> CInt -> CInt -> CInt -> IO ()) -API_ENTRY(glutVisibilityFunc,FunPtr VisibilityFunc -> IO ()) -API_ENTRY(glutWMCloseFunc,FunPtr WMCloseFunc -> IO ()) -API_ENTRY(glutWarpPointer,CInt -> CInt -> IO ()) -API_ENTRY(glutWindowStatusFunc,FunPtr WindowStatusFunc -> IO ()) -API_ENTRY(glutWireCone,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(glutWireCube,GLdouble -> IO ()) -API_ENTRY(glutWireCylinder,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(glutWireDodecahedron,IO ()) -API_ENTRY(glutWireIcosahedron,IO ()) -API_ENTRY(glutWireOctahedron,IO ()) -API_ENTRY(glutWireRhombicDodecahedron,IO ()) -API_ENTRY(glutWireSierpinskiSponge,CInt -> Ptr GLdouble -> GLdouble -> IO ()) -API_ENTRY(glutWireSphere,GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(glutWireTeapot,GLdouble -> IO ()) -API_ENTRY(glutWireTetrahedron,IO ()) -API_ENTRY(glutWireTorus,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(glutGetMenuData,IO (Ptr a)) -API_ENTRY(glutGetWindowData,IO (Ptr a)) +{-# LANGUAGE ForeignFunctionInterface, CPP #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Raw.Functions +-- Copyright : (c) Sven Panne 2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- All raw functions from GLUT and freeglut. +-- +----------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Raw.Functions ( + glutGetProcAddress, + glutGetColor, + glutStrokeHeight, + glutBitmapHeight, + glutBitmapLength, + glutBitmapWidth, + glutCreateMenu, + glutCreateSubWindow, + glutCreateWindow, + glutDeviceGet, + glutEnterGameMode, + glutExtensionSupported, + glutGameModeGet, + glutGet, + glutGetMenu, + glutGetModifiers, + glutGetWindow, + glutLayerGet, + glutStrokeLength, + glutStrokeWidth, + glutVideoResizeGet, + glutGetModeValues, + glutAddMenuEntry, + glutAddSubMenu, + glutAttachMenu, + glutBitmapCharacter, + glutBitmapString, + glutButtonBoxFunc, + glutChangeToMenuEntry, + glutChangeToSubMenu, + glutCloseFunc, + glutCopyColormap, + glutDestroyMenu, + glutDestroyWindow, + glutDetachMenu, + glutDialsFunc, + glutDisplayFunc, + glutEntryFunc, + glutEstablishOverlay, + glutExit, + glutForceJoystickFunc, + glutFullScreen, + glutFullScreenToggle, + glutGameModeString, + glutHideOverlay, + glutHideWindow, + glutIconifyWindow, + glutIdleFunc, + glutIgnoreKeyRepeat, + glutInit, + glutInitContextFlags, + glutInitContextVersion, + glutInitContextProfile, + glutInitDisplayMode, + glutInitDisplayString, + glutInitWindowPosition, + glutInitWindowSize, + glutJoystickFunc, + glutKeyboardFunc, + glutKeyboardUpFunc, + glutLeaveGameMode, + glutLeaveMainLoop, + glutMainLoop, + glutMainLoopEvent, + glutMenuDestroyFunc, + glutMenuStateFunc, + glutMenuStatusFunc, + glutMotionFunc, + glutMouseFunc, + glutMouseWheelFunc, + glutOverlayDisplayFunc, + glutPassiveMotionFunc, + glutPopWindow, + glutPositionWindow, + glutPostOverlayRedisplay, + glutPostRedisplay, + glutPostWindowOverlayRedisplay, + glutPostWindowRedisplay, + glutPushWindow, + glutRemoveMenuItem, + glutRemoveOverlay, + glutReportErrors, + glutReshapeFunc, + glutReshapeWindow, + glutSetColor, + glutSetCursor, + glutSetIconTitle, + glutSetKeyRepeat, + glutSetMenu, + glutSetMenuData, + glutSetOption, + glutSetWindow, + glutSetWindowData, + glutSetWindowTitle, + glutSetupVideoResizing, + glutShowOverlay, + glutShowWindow, + glutSolidCone, + glutSolidCube, + glutSolidCylinder, + glutSolidDodecahedron, + glutSolidIcosahedron, + glutSolidOctahedron, + glutSolidRhombicDodecahedron, + glutSolidSierpinskiSponge, + glutSolidSphere, + glutSolidTeapot, + glutSolidTetrahedron, + glutSolidTorus, + glutSpaceballButtonFunc, + glutSpaceballMotionFunc, + glutSpaceballRotateFunc, + glutSpecialFunc, + glutSpecialUpFunc, + glutStopVideoResizing, + glutStrokeCharacter, + glutStrokeString, + glutSwapBuffers, + glutTabletButtonFunc, + glutTabletMotionFunc, + glutTimerFunc, + glutUseLayer, + glutVideoPan, + glutVideoResize, + glutVisibilityFunc, + glutWMCloseFunc, + glutWarpPointer, + glutWindowStatusFunc, + glutWireCone, + glutWireCube, + glutWireCylinder, + glutWireDodecahedron, + glutWireIcosahedron, + glutWireOctahedron, + glutWireRhombicDodecahedron, + glutWireSierpinskiSponge, + glutWireSphere, + glutWireTeapot, + glutWireTetrahedron, + glutWireTorus, + glutGetMenuData, + glutGetWindowData +) where + +import Foreign.C.Types +import Foreign.Ptr +import Graphics.Rendering.OpenGL.Raw.Core31.Types +import Graphics.UI.GLUT.Raw.APIEntry +import Graphics.UI.GLUT.Raw.Callbacks + +#include "HsGLUTExt.h" + +API_ENTRY(glutGetProcAddress,Ptr CChar -> IO (FunPtr a)) +API_ENTRY(glutGetColor,CInt -> CInt -> IO GLfloat) +API_ENTRY(glutStrokeHeight,Ptr a -> IO GLfloat) +API_ENTRY(glutBitmapHeight,Ptr a -> IO CInt) +API_ENTRY(glutBitmapLength,Ptr a -> Ptr CUChar -> IO CInt) +API_ENTRY(glutBitmapWidth,Ptr a -> CInt -> IO CInt) +API_ENTRY(glutCreateMenu,FunPtr MenuFunc -> IO CInt) +API_ENTRY(glutCreateSubWindow,CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt) +API_ENTRY(glutCreateWindow,Ptr CChar -> IO CInt) +API_ENTRY(glutDeviceGet,GLenum -> IO CInt) +API_ENTRY(glutEnterGameMode,IO CInt) +API_ENTRY(glutExtensionSupported,Ptr CChar -> IO CInt) +API_ENTRY(glutGameModeGet,GLenum -> IO CInt) +API_ENTRY(glutGet,GLenum -> IO CInt) +API_ENTRY(glutGetMenu,IO CInt) +API_ENTRY(glutGetModifiers,IO CInt) +API_ENTRY(glutGetWindow,IO CInt) +API_ENTRY(glutLayerGet,GLenum -> IO CInt) +API_ENTRY(glutStrokeLength,Ptr a -> Ptr CUChar -> IO CInt) +API_ENTRY(glutStrokeWidth,Ptr a -> CInt -> IO CInt) +API_ENTRY(glutVideoResizeGet,GLenum -> IO CInt) +API_ENTRY(glutGetModeValues,GLenum -> Ptr CInt -> IO (Ptr CInt)) +API_ENTRY(glutAddMenuEntry,Ptr CChar -> CInt -> IO ()) +API_ENTRY(glutAddSubMenu,Ptr CChar -> CInt -> IO ()) +API_ENTRY(glutAttachMenu,CInt -> IO ()) +API_ENTRY(glutBitmapCharacter,Ptr a -> CInt -> IO ()) +API_ENTRY(glutBitmapString,Ptr a -> Ptr CUChar -> IO ()) +API_ENTRY(glutButtonBoxFunc,FunPtr ButtonBoxFunc -> IO ()) +API_ENTRY(glutChangeToMenuEntry,CInt -> Ptr CChar -> CInt -> IO ()) +API_ENTRY(glutChangeToSubMenu,CInt -> Ptr CChar -> CInt -> IO ()) +API_ENTRY(glutCloseFunc,FunPtr CloseFunc -> IO ()) +API_ENTRY(glutCopyColormap,CInt -> IO ()) +API_ENTRY(glutDestroyMenu,CInt -> IO ()) +API_ENTRY(glutDestroyWindow,CInt -> IO ()) +API_ENTRY(glutDetachMenu,CInt -> IO ()) +API_ENTRY(glutDialsFunc,FunPtr DialsFunc -> IO ()) +API_ENTRY(glutDisplayFunc,FunPtr DisplayFunc -> IO ()) +API_ENTRY(glutEntryFunc,FunPtr EntryFunc -> IO ()) +API_ENTRY_SAFE(glutEstablishOverlay,IO ()) +API_ENTRY(glutExit,IO ()) +API_ENTRY(glutForceJoystickFunc,IO ()) +API_ENTRY(glutFullScreen,IO ()) +API_ENTRY(glutFullScreenToggle,IO ()) +API_ENTRY(glutGameModeString,Ptr CChar -> IO ()) +API_ENTRY_SAFE(glutHideOverlay,IO ()) +API_ENTRY(glutHideWindow,IO ()) +API_ENTRY(glutIconifyWindow,IO ()) +API_ENTRY(glutIdleFunc,FunPtr IdleFunc -> IO ()) +API_ENTRY(glutIgnoreKeyRepeat,CInt -> IO ()) +API_ENTRY(glutInit,Ptr CInt -> Ptr (Ptr CChar) -> IO ()) +API_ENTRY(glutInitContextFlags,CInt -> IO ()) +API_ENTRY(glutInitContextVersion,CInt -> CInt -> IO ()) +API_ENTRY(glutInitContextProfile,CInt -> IO ()) +API_ENTRY(glutInitDisplayMode,CUInt -> IO ()) +API_ENTRY(glutInitDisplayString,Ptr CChar -> IO ()) +API_ENTRY(glutInitWindowPosition,CInt -> CInt -> IO ()) +API_ENTRY(glutInitWindowSize,CInt -> CInt -> IO ()) +API_ENTRY(glutJoystickFunc,FunPtr JoystickFunc -> CInt -> IO ()) +API_ENTRY(glutKeyboardFunc,FunPtr KeyboardFunc -> IO ()) +API_ENTRY(glutKeyboardUpFunc,FunPtr KeyboardUpFunc -> IO ()) +API_ENTRY(glutLeaveGameMode,IO ()) +API_ENTRY_SAFE(glutLeaveMainLoop,IO ()) +API_ENTRY_SAFE(glutMainLoop,IO ()) +API_ENTRY_SAFE(glutMainLoopEvent,IO ()) +API_ENTRY(glutMenuDestroyFunc,FunPtr MenuDestroyFunc -> IO ()) +API_ENTRY(glutMenuStateFunc,FunPtr MenuStateFunc -> IO ()) +API_ENTRY(glutMenuStatusFunc,FunPtr MenuStatusFunc -> IO ()) +API_ENTRY(glutMotionFunc,FunPtr MotionFunc -> IO ()) +API_ENTRY(glutMouseFunc,FunPtr MouseFunc -> IO ()) +API_ENTRY(glutMouseWheelFunc,FunPtr MouseWheelFunc -> IO ()) +API_ENTRY(glutOverlayDisplayFunc,FunPtr OverlayDisplayFunc -> IO ()) +API_ENTRY(glutPassiveMotionFunc,FunPtr PassiveMotionFunc -> IO ()) +API_ENTRY(glutPopWindow,IO ()) +API_ENTRY(glutPositionWindow,CInt -> CInt -> IO ()) +API_ENTRY_SAFE(glutPostOverlayRedisplay,IO ()) +API_ENTRY(glutPostRedisplay,IO ()) +API_ENTRY_SAFE(glutPostWindowOverlayRedisplay,CInt -> IO ()) +API_ENTRY(glutPostWindowRedisplay,CInt -> IO ()) +API_ENTRY(glutPushWindow,IO ()) +API_ENTRY(glutRemoveMenuItem,CInt -> IO ()) +API_ENTRY_SAFE(glutRemoveOverlay,IO ()) +API_ENTRY(glutReportErrors,IO ()) +API_ENTRY(glutReshapeFunc,FunPtr ReshapeFunc -> IO ()) +API_ENTRY(glutReshapeWindow,CInt -> CInt -> IO ()) +API_ENTRY(glutSetColor,CInt -> GLfloat -> GLfloat -> GLfloat -> IO ()) +API_ENTRY(glutSetCursor,CInt -> IO ()) +API_ENTRY(glutSetIconTitle,Ptr CChar -> IO ()) +API_ENTRY(glutSetKeyRepeat,CInt -> IO ()) +API_ENTRY(glutSetMenu,CInt -> IO ()) +API_ENTRY(glutSetMenuData,Ptr a -> IO ()) +API_ENTRY(glutSetOption,GLenum -> CInt -> IO ()) +API_ENTRY(glutSetWindow,CInt -> IO ()) +API_ENTRY(glutSetWindowData,Ptr a -> IO ()) +API_ENTRY(glutSetWindowTitle,Ptr CChar -> IO ()) +API_ENTRY(glutSetupVideoResizing,IO ()) +API_ENTRY_SAFE(glutShowOverlay,IO ()) +API_ENTRY(glutShowWindow,IO ()) +API_ENTRY(glutSolidCone,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) +API_ENTRY(glutSolidCube,GLdouble -> IO ()) +API_ENTRY(glutSolidCylinder,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) +API_ENTRY(glutSolidDodecahedron,IO ()) +API_ENTRY(glutSolidIcosahedron,IO ()) +API_ENTRY(glutSolidOctahedron,IO ()) +API_ENTRY(glutSolidRhombicDodecahedron,IO ()) +API_ENTRY(glutSolidSierpinskiSponge,CInt -> Ptr GLdouble -> GLdouble -> IO ()) +API_ENTRY(glutSolidSphere,GLdouble -> GLint -> GLint -> IO ()) +API_ENTRY(glutSolidTeapot,GLdouble -> IO ()) +API_ENTRY(glutSolidTetrahedron,IO ()) +API_ENTRY(glutSolidTorus,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) +API_ENTRY(glutSpaceballButtonFunc,FunPtr SpaceballButtonFunc -> IO ()) +API_ENTRY(glutSpaceballMotionFunc,FunPtr SpaceballMotionFunc -> IO ()) +API_ENTRY(glutSpaceballRotateFunc,FunPtr SpaceballRotateFunc -> IO ()) +API_ENTRY(glutSpecialFunc,FunPtr SpecialFunc -> IO ()) +API_ENTRY(glutSpecialUpFunc,FunPtr SpecialUpFunc -> IO ()) +API_ENTRY(glutStopVideoResizing,IO ()) +API_ENTRY(glutStrokeCharacter,Ptr a -> CInt -> IO ()) +API_ENTRY(glutStrokeString,Ptr a -> Ptr CUChar -> IO ()) +API_ENTRY(glutSwapBuffers,IO ()) +API_ENTRY(glutTabletButtonFunc,FunPtr TabletButtonFunc -> IO ()) +API_ENTRY(glutTabletMotionFunc,FunPtr TabletMotionFunc -> IO ()) +API_ENTRY(glutTimerFunc,CUInt -> FunPtr TimerFunc -> CInt -> IO ()) +API_ENTRY_SAFE(glutUseLayer,GLenum -> IO ()) +API_ENTRY(glutVideoPan,CInt -> CInt -> CInt -> CInt -> IO ()) +API_ENTRY(glutVideoResize,CInt -> CInt -> CInt -> CInt -> IO ()) +API_ENTRY(glutVisibilityFunc,FunPtr VisibilityFunc -> IO ()) +API_ENTRY(glutWMCloseFunc,FunPtr WMCloseFunc -> IO ()) +API_ENTRY(glutWarpPointer,CInt -> CInt -> IO ()) +API_ENTRY(glutWindowStatusFunc,FunPtr WindowStatusFunc -> IO ()) +API_ENTRY(glutWireCone,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) +API_ENTRY(glutWireCube,GLdouble -> IO ()) +API_ENTRY(glutWireCylinder,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) +API_ENTRY(glutWireDodecahedron,IO ()) +API_ENTRY(glutWireIcosahedron,IO ()) +API_ENTRY(glutWireOctahedron,IO ()) +API_ENTRY(glutWireRhombicDodecahedron,IO ()) +API_ENTRY(glutWireSierpinskiSponge,CInt -> Ptr GLdouble -> GLdouble -> IO ()) +API_ENTRY(glutWireSphere,GLdouble -> GLint -> GLint -> IO ()) +API_ENTRY(glutWireTeapot,GLdouble -> IO ()) +API_ENTRY(glutWireTetrahedron,IO ()) +API_ENTRY(glutWireTorus,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) +API_ENTRY(glutGetMenuData,IO (Ptr a)) +API_ENTRY(glutGetWindowData,IO (Ptr a)) diff --git a/Graphics/UI/GLUT/Raw/Tokens.hs b/Graphics/UI/GLUT/Raw/Tokens.hs --- a/Graphics/UI/GLUT/Raw/Tokens.hs +++ b/Graphics/UI/GLUT/Raw/Tokens.hs @@ -1,613 +1,613 @@ -{-# OPTIONS_HADDOCK hide #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.UI.GLUT.Raw.Tokens --- Copyright : (c) Sven Panne 2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- All tokens from GLUT and freeglut. --- ------------------------------------------------------------------------------ - -module Graphics.UI.GLUT.Raw.Tokens where - -import Foreign.C.Types -import Graphics.Rendering.OpenGL ( GLenum ) - -glut_ACCUM :: CUInt -glut_ACCUM = 0x0004 - -glut_ACTION_CONTINUE_EXECUTION :: CInt -glut_ACTION_CONTINUE_EXECUTION = 2 - -glut_ACTION_EXIT :: CInt -glut_ACTION_EXIT = 0 - -glut_ACTION_GLUTMAINLOOP_RETURNS :: CInt -glut_ACTION_GLUTMAINLOOP_RETURNS = 1 - -glut_ACTION_ON_WINDOW_CLOSE :: GLenum -glut_ACTION_ON_WINDOW_CLOSE = 0x01F9 - -glut_ACTIVE_ALT :: CInt -glut_ACTIVE_ALT = 0x0004 - -glut_ACTIVE_CTRL :: CInt -glut_ACTIVE_CTRL = 0x0002 - -glut_ACTIVE_SHIFT :: CInt -glut_ACTIVE_SHIFT = 0x0001 - -glut_ALLOW_DIRECT_CONTEXT :: CInt -glut_ALLOW_DIRECT_CONTEXT = 1 - -glut_ALPHA :: CUInt -glut_ALPHA = 0x0008 - -glut_AUX :: GLenum -glut_AUX = 0x1000 - -glut_AUX1 :: CUInt -glut_AUX1 = 0x1000 - -glut_AUX2 :: CUInt -glut_AUX2 = 0x2000 - -glut_AUX3 :: CUInt -glut_AUX3 = 0x4000 - -glut_AUX4 :: CUInt -glut_AUX4 = 0x8000 - -glut_BLUE :: CInt -glut_BLUE = 0x0002 - -glut_BORDERLESS :: CUInt -glut_BORDERLESS = 0x0800 - -glut_CAPTIONLESS :: CUInt -glut_CAPTIONLESS = 0x0400 - -glut_CORE_PROFILE :: CInt -glut_CORE_PROFILE = 0x0001 - -glut_COMPATIBILITY_PROFILE :: CInt -glut_COMPATIBILITY_PROFILE = 0x0002 - -glut_CREATE_NEW_CONTEXT :: CInt -glut_CREATE_NEW_CONTEXT = 0 - -glut_CURSOR_BOTTOM_LEFT_CORNER :: CInt -glut_CURSOR_BOTTOM_LEFT_CORNER = 0x0013 - -glut_CURSOR_BOTTOM_RIGHT_CORNER :: CInt -glut_CURSOR_BOTTOM_RIGHT_CORNER = 0x0012 - -glut_CURSOR_BOTTOM_SIDE :: CInt -glut_CURSOR_BOTTOM_SIDE = 0x000D - -glut_CURSOR_CROSSHAIR :: CInt -glut_CURSOR_CROSSHAIR = 0x0009 - -glut_CURSOR_CYCLE :: CInt -glut_CURSOR_CYCLE = 0x0005 - -glut_CURSOR_DESTROY :: CInt -glut_CURSOR_DESTROY = 0x0003 - -glut_CURSOR_FULL_CROSSHAIR :: CInt -glut_CURSOR_FULL_CROSSHAIR = 0x0066 - -glut_CURSOR_HELP :: CInt -glut_CURSOR_HELP = 0x0004 - -glut_CURSOR_INFO :: CInt -glut_CURSOR_INFO = 0x0002 - -glut_CURSOR_INHERIT :: CInt -glut_CURSOR_INHERIT = 0x0064 - -glut_CURSOR_LEFT_ARROW :: CInt -glut_CURSOR_LEFT_ARROW = 0x0001 - -glut_CURSOR_LEFT_RIGHT :: CInt -glut_CURSOR_LEFT_RIGHT = 0x000B - -glut_CURSOR_LEFT_SIDE :: CInt -glut_CURSOR_LEFT_SIDE = 0x000E - -glut_CURSOR_NONE :: CInt -glut_CURSOR_NONE = 0x0065 - -glut_CURSOR_RIGHT_ARROW :: CInt -glut_CURSOR_RIGHT_ARROW = 0x0000 - -glut_CURSOR_RIGHT_SIDE :: CInt -glut_CURSOR_RIGHT_SIDE = 0x000F - -glut_CURSOR_SPRAY :: CInt -glut_CURSOR_SPRAY = 0x0006 - -glut_CURSOR_TEXT :: CInt -glut_CURSOR_TEXT = 0x0008 - -glut_CURSOR_TOP_LEFT_CORNER :: CInt -glut_CURSOR_TOP_LEFT_CORNER = 0x0010 - -glut_CURSOR_TOP_RIGHT_CORNER :: CInt -glut_CURSOR_TOP_RIGHT_CORNER = 0x0011 - -glut_CURSOR_TOP_SIDE :: CInt -glut_CURSOR_TOP_SIDE = 0x000C - -glut_CURSOR_UP_DOWN :: CInt -glut_CURSOR_UP_DOWN = 0x000A - -glut_CURSOR_WAIT :: CInt -glut_CURSOR_WAIT = 0x0007 - -glut_DEBUG :: CInt -glut_DEBUG = 0x0001 - -glut_DEPTH :: CUInt -glut_DEPTH = 0x0010 - -glut_DEVICE_IGNORE_KEY_REPEAT :: GLenum -glut_DEVICE_IGNORE_KEY_REPEAT = 0x0262 - -glut_DEVICE_KEY_REPEAT :: GLenum -glut_DEVICE_KEY_REPEAT = 0x0263 - -glut_DIRECT_RENDERING :: GLenum -glut_DIRECT_RENDERING = 0x01FE - -glut_DISPLAY_MODE_POSSIBLE :: GLenum -glut_DISPLAY_MODE_POSSIBLE = 0x0190 - -glut_DOUBLE :: CUInt -glut_DOUBLE = 0x0002 - -glut_DOWN :: CInt -glut_DOWN = 0x0000 - -glut_ELAPSED_TIME :: GLenum -glut_ELAPSED_TIME = 0x02BC - -glut_ENTERED :: CInt -glut_ENTERED = 0x0001 - -glut_FORCE_DIRECT_CONTEXT :: CInt -glut_FORCE_DIRECT_CONTEXT = 3 - -glut_FORCE_INDIRECT_CONTEXT :: CInt -glut_FORCE_INDIRECT_CONTEXT = 0 - -glut_FORWARD_COMPATIBLE :: CInt -glut_FORWARD_COMPATIBLE = 0x0002 - -glut_FULLY_COVERED :: CInt -glut_FULLY_COVERED = 0x0003 - -glut_FULLY_RETAINED :: CInt -glut_FULLY_RETAINED = 0x0001 - -glut_FULL_SCREEN :: GLenum -glut_FULL_SCREEN = 0x01FF - -glut_GAME_MODE_ACTIVE :: GLenum -glut_GAME_MODE_ACTIVE = 0x0000 - -glut_GAME_MODE_DISPLAY_CHANGED :: GLenum -glut_GAME_MODE_DISPLAY_CHANGED = 0x0006 - -glut_GAME_MODE_HEIGHT :: GLenum -glut_GAME_MODE_HEIGHT = 0x0003 - -glut_GAME_MODE_PIXEL_DEPTH :: GLenum -glut_GAME_MODE_PIXEL_DEPTH = 0x0004 - -glut_GAME_MODE_POSSIBLE :: GLenum -glut_GAME_MODE_POSSIBLE = 0x0001 - -glut_GAME_MODE_REFRESH_RATE :: GLenum -glut_GAME_MODE_REFRESH_RATE = 0x0005 - -glut_GAME_MODE_WIDTH :: GLenum -glut_GAME_MODE_WIDTH = 0x0002 - -glut_GREEN :: CInt -glut_GREEN = 0x0001 - -glut_HAS_DIAL_AND_BUTTON_BOX :: GLenum -glut_HAS_DIAL_AND_BUTTON_BOX = 0x025B - -glut_HAS_JOYSTICK :: GLenum -glut_HAS_JOYSTICK = 0x0264 - -glut_HAS_KEYBOARD :: GLenum -glut_HAS_KEYBOARD = 0x0258 - -glut_HAS_MOUSE :: GLenum -glut_HAS_MOUSE = 0x0259 - -glut_HAS_OVERLAY :: GLenum -glut_HAS_OVERLAY = 0x0322 - -glut_HAS_SPACEBALL :: GLenum -glut_HAS_SPACEBALL = 0x025A - -glut_HAS_TABLET :: GLenum -glut_HAS_TABLET = 0x025C - -glut_HIDDEN :: CInt -glut_HIDDEN = 0x0000 - -glut_INDEX :: CUInt -glut_INDEX = 0x0001 - -glut_INIT_DISPLAY_MODE :: GLenum -glut_INIT_DISPLAY_MODE = 0x01F8 - -glut_INIT_FLAGS :: GLenum -glut_INIT_FLAGS = 0x0202 - -glut_INIT_MAJOR_VERSION :: GLenum -glut_INIT_MAJOR_VERSION = 0x0200 - -glut_INIT_MINOR_VERSION :: GLenum -glut_INIT_MINOR_VERSION = 0x0201 - -glut_INIT_PROFILE :: GLenum -glut_INIT_PROFILE = 0x0203 - -glut_INIT_STATE :: GLenum -glut_INIT_STATE = 0x007C - -glut_INIT_WINDOW_HEIGHT :: GLenum -glut_INIT_WINDOW_HEIGHT = 0x01F7 - -glut_INIT_WINDOW_WIDTH :: GLenum -glut_INIT_WINDOW_WIDTH = 0x01F6 - -glut_INIT_WINDOW_X :: GLenum -glut_INIT_WINDOW_X = 0x01F4 - -glut_INIT_WINDOW_Y :: GLenum -glut_INIT_WINDOW_Y = 0x01F5 - -glut_JOYSTICK_AXES :: GLenum -glut_JOYSTICK_AXES = 0x0267 - -glut_JOYSTICK_BUTTONS :: GLenum -glut_JOYSTICK_BUTTONS = 0x0266 - -glut_JOYSTICK_BUTTON_A :: CUInt -glut_JOYSTICK_BUTTON_A = 0x0001 - -glut_JOYSTICK_BUTTON_B :: CUInt -glut_JOYSTICK_BUTTON_B = 0x0002 - -glut_JOYSTICK_BUTTON_C :: CUInt -glut_JOYSTICK_BUTTON_C = 0x0004 - -glut_JOYSTICK_BUTTON_D :: CUInt -glut_JOYSTICK_BUTTON_D = 0x0008 - -glut_JOYSTICK_POLL_RATE :: GLenum -glut_JOYSTICK_POLL_RATE = 0x0268 - -glut_KEY_BEGIN :: CInt -glut_KEY_BEGIN = 0x006E - -glut_KEY_DELETE :: CInt -glut_KEY_DELETE = 0x006F - -glut_KEY_DOWN :: CInt -glut_KEY_DOWN = 0x0067 - -glut_KEY_END :: CInt -glut_KEY_END = 0x006B - -glut_KEY_F1 :: CInt -glut_KEY_F1 = 0x0001 - -glut_KEY_F10 :: CInt -glut_KEY_F10 = 0x000A - -glut_KEY_F11 :: CInt -glut_KEY_F11 = 0x000B - -glut_KEY_F12 :: CInt -glut_KEY_F12 = 0x000C - -glut_KEY_F2 :: CInt -glut_KEY_F2 = 0x0002 - -glut_KEY_F3 :: CInt -glut_KEY_F3 = 0x0003 - -glut_KEY_F4 :: CInt -glut_KEY_F4 = 0x0004 - -glut_KEY_F5 :: CInt -glut_KEY_F5 = 0x0005 - -glut_KEY_F6 :: CInt -glut_KEY_F6 = 0x0006 - -glut_KEY_F7 :: CInt -glut_KEY_F7 = 0x0007 - -glut_KEY_F8 :: CInt -glut_KEY_F8 = 0x0008 - -glut_KEY_F9 :: CInt -glut_KEY_F9 = 0x0009 - -glut_KEY_HOME :: CInt -glut_KEY_HOME = 0x006A - -glut_KEY_INSERT :: CInt -glut_KEY_INSERT = 0x006C - -glut_KEY_LEFT :: CInt -glut_KEY_LEFT = 0x0064 - -glut_KEY_NUM_LOCK :: CInt -glut_KEY_NUM_LOCK = 0x006D - -glut_KEY_PAGE_DOWN :: CInt -glut_KEY_PAGE_DOWN = 0x0069 - -glut_KEY_PAGE_UP :: CInt -glut_KEY_PAGE_UP = 0x0068 - -glut_KEY_REPEAT_DEFAULT :: CInt -glut_KEY_REPEAT_DEFAULT = 0x0002 - -glut_KEY_REPEAT_OFF :: CInt -glut_KEY_REPEAT_OFF = 0x0000 - -glut_KEY_REPEAT_ON :: CInt -glut_KEY_REPEAT_ON = 0x0001 - -glut_KEY_RIGHT :: CInt -glut_KEY_RIGHT = 0x0066 - -glut_KEY_UP :: CInt -glut_KEY_UP = 0x0065 - -glut_LAYER_IN_USE :: GLenum -glut_LAYER_IN_USE = 0x0321 - -glut_LEFT :: CInt -glut_LEFT = 0x0000 - -glut_LEFT_BUTTON :: CInt -glut_LEFT_BUTTON = 0x0000 - -glut_LUMINANCE :: CUInt -glut_LUMINANCE = 0x0200 - -glut_MENU_IN_USE :: CInt -glut_MENU_IN_USE = 0x0001 - -glut_MENU_NOT_IN_USE :: CInt -glut_MENU_NOT_IN_USE = 0x0000 - -glut_MENU_NUM_ITEMS :: GLenum -glut_MENU_NUM_ITEMS = 0x012C - -glut_MIDDLE_BUTTON :: CInt -glut_MIDDLE_BUTTON = 0x0001 - -glut_MULTISAMPLE :: CUInt -glut_MULTISAMPLE = 0x0080 - -glut_NORMAL :: GLenum -glut_NORMAL = 0x0000 - -glut_NORMAL_DAMAGED :: GLenum -glut_NORMAL_DAMAGED = 0x0324 - -glut_NOT_VISIBLE :: CInt -glut_NOT_VISIBLE = 0x0000 - -glut_NUM_BUTTON_BOX_BUTTONS :: GLenum -glut_NUM_BUTTON_BOX_BUTTONS = 0x025F - -glut_NUM_DIALS :: GLenum -glut_NUM_DIALS = 0x0260 - -glut_NUM_MOUSE_BUTTONS :: GLenum -glut_NUM_MOUSE_BUTTONS = 0x025D - -glut_NUM_SPACEBALL_BUTTONS :: GLenum -glut_NUM_SPACEBALL_BUTTONS = 0x025E - -glut_NUM_TABLET_BUTTONS :: GLenum -glut_NUM_TABLET_BUTTONS = 0x0261 - -glut_OVERLAY :: GLenum -glut_OVERLAY = 0x0001 - -glut_OVERLAY_DAMAGED :: GLenum -glut_OVERLAY_DAMAGED = 0x0325 - -glut_OVERLAY_POSSIBLE :: GLenum -glut_OVERLAY_POSSIBLE = 0x0320 - -glut_OWNS_JOYSTICK :: GLenum -glut_OWNS_JOYSTICK = 0x0265 - -glut_PARTIALLY_RETAINED :: CInt -glut_PARTIALLY_RETAINED = 0x0002 - -glut_RED :: CInt -glut_RED = 0x0000 - -glut_RENDERING_CONTEXT :: GLenum -glut_RENDERING_CONTEXT = 0x01FD - -glut_RGB :: CUInt -glut_RGB = 0x0000 - -glut_RGBA :: CUInt -glut_RGBA = 0x0000 - -glut_RIGHT_BUTTON :: CInt -glut_RIGHT_BUTTON = 0x0002 - -glut_SCREEN_HEIGHT :: GLenum -glut_SCREEN_HEIGHT = 0x00C9 - -glut_SCREEN_HEIGHT_MM :: GLenum -glut_SCREEN_HEIGHT_MM = 0x00CB - -glut_SCREEN_WIDTH :: GLenum -glut_SCREEN_WIDTH = 0x00C8 - -glut_SCREEN_WIDTH_MM :: GLenum -glut_SCREEN_WIDTH_MM = 0x00CA - -glut_SINGLE :: CUInt -glut_SINGLE = 0x0000 - -glut_SRGB :: CUInt -glut_SRGB = 0x1000 - -glut_STENCIL :: CUInt -glut_STENCIL = 0x0020 - -glut_STEREO :: CUInt -glut_STEREO = 0x0100 - -glut_TRANSPARENT_INDEX :: GLenum -glut_TRANSPARENT_INDEX = 0x0323 - -glut_TRY_DIRECT_CONTEXT :: CInt -glut_TRY_DIRECT_CONTEXT = 2 - -glut_UP :: CInt -glut_UP = 0x0001 - -glut_USE_CURRENT_CONTEXT :: CInt -glut_USE_CURRENT_CONTEXT = 1 - -glut_VERSION :: GLenum -glut_VERSION = 0x01FC - -glut_VIDEO_RESIZE_HEIGHT :: GLenum -glut_VIDEO_RESIZE_HEIGHT = 0x038D - -glut_VIDEO_RESIZE_HEIGHT_DELTA :: GLenum -glut_VIDEO_RESIZE_HEIGHT_DELTA = 0x0389 - -glut_VIDEO_RESIZE_IN_USE :: GLenum -glut_VIDEO_RESIZE_IN_USE = 0x0385 - -glut_VIDEO_RESIZE_POSSIBLE :: GLenum -glut_VIDEO_RESIZE_POSSIBLE = 0x0384 - -glut_VIDEO_RESIZE_WIDTH :: GLenum -glut_VIDEO_RESIZE_WIDTH = 0x038C - -glut_VIDEO_RESIZE_WIDTH_DELTA :: GLenum -glut_VIDEO_RESIZE_WIDTH_DELTA = 0x0388 - -glut_VIDEO_RESIZE_X :: GLenum -glut_VIDEO_RESIZE_X = 0x038A - -glut_VIDEO_RESIZE_X_DELTA :: GLenum -glut_VIDEO_RESIZE_X_DELTA = 0x0386 - -glut_VIDEO_RESIZE_Y :: GLenum -glut_VIDEO_RESIZE_Y = 0x038B - -glut_VIDEO_RESIZE_Y_DELTA :: GLenum -glut_VIDEO_RESIZE_Y_DELTA = 0x0387 - -glut_VISIBLE :: CInt -glut_VISIBLE = 0x0001 - -glut_WINDOW_ACCUM_ALPHA_SIZE :: GLenum -glut_WINDOW_ACCUM_ALPHA_SIZE = 0x0072 - -glut_WINDOW_ACCUM_BLUE_SIZE :: GLenum -glut_WINDOW_ACCUM_BLUE_SIZE = 0x0071 - -glut_WINDOW_ACCUM_GREEN_SIZE :: GLenum -glut_WINDOW_ACCUM_GREEN_SIZE = 0x0070 - -glut_WINDOW_ACCUM_RED_SIZE :: GLenum -glut_WINDOW_ACCUM_RED_SIZE = 0x006F - -glut_WINDOW_ALPHA_SIZE :: GLenum -glut_WINDOW_ALPHA_SIZE = 0x006E - -glut_WINDOW_BLUE_SIZE :: GLenum -glut_WINDOW_BLUE_SIZE = 0x006D - -glut_WINDOW_BORDER_WIDTH :: GLenum -glut_WINDOW_BORDER_WIDTH = 0x01FA - -glut_WINDOW_BUFFER_SIZE :: GLenum -glut_WINDOW_BUFFER_SIZE = 0x0068 - -glut_WINDOW_COLORMAP_SIZE :: GLenum -glut_WINDOW_COLORMAP_SIZE = 0x0077 - -glut_WINDOW_CURSOR :: GLenum -glut_WINDOW_CURSOR = 0x007A - -glut_WINDOW_DEPTH_SIZE :: GLenum -glut_WINDOW_DEPTH_SIZE = 0x006A - -glut_WINDOW_DOUBLEBUFFER :: GLenum -glut_WINDOW_DOUBLEBUFFER = 0x0073 - -glut_WINDOW_FORMAT_ID :: GLenum -glut_WINDOW_FORMAT_ID = 0x007B - -glut_WINDOW_GREEN_SIZE :: GLenum -glut_WINDOW_GREEN_SIZE = 0x006C - -glut_WINDOW_HEADER_HEIGHT :: GLenum -glut_WINDOW_HEADER_HEIGHT = 0x01FB - -glut_WINDOW_HEIGHT :: GLenum -glut_WINDOW_HEIGHT = 0x0067 - -glut_WINDOW_NUM_CHILDREN :: GLenum -glut_WINDOW_NUM_CHILDREN = 0x0076 - -glut_WINDOW_NUM_SAMPLES :: GLenum -glut_WINDOW_NUM_SAMPLES = 0x0078 - -glut_WINDOW_PARENT :: GLenum -glut_WINDOW_PARENT = 0x0075 - -glut_WINDOW_RED_SIZE :: GLenum -glut_WINDOW_RED_SIZE = 0x006B - -glut_WINDOW_RGBA :: GLenum -glut_WINDOW_RGBA = 0x0074 - -glut_WINDOW_STENCIL_SIZE :: GLenum -glut_WINDOW_STENCIL_SIZE = 0x0069 - -glut_WINDOW_STEREO :: GLenum -glut_WINDOW_STEREO = 0x0079 - -glut_WINDOW_WIDTH :: GLenum -glut_WINDOW_WIDTH = 0x0066 - -glut_WINDOW_X :: GLenum -glut_WINDOW_X = 0x0064 - -glut_WINDOW_Y :: GLenum -glut_WINDOW_Y = 0x0065 +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Raw.Tokens +-- Copyright : (c) Sven Panne 2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- All tokens from GLUT and freeglut. +-- +----------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Raw.Tokens where + +import Foreign.C.Types +import Graphics.Rendering.OpenGL ( GLenum ) + +glut_ACCUM :: CUInt +glut_ACCUM = 0x0004 + +glut_ACTION_CONTINUE_EXECUTION :: CInt +glut_ACTION_CONTINUE_EXECUTION = 2 + +glut_ACTION_EXIT :: CInt +glut_ACTION_EXIT = 0 + +glut_ACTION_GLUTMAINLOOP_RETURNS :: CInt +glut_ACTION_GLUTMAINLOOP_RETURNS = 1 + +glut_ACTION_ON_WINDOW_CLOSE :: GLenum +glut_ACTION_ON_WINDOW_CLOSE = 0x01F9 + +glut_ACTIVE_ALT :: CInt +glut_ACTIVE_ALT = 0x0004 + +glut_ACTIVE_CTRL :: CInt +glut_ACTIVE_CTRL = 0x0002 + +glut_ACTIVE_SHIFT :: CInt +glut_ACTIVE_SHIFT = 0x0001 + +glut_ALLOW_DIRECT_CONTEXT :: CInt +glut_ALLOW_DIRECT_CONTEXT = 1 + +glut_ALPHA :: CUInt +glut_ALPHA = 0x0008 + +glut_AUX :: GLenum +glut_AUX = 0x1000 + +glut_AUX1 :: CUInt +glut_AUX1 = 0x1000 + +glut_AUX2 :: CUInt +glut_AUX2 = 0x2000 + +glut_AUX3 :: CUInt +glut_AUX3 = 0x4000 + +glut_AUX4 :: CUInt +glut_AUX4 = 0x8000 + +glut_BLUE :: CInt +glut_BLUE = 0x0002 + +glut_BORDERLESS :: CUInt +glut_BORDERLESS = 0x0800 + +glut_CAPTIONLESS :: CUInt +glut_CAPTIONLESS = 0x0400 + +glut_CORE_PROFILE :: CInt +glut_CORE_PROFILE = 0x0001 + +glut_COMPATIBILITY_PROFILE :: CInt +glut_COMPATIBILITY_PROFILE = 0x0002 + +glut_CREATE_NEW_CONTEXT :: CInt +glut_CREATE_NEW_CONTEXT = 0 + +glut_CURSOR_BOTTOM_LEFT_CORNER :: CInt +glut_CURSOR_BOTTOM_LEFT_CORNER = 0x0013 + +glut_CURSOR_BOTTOM_RIGHT_CORNER :: CInt +glut_CURSOR_BOTTOM_RIGHT_CORNER = 0x0012 + +glut_CURSOR_BOTTOM_SIDE :: CInt +glut_CURSOR_BOTTOM_SIDE = 0x000D + +glut_CURSOR_CROSSHAIR :: CInt +glut_CURSOR_CROSSHAIR = 0x0009 + +glut_CURSOR_CYCLE :: CInt +glut_CURSOR_CYCLE = 0x0005 + +glut_CURSOR_DESTROY :: CInt +glut_CURSOR_DESTROY = 0x0003 + +glut_CURSOR_FULL_CROSSHAIR :: CInt +glut_CURSOR_FULL_CROSSHAIR = 0x0066 + +glut_CURSOR_HELP :: CInt +glut_CURSOR_HELP = 0x0004 + +glut_CURSOR_INFO :: CInt +glut_CURSOR_INFO = 0x0002 + +glut_CURSOR_INHERIT :: CInt +glut_CURSOR_INHERIT = 0x0064 + +glut_CURSOR_LEFT_ARROW :: CInt +glut_CURSOR_LEFT_ARROW = 0x0001 + +glut_CURSOR_LEFT_RIGHT :: CInt +glut_CURSOR_LEFT_RIGHT = 0x000B + +glut_CURSOR_LEFT_SIDE :: CInt +glut_CURSOR_LEFT_SIDE = 0x000E + +glut_CURSOR_NONE :: CInt +glut_CURSOR_NONE = 0x0065 + +glut_CURSOR_RIGHT_ARROW :: CInt +glut_CURSOR_RIGHT_ARROW = 0x0000 + +glut_CURSOR_RIGHT_SIDE :: CInt +glut_CURSOR_RIGHT_SIDE = 0x000F + +glut_CURSOR_SPRAY :: CInt +glut_CURSOR_SPRAY = 0x0006 + +glut_CURSOR_TEXT :: CInt +glut_CURSOR_TEXT = 0x0008 + +glut_CURSOR_TOP_LEFT_CORNER :: CInt +glut_CURSOR_TOP_LEFT_CORNER = 0x0010 + +glut_CURSOR_TOP_RIGHT_CORNER :: CInt +glut_CURSOR_TOP_RIGHT_CORNER = 0x0011 + +glut_CURSOR_TOP_SIDE :: CInt +glut_CURSOR_TOP_SIDE = 0x000C + +glut_CURSOR_UP_DOWN :: CInt +glut_CURSOR_UP_DOWN = 0x000A + +glut_CURSOR_WAIT :: CInt +glut_CURSOR_WAIT = 0x0007 + +glut_DEBUG :: CInt +glut_DEBUG = 0x0001 + +glut_DEPTH :: CUInt +glut_DEPTH = 0x0010 + +glut_DEVICE_IGNORE_KEY_REPEAT :: GLenum +glut_DEVICE_IGNORE_KEY_REPEAT = 0x0262 + +glut_DEVICE_KEY_REPEAT :: GLenum +glut_DEVICE_KEY_REPEAT = 0x0263 + +glut_DIRECT_RENDERING :: GLenum +glut_DIRECT_RENDERING = 0x01FE + +glut_DISPLAY_MODE_POSSIBLE :: GLenum +glut_DISPLAY_MODE_POSSIBLE = 0x0190 + +glut_DOUBLE :: CUInt +glut_DOUBLE = 0x0002 + +glut_DOWN :: CInt +glut_DOWN = 0x0000 + +glut_ELAPSED_TIME :: GLenum +glut_ELAPSED_TIME = 0x02BC + +glut_ENTERED :: CInt +glut_ENTERED = 0x0001 + +glut_FORCE_DIRECT_CONTEXT :: CInt +glut_FORCE_DIRECT_CONTEXT = 3 + +glut_FORCE_INDIRECT_CONTEXT :: CInt +glut_FORCE_INDIRECT_CONTEXT = 0 + +glut_FORWARD_COMPATIBLE :: CInt +glut_FORWARD_COMPATIBLE = 0x0002 + +glut_FULLY_COVERED :: CInt +glut_FULLY_COVERED = 0x0003 + +glut_FULLY_RETAINED :: CInt +glut_FULLY_RETAINED = 0x0001 + +glut_FULL_SCREEN :: GLenum +glut_FULL_SCREEN = 0x01FF + +glut_GAME_MODE_ACTIVE :: GLenum +glut_GAME_MODE_ACTIVE = 0x0000 + +glut_GAME_MODE_DISPLAY_CHANGED :: GLenum +glut_GAME_MODE_DISPLAY_CHANGED = 0x0006 + +glut_GAME_MODE_HEIGHT :: GLenum +glut_GAME_MODE_HEIGHT = 0x0003 + +glut_GAME_MODE_PIXEL_DEPTH :: GLenum +glut_GAME_MODE_PIXEL_DEPTH = 0x0004 + +glut_GAME_MODE_POSSIBLE :: GLenum +glut_GAME_MODE_POSSIBLE = 0x0001 + +glut_GAME_MODE_REFRESH_RATE :: GLenum +glut_GAME_MODE_REFRESH_RATE = 0x0005 + +glut_GAME_MODE_WIDTH :: GLenum +glut_GAME_MODE_WIDTH = 0x0002 + +glut_GREEN :: CInt +glut_GREEN = 0x0001 + +glut_HAS_DIAL_AND_BUTTON_BOX :: GLenum +glut_HAS_DIAL_AND_BUTTON_BOX = 0x025B + +glut_HAS_JOYSTICK :: GLenum +glut_HAS_JOYSTICK = 0x0264 + +glut_HAS_KEYBOARD :: GLenum +glut_HAS_KEYBOARD = 0x0258 + +glut_HAS_MOUSE :: GLenum +glut_HAS_MOUSE = 0x0259 + +glut_HAS_OVERLAY :: GLenum +glut_HAS_OVERLAY = 0x0322 + +glut_HAS_SPACEBALL :: GLenum +glut_HAS_SPACEBALL = 0x025A + +glut_HAS_TABLET :: GLenum +glut_HAS_TABLET = 0x025C + +glut_HIDDEN :: CInt +glut_HIDDEN = 0x0000 + +glut_INDEX :: CUInt +glut_INDEX = 0x0001 + +glut_INIT_DISPLAY_MODE :: GLenum +glut_INIT_DISPLAY_MODE = 0x01F8 + +glut_INIT_FLAGS :: GLenum +glut_INIT_FLAGS = 0x0202 + +glut_INIT_MAJOR_VERSION :: GLenum +glut_INIT_MAJOR_VERSION = 0x0200 + +glut_INIT_MINOR_VERSION :: GLenum +glut_INIT_MINOR_VERSION = 0x0201 + +glut_INIT_PROFILE :: GLenum +glut_INIT_PROFILE = 0x0203 + +glut_INIT_STATE :: GLenum +glut_INIT_STATE = 0x007C + +glut_INIT_WINDOW_HEIGHT :: GLenum +glut_INIT_WINDOW_HEIGHT = 0x01F7 + +glut_INIT_WINDOW_WIDTH :: GLenum +glut_INIT_WINDOW_WIDTH = 0x01F6 + +glut_INIT_WINDOW_X :: GLenum +glut_INIT_WINDOW_X = 0x01F4 + +glut_INIT_WINDOW_Y :: GLenum +glut_INIT_WINDOW_Y = 0x01F5 + +glut_JOYSTICK_AXES :: GLenum +glut_JOYSTICK_AXES = 0x0267 + +glut_JOYSTICK_BUTTONS :: GLenum +glut_JOYSTICK_BUTTONS = 0x0266 + +glut_JOYSTICK_BUTTON_A :: CUInt +glut_JOYSTICK_BUTTON_A = 0x0001 + +glut_JOYSTICK_BUTTON_B :: CUInt +glut_JOYSTICK_BUTTON_B = 0x0002 + +glut_JOYSTICK_BUTTON_C :: CUInt +glut_JOYSTICK_BUTTON_C = 0x0004 + +glut_JOYSTICK_BUTTON_D :: CUInt +glut_JOYSTICK_BUTTON_D = 0x0008 + +glut_JOYSTICK_POLL_RATE :: GLenum +glut_JOYSTICK_POLL_RATE = 0x0268 + +glut_KEY_BEGIN :: CInt +glut_KEY_BEGIN = 0x006E + +glut_KEY_DELETE :: CInt +glut_KEY_DELETE = 0x006F + +glut_KEY_DOWN :: CInt +glut_KEY_DOWN = 0x0067 + +glut_KEY_END :: CInt +glut_KEY_END = 0x006B + +glut_KEY_F1 :: CInt +glut_KEY_F1 = 0x0001 + +glut_KEY_F10 :: CInt +glut_KEY_F10 = 0x000A + +glut_KEY_F11 :: CInt +glut_KEY_F11 = 0x000B + +glut_KEY_F12 :: CInt +glut_KEY_F12 = 0x000C + +glut_KEY_F2 :: CInt +glut_KEY_F2 = 0x0002 + +glut_KEY_F3 :: CInt +glut_KEY_F3 = 0x0003 + +glut_KEY_F4 :: CInt +glut_KEY_F4 = 0x0004 + +glut_KEY_F5 :: CInt +glut_KEY_F5 = 0x0005 + +glut_KEY_F6 :: CInt +glut_KEY_F6 = 0x0006 + +glut_KEY_F7 :: CInt +glut_KEY_F7 = 0x0007 + +glut_KEY_F8 :: CInt +glut_KEY_F8 = 0x0008 + +glut_KEY_F9 :: CInt +glut_KEY_F9 = 0x0009 + +glut_KEY_HOME :: CInt +glut_KEY_HOME = 0x006A + +glut_KEY_INSERT :: CInt +glut_KEY_INSERT = 0x006C + +glut_KEY_LEFT :: CInt +glut_KEY_LEFT = 0x0064 + +glut_KEY_NUM_LOCK :: CInt +glut_KEY_NUM_LOCK = 0x006D + +glut_KEY_PAGE_DOWN :: CInt +glut_KEY_PAGE_DOWN = 0x0069 + +glut_KEY_PAGE_UP :: CInt +glut_KEY_PAGE_UP = 0x0068 + +glut_KEY_REPEAT_DEFAULT :: CInt +glut_KEY_REPEAT_DEFAULT = 0x0002 + +glut_KEY_REPEAT_OFF :: CInt +glut_KEY_REPEAT_OFF = 0x0000 + +glut_KEY_REPEAT_ON :: CInt +glut_KEY_REPEAT_ON = 0x0001 + +glut_KEY_RIGHT :: CInt +glut_KEY_RIGHT = 0x0066 + +glut_KEY_UP :: CInt +glut_KEY_UP = 0x0065 + +glut_LAYER_IN_USE :: GLenum +glut_LAYER_IN_USE = 0x0321 + +glut_LEFT :: CInt +glut_LEFT = 0x0000 + +glut_LEFT_BUTTON :: CInt +glut_LEFT_BUTTON = 0x0000 + +glut_LUMINANCE :: CUInt +glut_LUMINANCE = 0x0200 + +glut_MENU_IN_USE :: CInt +glut_MENU_IN_USE = 0x0001 + +glut_MENU_NOT_IN_USE :: CInt +glut_MENU_NOT_IN_USE = 0x0000 + +glut_MENU_NUM_ITEMS :: GLenum +glut_MENU_NUM_ITEMS = 0x012C + +glut_MIDDLE_BUTTON :: CInt +glut_MIDDLE_BUTTON = 0x0001 + +glut_MULTISAMPLE :: CUInt +glut_MULTISAMPLE = 0x0080 + +glut_NORMAL :: GLenum +glut_NORMAL = 0x0000 + +glut_NORMAL_DAMAGED :: GLenum +glut_NORMAL_DAMAGED = 0x0324 + +glut_NOT_VISIBLE :: CInt +glut_NOT_VISIBLE = 0x0000 + +glut_NUM_BUTTON_BOX_BUTTONS :: GLenum +glut_NUM_BUTTON_BOX_BUTTONS = 0x025F + +glut_NUM_DIALS :: GLenum +glut_NUM_DIALS = 0x0260 + +glut_NUM_MOUSE_BUTTONS :: GLenum +glut_NUM_MOUSE_BUTTONS = 0x025D + +glut_NUM_SPACEBALL_BUTTONS :: GLenum +glut_NUM_SPACEBALL_BUTTONS = 0x025E + +glut_NUM_TABLET_BUTTONS :: GLenum +glut_NUM_TABLET_BUTTONS = 0x0261 + +glut_OVERLAY :: GLenum +glut_OVERLAY = 0x0001 + +glut_OVERLAY_DAMAGED :: GLenum +glut_OVERLAY_DAMAGED = 0x0325 + +glut_OVERLAY_POSSIBLE :: GLenum +glut_OVERLAY_POSSIBLE = 0x0320 + +glut_OWNS_JOYSTICK :: GLenum +glut_OWNS_JOYSTICK = 0x0265 + +glut_PARTIALLY_RETAINED :: CInt +glut_PARTIALLY_RETAINED = 0x0002 + +glut_RED :: CInt +glut_RED = 0x0000 + +glut_RENDERING_CONTEXT :: GLenum +glut_RENDERING_CONTEXT = 0x01FD + +glut_RGB :: CUInt +glut_RGB = 0x0000 + +glut_RGBA :: CUInt +glut_RGBA = 0x0000 + +glut_RIGHT_BUTTON :: CInt +glut_RIGHT_BUTTON = 0x0002 + +glut_SCREEN_HEIGHT :: GLenum +glut_SCREEN_HEIGHT = 0x00C9 + +glut_SCREEN_HEIGHT_MM :: GLenum +glut_SCREEN_HEIGHT_MM = 0x00CB + +glut_SCREEN_WIDTH :: GLenum +glut_SCREEN_WIDTH = 0x00C8 + +glut_SCREEN_WIDTH_MM :: GLenum +glut_SCREEN_WIDTH_MM = 0x00CA + +glut_SINGLE :: CUInt +glut_SINGLE = 0x0000 + +glut_SRGB :: CUInt +glut_SRGB = 0x1000 + +glut_STENCIL :: CUInt +glut_STENCIL = 0x0020 + +glut_STEREO :: CUInt +glut_STEREO = 0x0100 + +glut_TRANSPARENT_INDEX :: GLenum +glut_TRANSPARENT_INDEX = 0x0323 + +glut_TRY_DIRECT_CONTEXT :: CInt +glut_TRY_DIRECT_CONTEXT = 2 + +glut_UP :: CInt +glut_UP = 0x0001 + +glut_USE_CURRENT_CONTEXT :: CInt +glut_USE_CURRENT_CONTEXT = 1 + +glut_VERSION :: GLenum +glut_VERSION = 0x01FC + +glut_VIDEO_RESIZE_HEIGHT :: GLenum +glut_VIDEO_RESIZE_HEIGHT = 0x038D + +glut_VIDEO_RESIZE_HEIGHT_DELTA :: GLenum +glut_VIDEO_RESIZE_HEIGHT_DELTA = 0x0389 + +glut_VIDEO_RESIZE_IN_USE :: GLenum +glut_VIDEO_RESIZE_IN_USE = 0x0385 + +glut_VIDEO_RESIZE_POSSIBLE :: GLenum +glut_VIDEO_RESIZE_POSSIBLE = 0x0384 + +glut_VIDEO_RESIZE_WIDTH :: GLenum +glut_VIDEO_RESIZE_WIDTH = 0x038C + +glut_VIDEO_RESIZE_WIDTH_DELTA :: GLenum +glut_VIDEO_RESIZE_WIDTH_DELTA = 0x0388 + +glut_VIDEO_RESIZE_X :: GLenum +glut_VIDEO_RESIZE_X = 0x038A + +glut_VIDEO_RESIZE_X_DELTA :: GLenum +glut_VIDEO_RESIZE_X_DELTA = 0x0386 + +glut_VIDEO_RESIZE_Y :: GLenum +glut_VIDEO_RESIZE_Y = 0x038B + +glut_VIDEO_RESIZE_Y_DELTA :: GLenum +glut_VIDEO_RESIZE_Y_DELTA = 0x0387 + +glut_VISIBLE :: CInt +glut_VISIBLE = 0x0001 + +glut_WINDOW_ACCUM_ALPHA_SIZE :: GLenum +glut_WINDOW_ACCUM_ALPHA_SIZE = 0x0072 + +glut_WINDOW_ACCUM_BLUE_SIZE :: GLenum +glut_WINDOW_ACCUM_BLUE_SIZE = 0x0071 + +glut_WINDOW_ACCUM_GREEN_SIZE :: GLenum +glut_WINDOW_ACCUM_GREEN_SIZE = 0x0070 + +glut_WINDOW_ACCUM_RED_SIZE :: GLenum +glut_WINDOW_ACCUM_RED_SIZE = 0x006F + +glut_WINDOW_ALPHA_SIZE :: GLenum +glut_WINDOW_ALPHA_SIZE = 0x006E + +glut_WINDOW_BLUE_SIZE :: GLenum +glut_WINDOW_BLUE_SIZE = 0x006D + +glut_WINDOW_BORDER_WIDTH :: GLenum +glut_WINDOW_BORDER_WIDTH = 0x01FA + +glut_WINDOW_BUFFER_SIZE :: GLenum +glut_WINDOW_BUFFER_SIZE = 0x0068 + +glut_WINDOW_COLORMAP_SIZE :: GLenum +glut_WINDOW_COLORMAP_SIZE = 0x0077 + +glut_WINDOW_CURSOR :: GLenum +glut_WINDOW_CURSOR = 0x007A + +glut_WINDOW_DEPTH_SIZE :: GLenum +glut_WINDOW_DEPTH_SIZE = 0x006A + +glut_WINDOW_DOUBLEBUFFER :: GLenum +glut_WINDOW_DOUBLEBUFFER = 0x0073 + +glut_WINDOW_FORMAT_ID :: GLenum +glut_WINDOW_FORMAT_ID = 0x007B + +glut_WINDOW_GREEN_SIZE :: GLenum +glut_WINDOW_GREEN_SIZE = 0x006C + +glut_WINDOW_HEADER_HEIGHT :: GLenum +glut_WINDOW_HEADER_HEIGHT = 0x01FB + +glut_WINDOW_HEIGHT :: GLenum +glut_WINDOW_HEIGHT = 0x0067 + +glut_WINDOW_NUM_CHILDREN :: GLenum +glut_WINDOW_NUM_CHILDREN = 0x0076 + +glut_WINDOW_NUM_SAMPLES :: GLenum +glut_WINDOW_NUM_SAMPLES = 0x0078 + +glut_WINDOW_PARENT :: GLenum +glut_WINDOW_PARENT = 0x0075 + +glut_WINDOW_RED_SIZE :: GLenum +glut_WINDOW_RED_SIZE = 0x006B + +glut_WINDOW_RGBA :: GLenum +glut_WINDOW_RGBA = 0x0074 + +glut_WINDOW_STENCIL_SIZE :: GLenum +glut_WINDOW_STENCIL_SIZE = 0x0069 + +glut_WINDOW_STEREO :: GLenum +glut_WINDOW_STEREO = 0x0079 + +glut_WINDOW_WIDTH :: GLenum +glut_WINDOW_WIDTH = 0x0066 + +glut_WINDOW_X :: GLenum +glut_WINDOW_X = 0x0064 + +glut_WINDOW_Y :: GLenum +glut_WINDOW_Y = 0x0065 diff --git a/Graphics/UI/GLUT/State.hs b/Graphics/UI/GLUT/State.hs --- a/Graphics/UI/GLUT/State.hs +++ b/Graphics/UI/GLUT/State.hs @@ -1,382 +1,382 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.State --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- GLUT maintains a considerable amount of programmer visible state. Some (but --- not all) of this state may be directly retrieved. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.State ( - -- * State of all windows - windowBorderWidth, windowHeaderHeight, - - -- * State of the /current window/ - rgba, - BufferDepth, rgbaBufferDepths, colorBufferDepth, - doubleBuffered, stereo, - accumBufferDepths, depthBufferDepth, stencilBufferDepth, - SampleCount, sampleCount, formatID, - fullScreenMode, - - -- * GLUT state pertaining to the layers of the /current window/ - damaged, - - -- * Timing - elapsedTime, - - -- * Device information - - -- $DeviceInformation - screenSize, screenSizeMM, - hasKeyboard, - ButtonCount, numMouseButtons, - numSpaceballButtons, - DialCount, numDialsAndButtons, - numTabletButtons, - AxisCount, PollRate, joystickInfo, - supportedNumAuxBuffers, supportedSamplesPerPixel, - - -- * GLUT information - glutVersion, initState -) where - -import Control.Monad -import Foreign.C.Types -import Foreign.Marshal.Alloc -import Foreign.Marshal.Array -import Foreign.Ptr -import Foreign.Storable -import Graphics.Rendering.OpenGL ( GLenum, Size(..) - , StateVar, makeStateVar - , GettableStateVar, makeGettableStateVar ) -import Graphics.UI.GLUT.Overlay -import Graphics.UI.GLUT.QueryUtils -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.Window - --------------------------------------------------------------------------------- - --- | Contains 'True' when the current layer of the /current window/ is in RGBA --- mode, 'False' means color index mode. - -rgba :: GettableStateVar Bool -rgba = makeGettableStateVar$ simpleGet i2b glut_WINDOW_RGBA - --- | Bit depth of a buffer - -type BufferDepth = Int - --- | Contains the number of red, green, blue, and alpha bits in the color buffer --- of the /current window\'s/ current layer (0 in color index mode). - -rgbaBufferDepths :: - GettableStateVar (BufferDepth, BufferDepth, BufferDepth, BufferDepth) -rgbaBufferDepths = makeGettableStateVar $ do - r <- simpleGet fromIntegral glut_WINDOW_RED_SIZE - g <- simpleGet fromIntegral glut_WINDOW_GREEN_SIZE - b <- simpleGet fromIntegral glut_WINDOW_BLUE_SIZE - a <- simpleGet fromIntegral glut_WINDOW_ALPHA_SIZE - return (r, g, b, a) - --- | Contains the total number of bits in the color buffer of the /current --- window\'s/ current layer. For an RGBA layer, this is the sum of the red, --- green, blue, and alpha bits. For an color index layer, this is the number --- of bits of the color indexes. - -colorBufferDepth :: GettableStateVar BufferDepth -colorBufferDepth = - makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_BUFFER_SIZE - --- | Contains 'True' when the current layer of the /current window/ is double --- buffered, 'False' otherwise. - -doubleBuffered :: GettableStateVar Bool -doubleBuffered = makeGettableStateVar $ simpleGet i2b glut_WINDOW_DOUBLEBUFFER - --- | Contains 'True' when the current layer of the /current window/ is stereo, --- 'False' otherwise. - -stereo :: GettableStateVar Bool -stereo = makeGettableStateVar $ simpleGet i2b glut_WINDOW_STEREO - --- | Contains the number of red, green, blue, and alpha bits in the accumulation --- buffer of the /current window\'s/ current layer (0 in color index mode). - -accumBufferDepths :: - GettableStateVar (BufferDepth, BufferDepth, BufferDepth, BufferDepth) -accumBufferDepths = makeGettableStateVar $ do - r <- simpleGet fromIntegral glut_WINDOW_ACCUM_RED_SIZE - g <- simpleGet fromIntegral glut_WINDOW_ACCUM_GREEN_SIZE - b <- simpleGet fromIntegral glut_WINDOW_ACCUM_BLUE_SIZE - a <- simpleGet fromIntegral glut_WINDOW_ACCUM_ALPHA_SIZE - return (r, g, b, a) - --- | Contains the number of bits in the depth buffer of the /current window\'s/ --- current layer. - -depthBufferDepth :: GettableStateVar BufferDepth -depthBufferDepth = - makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_DEPTH_SIZE - --- | Contains the number of bits in the stencil buffer of the /current --- window\'s/ current layer. - -stencilBufferDepth :: GettableStateVar BufferDepth -stencilBufferDepth = - makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_STENCIL_SIZE - --- | Number of samples for multisampling - -type SampleCount = Int - --- | Contains the number of samples for multisampling for the /current window./ - -sampleCount :: GettableStateVar SampleCount -sampleCount = - makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_NUM_SAMPLES - --- | Contains the window system dependent format ID for the current layer of the --- /current window/. On X11 GLUT implementations, this is the X visual ID. On --- Win32 GLUT implementations, this is the Win32 Pixel Format Descriptor number. --- This value is returned for debugging, benchmarking, and testing ease. - -formatID :: GettableStateVar Int -formatID = makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_FORMAT_ID - --------------------------------------------------------------------------------- - --- | (/freeglut only/) Contains 'True' if the /current window/ is in full screen --- mode, 'False' otherwise. - -fullScreenMode :: StateVar Bool -fullScreenMode = makeStateVar getFullScreenMode setFullScreenMode - -getFullScreenMode :: IO Bool -getFullScreenMode = simpleGet i2b glut_FULL_SCREEN - -setFullScreenMode :: Bool -> IO () -setFullScreenMode newMode = do - oldMode <- getFullScreenMode - unless (newMode == oldMode) fullScreenToggle - --------------------------------------------------------------------------------- - --- | Contains the number of milliseconds since --- 'Graphics.UI.GLUT.Initialization.initialize' was called. - -elapsedTime :: GettableStateVar Int -elapsedTime = makeGettableStateVar $ simpleGet fromIntegral glut_ELAPSED_TIME - --------------------------------------------------------------------------------- - --- | Contains 'True' if the given plane of the /current window/ has been --- damaged (by window system activity) since the last display callback was --- triggered. Calling 'Graphics.UI.GLUT.Window.postRedisplay' or --- 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay' will not set this 'True'. - -damaged :: Layer -> GettableStateVar Bool -damaged l = makeGettableStateVar $ layerGet isDamaged (marshalDamagedLayer l) - where isDamaged d = d /= 0 && d /= -1 - marshalDamagedLayer x = case x of - Normal -> glut_NORMAL_DAMAGED - Overlay -> glut_OVERLAY_DAMAGED - --------------------------------------------------------------------------------- - --- $DeviceInformation --- If a device is not available, the following state variables contain --- 'Nothing', otherwise they return 'Just' the specific device information. --- Only a screen is always assumed. - --------------------------------------------------------------------------------- - --- | The size of the screen in pixels. - -screenSize :: GettableStateVar Size -screenSize = - makeGettableStateVar $ do - wpx <- simpleGet fromIntegral glut_SCREEN_WIDTH - hpx <- simpleGet fromIntegral glut_SCREEN_HEIGHT - return $ Size wpx hpx - --- | The size of the screen in millimeters. - -screenSizeMM :: GettableStateVar Size -screenSizeMM = - makeGettableStateVar $ do - wmm <- simpleGet fromIntegral glut_SCREEN_WIDTH_MM - hmm <- simpleGet fromIntegral glut_SCREEN_HEIGHT_MM - return $ Size wmm hmm - --------------------------------------------------------------------------------- - --- | Contains 'True' if a keyboard is present, 'False' otherwise. - -hasKeyboard :: GettableStateVar Bool -hasKeyboard = makeGettableStateVar $ deviceGet i2b glut_HAS_KEYBOARD - --------------------------------------------------------------------------------- - --- | Number of buttons of an input device - -type ButtonCount = Int - --- | Contains 'Just' the number of buttons of an attached mouse or 'Nothing' if --- there is none. - -numMouseButtons :: GettableStateVar (Maybe ButtonCount) -numMouseButtons = - getDeviceInfo glut_HAS_MOUSE $ - deviceGet fromIntegral glut_NUM_MOUSE_BUTTONS - --------------------------------------------------------------------------------- - --- | Contains 'Just' the number of buttons of the attached Spaceball or 'Nothing' --- if there is none. - -numSpaceballButtons :: GettableStateVar (Maybe ButtonCount) -numSpaceballButtons = - getDeviceInfo glut_HAS_SPACEBALL $ - deviceGet fromIntegral glut_NUM_SPACEBALL_BUTTONS - --------------------------------------------------------------------------------- - --- | Number of dials of a dial and button box - -type DialCount = Int - --- | Contains 'Just' the number of dials and buttons of an attached dial & --- button box or 'Nothing' if there is none. - -numDialsAndButtons :: GettableStateVar (Maybe (DialCount, ButtonCount)) -numDialsAndButtons = - getDeviceInfo glut_HAS_DIAL_AND_BUTTON_BOX $ do - d <- deviceGet fromIntegral glut_NUM_DIALS - b <- deviceGet fromIntegral glut_NUM_BUTTON_BOX_BUTTONS - return (d, b) - --------------------------------------------------------------------------------- - --- | Contains 'Just' the number of buttons of an attached tablet or 'Nothing' if --- there is none. - -numTabletButtons :: GettableStateVar (Maybe ButtonCount) -numTabletButtons = - getDeviceInfo glut_HAS_TABLET $ - deviceGet fromIntegral glut_NUM_TABLET_BUTTONS - --------------------------------------------------------------------------------- - --- | Number of axes of a joystick - -type AxisCount = Int - --- | The a rate at which a joystick is polled (in milliseconds) - -type PollRate = Int - --- | Contains 'Just' the number of buttons of an attached joystick, the number --- of joystick axes, and the rate at which the joystick is polled. Contains --- 'Nothing' if there is no joystick attached. - -joystickInfo :: GettableStateVar (Maybe (ButtonCount, PollRate, AxisCount)) -joystickInfo = - getDeviceInfo glut_HAS_JOYSTICK $ do - b <- deviceGet fromIntegral glut_JOYSTICK_BUTTONS - a <- deviceGet fromIntegral glut_JOYSTICK_AXES - r <- deviceGet fromIntegral glut_JOYSTICK_POLL_RATE - return (b, a, r) - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Contains a list of the number of auxiliary buffers --- supported, in increasing order. - -supportedNumAuxBuffers :: GettableStateVar [Int] -supportedNumAuxBuffers = getModeValues glut_AUX - --- | (/freeglut only/) Contains a list of the number of samples per pixel --- supported for multisampling, in increasing order. - -supportedSamplesPerPixel :: GettableStateVar [SampleCount] -supportedSamplesPerPixel = getModeValues (fromIntegral glut_MULTISAMPLE) - -getModeValues :: Integral a => GLenum -> GettableStateVar [a] -getModeValues what = makeGettableStateVar $ - alloca $ \sizeBuffer -> do - valuesBuffer <- glutGetModeValues what sizeBuffer - size <- peek sizeBuffer - fmap (map fromIntegral) $ peekArray (fromIntegral size) valuesBuffer - --------------------------------------------------------------------------------- --- Convenience unmarshalers - -i2b :: CInt -> Bool -i2b = (/= 0) - --------------------------------------------------------------------------------- - -getDeviceInfo :: GLenum -> IO a -> GettableStateVar (Maybe a) -getDeviceInfo dev act = - makeGettableStateVar $ do - hasDevice <- deviceGet i2b dev - if hasDevice then fmap Just act else return Nothing - ------------------------------------------------------------------------------ - --- | Contains version of GLUT in the form of --- @/flavour/ /major/./minor/./patchlevel/@, where @/flavour/@ is one of --- @GLUT@, @freeglut@ or @OpenGLUT@. - -glutVersion :: GettableStateVar String -glutVersion = makeGettableStateVar $ do - let isGLUT = isUnknown "glutSetOption" - isFreeglut = isUnknown "glutSetWindowStayOnTop" - isUnknown = fmap (== nullFunPtr) . getAPIEntryInternal - showVersionPart x = shows (x `mod` 100) - showVersion v = showVersionPart (v `div` 10000) . showChar '.' . - showVersionPart (v `div` 100) . showChar '.' . - showVersionPart v - g <- isGLUT - if g - then return "GLUT 3.7" -- ToDo: just guessing - else do f <- isFreeglut - v <- simpleGet id glut_VERSION - let prefix = if f then "freeglut" else "OpenGLUT" - return $ showString prefix . showChar ' ' . showVersion v $ "" - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Contains the thickness of the sizing border around the --- perimeter of a window that can be resized, in pixels. - -windowBorderWidth :: GettableStateVar Int -windowBorderWidth = - makeGettableStateVar (simpleGet fromIntegral glut_WINDOW_BORDER_WIDTH) - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Contains the height of the header\/caption area of a --- window in pixels. - -windowHeaderHeight :: GettableStateVar Int -windowHeaderHeight = - makeGettableStateVar (simpleGet fromIntegral glut_WINDOW_HEADER_HEIGHT) - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Contains 'True' if GLUT has been initialized --- with 'Graphics.UI.GLUT.Initialization.initialize' or --- 'Graphics.UI.GLUT.Initialization.getArgsAndInitialize' has and not yet --- been de-initialized with 'Graphics.UI.GLUT.Initialization.exit'. Contains --- 'False' otherwise. - -initState :: GettableStateVar Bool -initState = makeGettableStateVar$ simpleGet i2b glut_INIT_STATE +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.State +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- GLUT maintains a considerable amount of programmer visible state. Some (but +-- not all) of this state may be directly retrieved. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.State ( + -- * State of all windows + windowBorderWidth, windowHeaderHeight, + + -- * State of the /current window/ + rgba, + BufferDepth, rgbaBufferDepths, colorBufferDepth, + doubleBuffered, stereo, + accumBufferDepths, depthBufferDepth, stencilBufferDepth, + SampleCount, sampleCount, formatID, + fullScreenMode, + + -- * GLUT state pertaining to the layers of the /current window/ + damaged, + + -- * Timing + elapsedTime, + + -- * Device information + + -- $DeviceInformation + screenSize, screenSizeMM, + hasKeyboard, + ButtonCount, numMouseButtons, + numSpaceballButtons, + DialCount, numDialsAndButtons, + numTabletButtons, + AxisCount, PollRate, joystickInfo, + supportedNumAuxBuffers, supportedSamplesPerPixel, + + -- * GLUT information + glutVersion, initState +) where + +import Control.Monad +import Foreign.C.Types +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable +import Graphics.Rendering.OpenGL ( GLenum, Size(..) + , StateVar, makeStateVar + , GettableStateVar, makeGettableStateVar ) +import Graphics.UI.GLUT.Overlay +import Graphics.UI.GLUT.QueryUtils +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.Window + +-------------------------------------------------------------------------------- + +-- | Contains 'True' when the current layer of the /current window/ is in RGBA +-- mode, 'False' means color index mode. + +rgba :: GettableStateVar Bool +rgba = makeGettableStateVar$ simpleGet i2b glut_WINDOW_RGBA + +-- | Bit depth of a buffer + +type BufferDepth = Int + +-- | Contains the number of red, green, blue, and alpha bits in the color buffer +-- of the /current window\'s/ current layer (0 in color index mode). + +rgbaBufferDepths :: + GettableStateVar (BufferDepth, BufferDepth, BufferDepth, BufferDepth) +rgbaBufferDepths = makeGettableStateVar $ do + r <- simpleGet fromIntegral glut_WINDOW_RED_SIZE + g <- simpleGet fromIntegral glut_WINDOW_GREEN_SIZE + b <- simpleGet fromIntegral glut_WINDOW_BLUE_SIZE + a <- simpleGet fromIntegral glut_WINDOW_ALPHA_SIZE + return (r, g, b, a) + +-- | Contains the total number of bits in the color buffer of the /current +-- window\'s/ current layer. For an RGBA layer, this is the sum of the red, +-- green, blue, and alpha bits. For an color index layer, this is the number +-- of bits of the color indexes. + +colorBufferDepth :: GettableStateVar BufferDepth +colorBufferDepth = + makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_BUFFER_SIZE + +-- | Contains 'True' when the current layer of the /current window/ is double +-- buffered, 'False' otherwise. + +doubleBuffered :: GettableStateVar Bool +doubleBuffered = makeGettableStateVar $ simpleGet i2b glut_WINDOW_DOUBLEBUFFER + +-- | Contains 'True' when the current layer of the /current window/ is stereo, +-- 'False' otherwise. + +stereo :: GettableStateVar Bool +stereo = makeGettableStateVar $ simpleGet i2b glut_WINDOW_STEREO + +-- | Contains the number of red, green, blue, and alpha bits in the accumulation +-- buffer of the /current window\'s/ current layer (0 in color index mode). + +accumBufferDepths :: + GettableStateVar (BufferDepth, BufferDepth, BufferDepth, BufferDepth) +accumBufferDepths = makeGettableStateVar $ do + r <- simpleGet fromIntegral glut_WINDOW_ACCUM_RED_SIZE + g <- simpleGet fromIntegral glut_WINDOW_ACCUM_GREEN_SIZE + b <- simpleGet fromIntegral glut_WINDOW_ACCUM_BLUE_SIZE + a <- simpleGet fromIntegral glut_WINDOW_ACCUM_ALPHA_SIZE + return (r, g, b, a) + +-- | Contains the number of bits in the depth buffer of the /current window\'s/ +-- current layer. + +depthBufferDepth :: GettableStateVar BufferDepth +depthBufferDepth = + makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_DEPTH_SIZE + +-- | Contains the number of bits in the stencil buffer of the /current +-- window\'s/ current layer. + +stencilBufferDepth :: GettableStateVar BufferDepth +stencilBufferDepth = + makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_STENCIL_SIZE + +-- | Number of samples for multisampling + +type SampleCount = Int + +-- | Contains the number of samples for multisampling for the /current window./ + +sampleCount :: GettableStateVar SampleCount +sampleCount = + makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_NUM_SAMPLES + +-- | Contains the window system dependent format ID for the current layer of the +-- /current window/. On X11 GLUT implementations, this is the X visual ID. On +-- Win32 GLUT implementations, this is the Win32 Pixel Format Descriptor number. +-- This value is returned for debugging, benchmarking, and testing ease. + +formatID :: GettableStateVar Int +formatID = makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_FORMAT_ID + +-------------------------------------------------------------------------------- + +-- | (/freeglut only/) Contains 'True' if the /current window/ is in full screen +-- mode, 'False' otherwise. + +fullScreenMode :: StateVar Bool +fullScreenMode = makeStateVar getFullScreenMode setFullScreenMode + +getFullScreenMode :: IO Bool +getFullScreenMode = simpleGet i2b glut_FULL_SCREEN + +setFullScreenMode :: Bool -> IO () +setFullScreenMode newMode = do + oldMode <- getFullScreenMode + unless (newMode == oldMode) fullScreenToggle + +-------------------------------------------------------------------------------- + +-- | Contains the number of milliseconds since +-- 'Graphics.UI.GLUT.Initialization.initialize' was called. + +elapsedTime :: GettableStateVar Int +elapsedTime = makeGettableStateVar $ simpleGet fromIntegral glut_ELAPSED_TIME + +-------------------------------------------------------------------------------- + +-- | Contains 'True' if the given plane of the /current window/ has been +-- damaged (by window system activity) since the last display callback was +-- triggered. Calling 'Graphics.UI.GLUT.Window.postRedisplay' or +-- 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay' will not set this 'True'. + +damaged :: Layer -> GettableStateVar Bool +damaged l = makeGettableStateVar $ layerGet isDamaged (marshalDamagedLayer l) + where isDamaged d = d /= 0 && d /= -1 + marshalDamagedLayer x = case x of + Normal -> glut_NORMAL_DAMAGED + Overlay -> glut_OVERLAY_DAMAGED + +-------------------------------------------------------------------------------- + +-- $DeviceInformation +-- If a device is not available, the following state variables contain +-- 'Nothing', otherwise they return 'Just' the specific device information. +-- Only a screen is always assumed. + +-------------------------------------------------------------------------------- + +-- | The size of the screen in pixels. + +screenSize :: GettableStateVar Size +screenSize = + makeGettableStateVar $ do + wpx <- simpleGet fromIntegral glut_SCREEN_WIDTH + hpx <- simpleGet fromIntegral glut_SCREEN_HEIGHT + return $ Size wpx hpx + +-- | The size of the screen in millimeters. + +screenSizeMM :: GettableStateVar Size +screenSizeMM = + makeGettableStateVar $ do + wmm <- simpleGet fromIntegral glut_SCREEN_WIDTH_MM + hmm <- simpleGet fromIntegral glut_SCREEN_HEIGHT_MM + return $ Size wmm hmm + +-------------------------------------------------------------------------------- + +-- | Contains 'True' if a keyboard is present, 'False' otherwise. + +hasKeyboard :: GettableStateVar Bool +hasKeyboard = makeGettableStateVar $ deviceGet i2b glut_HAS_KEYBOARD + +-------------------------------------------------------------------------------- + +-- | Number of buttons of an input device + +type ButtonCount = Int + +-- | Contains 'Just' the number of buttons of an attached mouse or 'Nothing' if +-- there is none. + +numMouseButtons :: GettableStateVar (Maybe ButtonCount) +numMouseButtons = + getDeviceInfo glut_HAS_MOUSE $ + deviceGet fromIntegral glut_NUM_MOUSE_BUTTONS + +-------------------------------------------------------------------------------- + +-- | Contains 'Just' the number of buttons of the attached Spaceball or 'Nothing' +-- if there is none. + +numSpaceballButtons :: GettableStateVar (Maybe ButtonCount) +numSpaceballButtons = + getDeviceInfo glut_HAS_SPACEBALL $ + deviceGet fromIntegral glut_NUM_SPACEBALL_BUTTONS + +-------------------------------------------------------------------------------- + +-- | Number of dials of a dial and button box + +type DialCount = Int + +-- | Contains 'Just' the number of dials and buttons of an attached dial & +-- button box or 'Nothing' if there is none. + +numDialsAndButtons :: GettableStateVar (Maybe (DialCount, ButtonCount)) +numDialsAndButtons = + getDeviceInfo glut_HAS_DIAL_AND_BUTTON_BOX $ do + d <- deviceGet fromIntegral glut_NUM_DIALS + b <- deviceGet fromIntegral glut_NUM_BUTTON_BOX_BUTTONS + return (d, b) + +-------------------------------------------------------------------------------- + +-- | Contains 'Just' the number of buttons of an attached tablet or 'Nothing' if +-- there is none. + +numTabletButtons :: GettableStateVar (Maybe ButtonCount) +numTabletButtons = + getDeviceInfo glut_HAS_TABLET $ + deviceGet fromIntegral glut_NUM_TABLET_BUTTONS + +-------------------------------------------------------------------------------- + +-- | Number of axes of a joystick + +type AxisCount = Int + +-- | The a rate at which a joystick is polled (in milliseconds) + +type PollRate = Int + +-- | Contains 'Just' the number of buttons of an attached joystick, the number +-- of joystick axes, and the rate at which the joystick is polled. Contains +-- 'Nothing' if there is no joystick attached. + +joystickInfo :: GettableStateVar (Maybe (ButtonCount, PollRate, AxisCount)) +joystickInfo = + getDeviceInfo glut_HAS_JOYSTICK $ do + b <- deviceGet fromIntegral glut_JOYSTICK_BUTTONS + a <- deviceGet fromIntegral glut_JOYSTICK_AXES + r <- deviceGet fromIntegral glut_JOYSTICK_POLL_RATE + return (b, a, r) + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Contains a list of the number of auxiliary buffers +-- supported, in increasing order. + +supportedNumAuxBuffers :: GettableStateVar [Int] +supportedNumAuxBuffers = getModeValues glut_AUX + +-- | (/freeglut only/) Contains a list of the number of samples per pixel +-- supported for multisampling, in increasing order. + +supportedSamplesPerPixel :: GettableStateVar [SampleCount] +supportedSamplesPerPixel = getModeValues (fromIntegral glut_MULTISAMPLE) + +getModeValues :: Integral a => GLenum -> GettableStateVar [a] +getModeValues what = makeGettableStateVar $ + alloca $ \sizeBuffer -> do + valuesBuffer <- glutGetModeValues what sizeBuffer + size <- peek sizeBuffer + fmap (map fromIntegral) $ peekArray (fromIntegral size) valuesBuffer + +-------------------------------------------------------------------------------- +-- Convenience unmarshalers + +i2b :: CInt -> Bool +i2b = (/= 0) + +-------------------------------------------------------------------------------- + +getDeviceInfo :: GLenum -> IO a -> GettableStateVar (Maybe a) +getDeviceInfo dev act = + makeGettableStateVar $ do + hasDevice <- deviceGet i2b dev + if hasDevice then fmap Just act else return Nothing + +----------------------------------------------------------------------------- + +-- | Contains version of GLUT in the form of +-- @/flavour/ /major/./minor/./patchlevel/@, where @/flavour/@ is one of +-- @GLUT@, @freeglut@ or @OpenGLUT@. + +glutVersion :: GettableStateVar String +glutVersion = makeGettableStateVar $ do + let isGLUT = isUnknown "glutSetOption" + isFreeglut = isUnknown "glutSetWindowStayOnTop" + isUnknown = fmap (== nullFunPtr) . getAPIEntryInternal + showVersionPart x = shows (x `mod` 100) + showVersion v = showVersionPart (v `div` 10000) . showChar '.' . + showVersionPart (v `div` 100) . showChar '.' . + showVersionPart v + g <- isGLUT + if g + then return "GLUT 3.7" -- ToDo: just guessing + else do f <- isFreeglut + v <- simpleGet id glut_VERSION + let prefix = if f then "freeglut" else "OpenGLUT" + return $ showString prefix . showChar ' ' . showVersion v $ "" + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Contains the thickness of the sizing border around the +-- perimeter of a window that can be resized, in pixels. + +windowBorderWidth :: GettableStateVar Int +windowBorderWidth = + makeGettableStateVar (simpleGet fromIntegral glut_WINDOW_BORDER_WIDTH) + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Contains the height of the header\/caption area of a +-- window in pixels. + +windowHeaderHeight :: GettableStateVar Int +windowHeaderHeight = + makeGettableStateVar (simpleGet fromIntegral glut_WINDOW_HEADER_HEIGHT) + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Contains 'True' if GLUT has been initialized +-- with 'Graphics.UI.GLUT.Initialization.initialize' or +-- 'Graphics.UI.GLUT.Initialization.getArgsAndInitialize' has and not yet +-- been de-initialized with 'Graphics.UI.GLUT.Initialization.exit'. Contains +-- 'False' otherwise. + +initState :: GettableStateVar Bool +initState = makeGettableStateVar$ simpleGet i2b glut_INIT_STATE diff --git a/Graphics/UI/GLUT/Types.hs b/Graphics/UI/GLUT/Types.hs --- a/Graphics/UI/GLUT/Types.hs +++ b/Graphics/UI/GLUT/Types.hs @@ -1,104 +1,104 @@ -{-# OPTIONS_HADDOCK hide #-} --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Types --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- This is a purely internal module with miscellaneous types which don\'t really --- have a good place elsewhere. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Types ( - Window(..), -- constructor used only internally - Relation(..), - relationToString, -- used only internally - MouseButton(..), - marshalMouseButton, unmarshalMouseButton -- used only internally -) where - -import Foreign.C.Types -import Graphics.UI.GLUT.Raw - --------------------------------------------------------------------------------- - --- | An opaque identifier for a top-level window or a subwindow. - -newtype Window = Window CInt - deriving ( Eq, Ord, Show ) - --------------------------------------------------------------------------------- - --- | A relation between a 'Graphics.UI.GLUT.Initialization.DisplayCapability' --- and a numeric value. - -data Relation - = IsEqualTo -- ^ Equal. - | IsNotEqualTo -- ^ Not equal. - | IsLessThan -- ^ Less than and preferring larger difference (the least - -- is best). - | IsNotGreaterThan -- ^ Less than or equal and preferring larger difference - -- (the least is best). - | IsGreaterThan -- ^ Greater than and preferring larger differences (the - -- most is best). - | IsAtLeast -- ^ Greater than or equal and preferring more instead of - -- less. This relation is useful for allocating - -- resources like color precision or depth buffer - -- precision where the maximum precision is generally - -- preferred. Contrast with 'IsNotLessThan' relation. - | IsNotLessThan -- ^ Greater than or equal but preferring less instead of - -- more. This relation is useful for allocating - -- resources such as stencil bits or auxillary color - -- buffers where you would rather not over-allocate. - deriving ( Eq, Ord, Show ) - -relationToString :: Relation -> String -relationToString IsEqualTo = "=" -relationToString IsNotEqualTo = "!=" -relationToString IsLessThan = "<" -relationToString IsNotGreaterThan = "<=" -relationToString IsGreaterThan = ">" -relationToString IsAtLeast = ">=" -relationToString IsNotLessThan = "~" - --------------------------------------------------------------------------------- - --- | Mouse buttons, including a wheel - -data MouseButton - = LeftButton - | MiddleButton - | RightButton - | WheelUp - | WheelDown - | AdditionalButton Int - deriving ( Eq, Ord, Show ) - -marshalMouseButton :: MouseButton -> CInt -marshalMouseButton x = case x of - LeftButton -> glut_LEFT_BUTTON - MiddleButton -> glut_MIDDLE_BUTTON - RightButton -> glut_RIGHT_BUTTON - WheelUp -> glut_WHEEL_UP - WheelDown -> glut_WHEEL_DOWN - AdditionalButton b -> fromIntegral b - -unmarshalMouseButton :: CInt -> MouseButton -unmarshalMouseButton x - | x == glut_LEFT_BUTTON = LeftButton - | x == glut_MIDDLE_BUTTON = MiddleButton - | x == glut_RIGHT_BUTTON = RightButton - | x == glut_WHEEL_UP = WheelUp - | x == glut_WHEEL_DOWN = WheelDown - | otherwise = AdditionalButton (fromIntegral x) - -glut_WHEEL_UP :: CInt -glut_WHEEL_UP = 3 - -glut_WHEEL_DOWN :: CInt -glut_WHEEL_DOWN = 4 +{-# OPTIONS_HADDOCK hide #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Types +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- This is a purely internal module with miscellaneous types which don\'t really +-- have a good place elsewhere. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Types ( + Window(..), -- constructor used only internally + Relation(..), + relationToString, -- used only internally + MouseButton(..), + marshalMouseButton, unmarshalMouseButton -- used only internally +) where + +import Foreign.C.Types +import Graphics.UI.GLUT.Raw + +-------------------------------------------------------------------------------- + +-- | An opaque identifier for a top-level window or a subwindow. + +newtype Window = Window CInt + deriving ( Eq, Ord, Show ) + +-------------------------------------------------------------------------------- + +-- | A relation between a 'Graphics.UI.GLUT.Initialization.DisplayCapability' +-- and a numeric value. + +data Relation + = IsEqualTo -- ^ Equal. + | IsNotEqualTo -- ^ Not equal. + | IsLessThan -- ^ Less than and preferring larger difference (the least + -- is best). + | IsNotGreaterThan -- ^ Less than or equal and preferring larger difference + -- (the least is best). + | IsGreaterThan -- ^ Greater than and preferring larger differences (the + -- most is best). + | IsAtLeast -- ^ Greater than or equal and preferring more instead of + -- less. This relation is useful for allocating + -- resources like color precision or depth buffer + -- precision where the maximum precision is generally + -- preferred. Contrast with 'IsNotLessThan' relation. + | IsNotLessThan -- ^ Greater than or equal but preferring less instead of + -- more. This relation is useful for allocating + -- resources such as stencil bits or auxillary color + -- buffers where you would rather not over-allocate. + deriving ( Eq, Ord, Show ) + +relationToString :: Relation -> String +relationToString IsEqualTo = "=" +relationToString IsNotEqualTo = "!=" +relationToString IsLessThan = "<" +relationToString IsNotGreaterThan = "<=" +relationToString IsGreaterThan = ">" +relationToString IsAtLeast = ">=" +relationToString IsNotLessThan = "~" + +-------------------------------------------------------------------------------- + +-- | Mouse buttons, including a wheel + +data MouseButton + = LeftButton + | MiddleButton + | RightButton + | WheelUp + | WheelDown + | AdditionalButton Int + deriving ( Eq, Ord, Show ) + +marshalMouseButton :: MouseButton -> CInt +marshalMouseButton x = case x of + LeftButton -> glut_LEFT_BUTTON + MiddleButton -> glut_MIDDLE_BUTTON + RightButton -> glut_RIGHT_BUTTON + WheelUp -> glut_WHEEL_UP + WheelDown -> glut_WHEEL_DOWN + AdditionalButton b -> fromIntegral b + +unmarshalMouseButton :: CInt -> MouseButton +unmarshalMouseButton x + | x == glut_LEFT_BUTTON = LeftButton + | x == glut_MIDDLE_BUTTON = MiddleButton + | x == glut_RIGHT_BUTTON = RightButton + | x == glut_WHEEL_UP = WheelUp + | x == glut_WHEEL_DOWN = WheelDown + | otherwise = AdditionalButton (fromIntegral x) + +glut_WHEEL_UP :: CInt +glut_WHEEL_UP = 3 + +glut_WHEEL_DOWN :: CInt +glut_WHEEL_DOWN = 4 diff --git a/Graphics/UI/GLUT/Window.hs b/Graphics/UI/GLUT/Window.hs --- a/Graphics/UI/GLUT/Window.hs +++ b/Graphics/UI/GLUT/Window.hs @@ -1,494 +1,494 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Window --- Copyright : (c) Sven Panne 2002-2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- GLUT supports two types of windows: top-level windows and subwindows. Both --- types support OpenGL rendering and GLUT callbacks. There is a single --- identifier space for both types of windows. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Window ( - -- * Window identifiers - Window, - - -- * Creating and destroying (sub-)windows - - -- $CreatingAndDestroyingSubWindows - createWindow, createSubWindow, destroyWindow, - parentWindow, numSubWindows, - - -- * Manipulating the /current window/ - currentWindow, - - -- * Re-displaying and double buffer management - postRedisplay, swapBuffers, - - -- * Changing the window geometry - - -- $ChangingTheWindowGeometry - windowPosition, windowSize, fullScreen, fullScreenToggle, - - -- * Manipulating the stacking order - - -- $ManipulatingTheStackingOrder - pushWindow, popWindow, - - -- * Managing a window\'s display status - WindowStatus(..), windowStatus, - - -- * Changing the window\/icon title - - -- $ChangingTheWindowIconTitle - windowTitle, iconTitle, - - -- * Cursor management - Cursor(..), cursor, pointerPosition -) where - -import Foreign.C.String -import Foreign.C.Types -import Graphics.Rendering.OpenGL ( Position(..), Size(..) - , StateVar, makeStateVar - , GettableStateVar, makeGettableStateVar - , SettableStateVar, makeSettableStateVar ) -import Graphics.UI.GLUT.QueryUtils -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.Types - --------------------------------------------------------------------------------- - --- $CreatingAndDestroyingSubWindows --- Each created window has a unique associated OpenGL context. State changes to --- a window\'s associated OpenGL context can be done immediately after the --- window is created. --- --- The /display state/ of a window is initially for the window to be shown. But --- the window\'s /display state/ is not actually acted upon until --- 'Graphics.UI.GLUT.Begin.mainLoop' is entered. This means until --- 'Graphics.UI.GLUT.Begin.mainLoop' is called, rendering to a created window is --- ineffective because the window can not yet be displayed. --- --- The value returned by 'createWindow' and 'createSubWindow' is a unique --- identifier for the window, which can be used with 'currentWindow'. - --- | Create a top-level window. The given name will be provided to the window --- system as the window\'s name. The intent is that the window system will label --- the window with the name.Implicitly, the /current window/ is set to the newly --- created window. --- --- /X Implementation Notes:/ The proper X Inter-Client Communication Conventions --- Manual (ICCCM) top-level properties are established. The @WM_COMMAND@ --- property that lists the command line used to invoke the GLUT program is only --- established for the first window created. - -createWindow - :: String -- ^ The window name - -> IO Window -- ^ The identifier for the newly created window -createWindow name = fmap Window $ withCString name glutCreateWindow - --------------------------------------------------------------------------------- - --- | Create a subwindow of the identified window with the given relative --- position and size. Implicitly, the /current window/ is set to the --- newly created subwindow. Subwindows can be nested arbitrarily deep. - -createSubWindow - :: Window -- ^ Identifier of the subwindow\'s parent window. - -> Position -- ^ Window position in pixels relative to parent window\'s - -- origin. - -> Size -- ^ Window size in pixels - -> IO Window -- ^ The identifier for the newly created subwindow -createSubWindow (Window win) (Position x y) (Size w h) = - fmap Window $ - glutCreateSubWindow win - (fromIntegral x) (fromIntegral y) - (fromIntegral w) (fromIntegral h) - --------------------------------------------------------------------------------- - --- | Contains the /current window\'s/ parent. If the /current window/ is a --- top-level window, 'Nothing' is returned. - -parentWindow :: GettableStateVar (Maybe Window) -parentWindow = - makeGettableStateVar $ - getWindow (simpleGet Window glut_WINDOW_PARENT) - --------------------------------------------------------------------------------- - --- | Contains the number of subwindows the /current window/ has, not counting --- children of children. - -numSubWindows :: GettableStateVar Int -numSubWindows = - makeGettableStateVar $ - simpleGet fromIntegral glut_WINDOW_NUM_CHILDREN - --------------------------------------------------------------------------------- - --- | Destroy the specified window and the window\'s associated OpenGL context, --- logical colormap (if the window is color index), and overlay and related --- state (if an overlay has been established). Any subwindows of the destroyed --- window are also destroyed by 'destroyWindow'. If the specified window was the --- /current window/, the /current window/ becomes invalid ('currentWindow' will --- contain 'Nothing'). - -destroyWindow :: Window -> IO () -destroyWindow (Window win) = glutDestroyWindow win - --------------------------------------------------------------------------------- - --- | Controls the /current window/. It does /not/ affect the /layer in use/ for --- the window; this is done using 'Graphics.UI.GLUT.Overlay.layerInUse'. --- Contains 'Nothing' if no windows exist or the previously /current window/ was --- destroyed. Setting the /current window/ to 'Nothing' is a no-op. - -currentWindow :: StateVar (Maybe Window) -currentWindow = - makeStateVar - (getWindow (fmap Window glutGetWindow)) - (maybe (return ()) (\(Window win) -> glutSetWindow win)) - -getWindow :: IO Window -> IO (Maybe Window) -getWindow act = do - win <- act - return $ if win == Window 0 then Nothing else Just win - --------------------------------------------------------------------------------- - --- | Mark the normal plane of given window (or the /current window/, if none --- is supplied) as needing to be redisplayed. The next iteration through --- 'Graphics.UI.GLUT.Begin.mainLoop', the window\'s display callback will be --- called to redisplay the window\'s normal plane. Multiple calls to --- 'postRedisplay' before the next display callback opportunity generates only a --- single redisplay callback. 'postRedisplay' may be called within a window\'s --- display or overlay display callback to re-mark that window for redisplay. --- --- Logically, normal plane damage notification for a window is treated as a --- 'postRedisplay' on the damaged window. Unlike damage reported by the window --- system, 'postRedisplay' will /not/ set to true the normal plane\'s damaged --- status (see 'Graphics.UI.GLUT.State.damaged'). --- --- Also, see 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay'. - -postRedisplay :: Maybe Window -> IO () -postRedisplay = maybe glutPostRedisplay (\(Window win) -> glutPostWindowRedisplay win) - --- | Mark the normal plane of the given window as needing to be redisplayed, --- otherwise the same as 'postRedisplay'. --- --- The advantage of this routine is that it saves the cost of using --- 'currentWindow' (entailing an expensive OpenGL context switch), which is --- particularly useful when multiple windows need redisplays posted at the same --- time. - --------------------------------------------------------------------------------- - --- | Perform a buffer swap on the /layer in use/ for the /current window/. --- Specifically, 'swapBuffers' promotes the contents of the back buffer of the --- /layer in use/ of the /current window/ to become the contents of the front --- buffer. The contents of the back buffer then become undefined. The update --- typically takes place during the vertical retrace of the monitor, rather than --- immediately after 'swapBuffers' is called. --- --- An implicit 'Graphics.Rendering.OpenGL.GL.FlushFinish.flush' is done by --- 'swapBuffers' before it returns. Subsequent OpenGL commands can be issued --- immediately after calling 'swapBuffers', but are not executed until the --- buffer exchange is completed. --- --- If the /layer in use/ is not double buffered, 'swapBuffers' has no effect. - -swapBuffers :: IO () -swapBuffers = glutSwapBuffers - --------------------------------------------------------------------------------- - --- $ChangingTheWindowGeometry --- Note that the requests by 'windowPosition', 'windowSize', and 'fullScreen' --- are not processed immediately. A request is executed after returning to the --- main event loop. This allows multiple requests to the same window to be --- coalesced. --- --- 'windowPosition' and 'windowSize' requests on a window will disable the full --- screen status of the window. - --------------------------------------------------------------------------------- - --- | Controls the position of the /current window/. For top-level windows, --- parameters of 'Position' are pixel offsets from the screen origin. For --- subwindows, the parameters are pixel offsets from the window\'s parent window --- origin. --- --- In the case of top-level windows, setting 'windowPosition' is considered only --- a request for positioning the window. The window system is free to apply its --- own policies to top-level window placement. The intent is that top-level --- windows should be repositioned according to the value of 'windowPosition'. - -windowPosition :: StateVar Position -windowPosition = makeStateVar getWindowPosition setWindowPosition - -setWindowPosition :: Position -> IO () -setWindowPosition (Position x y) = - glutPositionWindow (fromIntegral x) (fromIntegral y) - -getWindowPosition :: IO Position -getWindowPosition = do - x <- simpleGet fromIntegral glut_WINDOW_X - y <- simpleGet fromIntegral glut_WINDOW_Y - return $ Position x y - --------------------------------------------------------------------------------- - --- | Controls the size of the /current window/. The parameters of 'Size' are --- size extents in pixels. The width and height must be positive values. --- --- In the case of top-level windows, setting 'windowSize' is considered only a --- request for sizing the window. The window system is free to apply its own --- policies to top-level window sizing. The intent is that top-level windows --- should be reshaped according to the value of 'windowSize'. Whether a reshape --- actually takes effect and, if so, the reshaped dimensions are reported to the --- program by a reshape callback. - -windowSize :: StateVar Size -windowSize = makeStateVar getWindowSize setWindowSize - -setWindowSize :: Size -> IO () -setWindowSize (Size w h) = - glutReshapeWindow (fromIntegral w) (fromIntegral h) - -getWindowSize :: IO Size -getWindowSize = do - w <- simpleGet fromIntegral glut_WINDOW_WIDTH - h <- simpleGet fromIntegral glut_WINDOW_HEIGHT - return $ Size w h - --------------------------------------------------------------------------------- - --- | Request that the /current window/ be made full screen. The exact semantics --- of what full screen means may vary by window system. The intent is to make --- the window as large as possible and disable any window decorations or borders --- added the window system. The window width and height are not guaranteed to be --- the same as the screen width and height, but that is the intent of making a --- window full screen. --- --- 'fullScreen' is defined to work only on top-level windows. --- --- /X Implementation Notes:/ In the X implementation of GLUT, full screen is --- implemented by sizing and positioning the window to cover the entire screen --- and posting the @_MOTIF_WM_HINTS@ property on the window requesting --- absolutely no decorations. Non-Motif window managers may not respond to --- @_MOTIF_WM_HINTS@. - -fullScreen :: IO () -fullScreen = glutFullScreen - --------------------------------------------------------------------------------- - --- | (/freeglut only/) Toggle between windowed and full screen mode. - -fullScreenToggle :: IO () -fullScreenToggle = glutFullScreenToggle - --------------------------------------------------------------------------------- - --- $ManipulatingTheStackingOrder --- 'pushWindow' and 'popWindow' work on both top-level windows and subwindows. --- The effect of pushing and popping windows does not take place immediately. --- Instead the push or pop is saved for execution upon return to the GLUT event --- loop. Subsequent pop or push requests on a window replace the previously --- saved request for that window. The effect of pushing and popping top-level --- windows is subject to the window system\'s policy for restacking windows. - --- | Change the stacking order of the /current window/ relative to its siblings --- (lowering it). - -pushWindow :: IO () -pushWindow = glutPushWindow - --- | Change the stacking order of the /current window/ relative to its siblings, --- bringing the /current window/ closer to the top. - -popWindow :: IO () -popWindow = glutPopWindow - --------------------------------------------------------------------------------- - --- | The display status of a window. - -data WindowStatus - = Shown - | Hidden - | Iconified - deriving ( Eq, Ord, Show ) - --- | Controls the display status of the /current window/. --- --- Note that the effect of showing, hiding, and iconifying windows does not take --- place immediately. Instead the requests are saved for execution upon return --- to the GLUT event loop. Subsequent show, hide, or iconification requests on a --- window replace the previously saved request for that window. The effect of --- hiding, showing, or iconifying top-level windows is subject to the window --- system\'s policy for displaying windows. Subwindows can\'t be iconified. - -windowStatus :: SettableStateVar WindowStatus -windowStatus = makeSettableStateVar setStatus - where setStatus Shown = glutShowWindow - setStatus Hidden = glutHideWindow - setStatus Iconified = glutIconifyWindow - --------------------------------------------------------------------------------- - --- $ChangingTheWindowIconTitle --- 'windowTitle' and 'iconTitle' should be set only when the /current --- window/ is a top-level window. Upon creation of a top-level window, the --- window and icon names are determined by the name given to 'createWindow'. --- Once created, setting 'windowTitle' and 'iconTitle' can change the window and --- icon names respectively of top-level windows. Each call requests the window --- system change the title appropriately. Requests are not buffered or --- coalesced. The policy by which the window and icon name are displayed is --- window system dependent. - --- | Controls the window title of the /current top-level window/. - -windowTitle :: SettableStateVar String -windowTitle = - makeSettableStateVar $ \name -> - withCString name glutSetWindowTitle - --- | Controls the icon title of the /current top-level window/. - -iconTitle :: SettableStateVar String -iconTitle = - makeSettableStateVar $ \name -> - withCString name glutSetIconTitle - --------------------------------------------------------------------------------- - --- | The different cursor images GLUT supports. - -data Cursor - = RightArrow -- ^ Arrow pointing up and to the right. - | LeftArrow -- ^ Arrow pointing up and to the left. - | Info -- ^ Pointing hand. - | Destroy -- ^ Skull & cross bones. - | Help -- ^ Question mark. - | Cycle -- ^ Arrows rotating in a circle. - | Spray -- ^ Spray can. - | Wait -- ^ Wrist watch. - | Text -- ^ Insertion point cursor for text. - | Crosshair -- ^ Simple cross-hair. - | UpDown -- ^ Bi-directional pointing up & down. - | LeftRight -- ^ Bi-directional pointing left & right. - | TopSide -- ^ Arrow pointing to top side. - | BottomSide -- ^ Arrow pointing to bottom side. - | LeftSide -- ^ Arrow pointing to left side. - | RightSide -- ^ Arrow pointing to right side. - | TopLeftCorner -- ^ Arrow pointing to top-left corner. - | TopRightCorner -- ^ Arrow pointing to top-right corner. - | BottomRightCorner -- ^ Arrow pointing to bottom-left corner. - | BottomLeftCorner -- ^ Arrow pointing to bottom-right corner. - | Inherit -- ^ Use parent\'s cursor. - | None -- ^ Invisible cursor. - | FullCrosshair -- ^ Full-screen cross-hair cursor (if possible, otherwise 'Crosshair'). - deriving ( Eq, Ord, Show ) - -marshalCursor :: Cursor -> CInt -marshalCursor x = case x of - RightArrow -> glut_CURSOR_RIGHT_ARROW - LeftArrow -> glut_CURSOR_LEFT_ARROW - Info -> glut_CURSOR_INFO - Destroy -> glut_CURSOR_DESTROY - Help -> glut_CURSOR_HELP - Cycle -> glut_CURSOR_CYCLE - Spray -> glut_CURSOR_SPRAY - Wait -> glut_CURSOR_WAIT - Text -> glut_CURSOR_TEXT - Crosshair -> glut_CURSOR_CROSSHAIR - UpDown -> glut_CURSOR_UP_DOWN - LeftRight -> glut_CURSOR_LEFT_RIGHT - TopSide -> glut_CURSOR_TOP_SIDE - BottomSide -> glut_CURSOR_BOTTOM_SIDE - LeftSide -> glut_CURSOR_LEFT_SIDE - RightSide -> glut_CURSOR_RIGHT_SIDE - TopLeftCorner -> glut_CURSOR_TOP_LEFT_CORNER - TopRightCorner -> glut_CURSOR_TOP_RIGHT_CORNER - BottomRightCorner -> glut_CURSOR_BOTTOM_RIGHT_CORNER - BottomLeftCorner -> glut_CURSOR_BOTTOM_LEFT_CORNER - Inherit -> glut_CURSOR_INHERIT - None -> glut_CURSOR_NONE - FullCrosshair -> glut_CURSOR_FULL_CROSSHAIR - -unmarshalCursor :: CInt -> Cursor -unmarshalCursor x - | x == glut_CURSOR_RIGHT_ARROW = RightArrow - | x == glut_CURSOR_LEFT_ARROW = LeftArrow - | x == glut_CURSOR_INFO = Info - | x == glut_CURSOR_DESTROY = Destroy - | x == glut_CURSOR_HELP = Help - | x == glut_CURSOR_CYCLE = Cycle - | x == glut_CURSOR_SPRAY = Spray - | x == glut_CURSOR_WAIT = Wait - | x == glut_CURSOR_TEXT = Text - | x == glut_CURSOR_CROSSHAIR = Crosshair - | x == glut_CURSOR_UP_DOWN = UpDown - | x == glut_CURSOR_LEFT_RIGHT = LeftRight - | x == glut_CURSOR_TOP_SIDE = TopSide - | x == glut_CURSOR_BOTTOM_SIDE = BottomSide - | x == glut_CURSOR_LEFT_SIDE = LeftSide - | x == glut_CURSOR_RIGHT_SIDE = RightSide - | x == glut_CURSOR_TOP_LEFT_CORNER = TopLeftCorner - | x == glut_CURSOR_TOP_RIGHT_CORNER = TopRightCorner - | x == glut_CURSOR_BOTTOM_RIGHT_CORNER = BottomRightCorner - | x == glut_CURSOR_BOTTOM_LEFT_CORNER = BottomLeftCorner - | x == glut_CURSOR_INHERIT = Inherit - | x == glut_CURSOR_NONE = None - | x == glut_CURSOR_FULL_CROSSHAIR = FullCrosshair - | otherwise = error ("unmarshalCursor: illegal value " ++ show x) - --------------------------------------------------------------------------------- - --- | Change the cursor image of the /current window/. Each call requests the --- window system change the cursor appropriately. The cursor image when a window --- is created is 'Inherit'. The exact cursor images used are implementation --- dependent. The intent is for the image to convey the meaning of the cursor --- name. For a top-level window, 'Inherit' uses the default window system --- cursor. --- --- /X Implementation Notes:/ GLUT for X uses SGI\'s @_SGI_CROSSHAIR_CURSOR@ --- convention to access a full-screen cross-hair cursor if possible. - -cursor :: StateVar Cursor -cursor = makeStateVar getCursor setCursor - -setCursor :: Cursor -> IO () -setCursor = glutSetCursor . marshalCursor - -getCursor :: IO Cursor -getCursor = simpleGet unmarshalCursor glut_WINDOW_CURSOR - --------------------------------------------------------------------------------- - --- | Setting 'pointerPosition' warps the window system\'s pointer to a new --- location relative to the origin of the /current window/ by the specified --- pixel offset, which may be negative. The warp is done immediately. --- --- If the pointer would be warped outside the screen\'s frame buffer region, the --- location will be clamped to the nearest screen edge. The window system is --- allowed to further constrain the pointer\'s location in window system --- dependent ways. --- --- Good advice from Xlib\'s @XWarpPointer@ man page: \"There is seldom any --- reason for calling this function. The pointer should normally be left to the --- user.\" - -pointerPosition :: SettableStateVar Position -pointerPosition = - makeSettableStateVar $ \(Position x y) -> - glutWarpPointer (fromIntegral x) (fromIntegral y) +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Window +-- Copyright : (c) Sven Panne 2002-2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- GLUT supports two types of windows: top-level windows and subwindows. Both +-- types support OpenGL rendering and GLUT callbacks. There is a single +-- identifier space for both types of windows. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Window ( + -- * Window identifiers + Window, + + -- * Creating and destroying (sub-)windows + + -- $CreatingAndDestroyingSubWindows + createWindow, createSubWindow, destroyWindow, + parentWindow, numSubWindows, + + -- * Manipulating the /current window/ + currentWindow, + + -- * Re-displaying and double buffer management + postRedisplay, swapBuffers, + + -- * Changing the window geometry + + -- $ChangingTheWindowGeometry + windowPosition, windowSize, fullScreen, fullScreenToggle, + + -- * Manipulating the stacking order + + -- $ManipulatingTheStackingOrder + pushWindow, popWindow, + + -- * Managing a window\'s display status + WindowStatus(..), windowStatus, + + -- * Changing the window\/icon title + + -- $ChangingTheWindowIconTitle + windowTitle, iconTitle, + + -- * Cursor management + Cursor(..), cursor, pointerPosition +) where + +import Foreign.C.String +import Foreign.C.Types +import Graphics.Rendering.OpenGL ( Position(..), Size(..) + , StateVar, makeStateVar + , GettableStateVar, makeGettableStateVar + , SettableStateVar, makeSettableStateVar ) +import Graphics.UI.GLUT.QueryUtils +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.Types + +-------------------------------------------------------------------------------- + +-- $CreatingAndDestroyingSubWindows +-- Each created window has a unique associated OpenGL context. State changes to +-- a window\'s associated OpenGL context can be done immediately after the +-- window is created. +-- +-- The /display state/ of a window is initially for the window to be shown. But +-- the window\'s /display state/ is not actually acted upon until +-- 'Graphics.UI.GLUT.Begin.mainLoop' is entered. This means until +-- 'Graphics.UI.GLUT.Begin.mainLoop' is called, rendering to a created window is +-- ineffective because the window can not yet be displayed. +-- +-- The value returned by 'createWindow' and 'createSubWindow' is a unique +-- identifier for the window, which can be used with 'currentWindow'. + +-- | Create a top-level window. The given name will be provided to the window +-- system as the window\'s name. The intent is that the window system will label +-- the window with the name.Implicitly, the /current window/ is set to the newly +-- created window. +-- +-- /X Implementation Notes:/ The proper X Inter-Client Communication Conventions +-- Manual (ICCCM) top-level properties are established. The @WM_COMMAND@ +-- property that lists the command line used to invoke the GLUT program is only +-- established for the first window created. + +createWindow + :: String -- ^ The window name + -> IO Window -- ^ The identifier for the newly created window +createWindow name = fmap Window $ withCString name glutCreateWindow + +-------------------------------------------------------------------------------- + +-- | Create a subwindow of the identified window with the given relative +-- position and size. Implicitly, the /current window/ is set to the +-- newly created subwindow. Subwindows can be nested arbitrarily deep. + +createSubWindow + :: Window -- ^ Identifier of the subwindow\'s parent window. + -> Position -- ^ Window position in pixels relative to parent window\'s + -- origin. + -> Size -- ^ Window size in pixels + -> IO Window -- ^ The identifier for the newly created subwindow +createSubWindow (Window win) (Position x y) (Size w h) = + fmap Window $ + glutCreateSubWindow win + (fromIntegral x) (fromIntegral y) + (fromIntegral w) (fromIntegral h) + +-------------------------------------------------------------------------------- + +-- | Contains the /current window\'s/ parent. If the /current window/ is a +-- top-level window, 'Nothing' is returned. + +parentWindow :: GettableStateVar (Maybe Window) +parentWindow = + makeGettableStateVar $ + getWindow (simpleGet Window glut_WINDOW_PARENT) + +-------------------------------------------------------------------------------- + +-- | Contains the number of subwindows the /current window/ has, not counting +-- children of children. + +numSubWindows :: GettableStateVar Int +numSubWindows = + makeGettableStateVar $ + simpleGet fromIntegral glut_WINDOW_NUM_CHILDREN + +-------------------------------------------------------------------------------- + +-- | Destroy the specified window and the window\'s associated OpenGL context, +-- logical colormap (if the window is color index), and overlay and related +-- state (if an overlay has been established). Any subwindows of the destroyed +-- window are also destroyed by 'destroyWindow'. If the specified window was the +-- /current window/, the /current window/ becomes invalid ('currentWindow' will +-- contain 'Nothing'). + +destroyWindow :: Window -> IO () +destroyWindow (Window win) = glutDestroyWindow win + +-------------------------------------------------------------------------------- + +-- | Controls the /current window/. It does /not/ affect the /layer in use/ for +-- the window; this is done using 'Graphics.UI.GLUT.Overlay.layerInUse'. +-- Contains 'Nothing' if no windows exist or the previously /current window/ was +-- destroyed. Setting the /current window/ to 'Nothing' is a no-op. + +currentWindow :: StateVar (Maybe Window) +currentWindow = + makeStateVar + (getWindow (fmap Window glutGetWindow)) + (maybe (return ()) (\(Window win) -> glutSetWindow win)) + +getWindow :: IO Window -> IO (Maybe Window) +getWindow act = do + win <- act + return $ if win == Window 0 then Nothing else Just win + +-------------------------------------------------------------------------------- + +-- | Mark the normal plane of given window (or the /current window/, if none +-- is supplied) as needing to be redisplayed. The next iteration through +-- 'Graphics.UI.GLUT.Begin.mainLoop', the window\'s display callback will be +-- called to redisplay the window\'s normal plane. Multiple calls to +-- 'postRedisplay' before the next display callback opportunity generates only a +-- single redisplay callback. 'postRedisplay' may be called within a window\'s +-- display or overlay display callback to re-mark that window for redisplay. +-- +-- Logically, normal plane damage notification for a window is treated as a +-- 'postRedisplay' on the damaged window. Unlike damage reported by the window +-- system, 'postRedisplay' will /not/ set to true the normal plane\'s damaged +-- status (see 'Graphics.UI.GLUT.State.damaged'). +-- +-- Also, see 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay'. + +postRedisplay :: Maybe Window -> IO () +postRedisplay = maybe glutPostRedisplay (\(Window win) -> glutPostWindowRedisplay win) + +-- | Mark the normal plane of the given window as needing to be redisplayed, +-- otherwise the same as 'postRedisplay'. +-- +-- The advantage of this routine is that it saves the cost of using +-- 'currentWindow' (entailing an expensive OpenGL context switch), which is +-- particularly useful when multiple windows need redisplays posted at the same +-- time. + +-------------------------------------------------------------------------------- + +-- | Perform a buffer swap on the /layer in use/ for the /current window/. +-- Specifically, 'swapBuffers' promotes the contents of the back buffer of the +-- /layer in use/ of the /current window/ to become the contents of the front +-- buffer. The contents of the back buffer then become undefined. The update +-- typically takes place during the vertical retrace of the monitor, rather than +-- immediately after 'swapBuffers' is called. +-- +-- An implicit 'Graphics.Rendering.OpenGL.GL.FlushFinish.flush' is done by +-- 'swapBuffers' before it returns. Subsequent OpenGL commands can be issued +-- immediately after calling 'swapBuffers', but are not executed until the +-- buffer exchange is completed. +-- +-- If the /layer in use/ is not double buffered, 'swapBuffers' has no effect. + +swapBuffers :: IO () +swapBuffers = glutSwapBuffers + +-------------------------------------------------------------------------------- + +-- $ChangingTheWindowGeometry +-- Note that the requests by 'windowPosition', 'windowSize', and 'fullScreen' +-- are not processed immediately. A request is executed after returning to the +-- main event loop. This allows multiple requests to the same window to be +-- coalesced. +-- +-- 'windowPosition' and 'windowSize' requests on a window will disable the full +-- screen status of the window. + +-------------------------------------------------------------------------------- + +-- | Controls the position of the /current window/. For top-level windows, +-- parameters of 'Position' are pixel offsets from the screen origin. For +-- subwindows, the parameters are pixel offsets from the window\'s parent window +-- origin. +-- +-- In the case of top-level windows, setting 'windowPosition' is considered only +-- a request for positioning the window. The window system is free to apply its +-- own policies to top-level window placement. The intent is that top-level +-- windows should be repositioned according to the value of 'windowPosition'. + +windowPosition :: StateVar Position +windowPosition = makeStateVar getWindowPosition setWindowPosition + +setWindowPosition :: Position -> IO () +setWindowPosition (Position x y) = + glutPositionWindow (fromIntegral x) (fromIntegral y) + +getWindowPosition :: IO Position +getWindowPosition = do + x <- simpleGet fromIntegral glut_WINDOW_X + y <- simpleGet fromIntegral glut_WINDOW_Y + return $ Position x y + +-------------------------------------------------------------------------------- + +-- | Controls the size of the /current window/. The parameters of 'Size' are +-- size extents in pixels. The width and height must be positive values. +-- +-- In the case of top-level windows, setting 'windowSize' is considered only a +-- request for sizing the window. The window system is free to apply its own +-- policies to top-level window sizing. The intent is that top-level windows +-- should be reshaped according to the value of 'windowSize'. Whether a reshape +-- actually takes effect and, if so, the reshaped dimensions are reported to the +-- program by a reshape callback. + +windowSize :: StateVar Size +windowSize = makeStateVar getWindowSize setWindowSize + +setWindowSize :: Size -> IO () +setWindowSize (Size w h) = + glutReshapeWindow (fromIntegral w) (fromIntegral h) + +getWindowSize :: IO Size +getWindowSize = do + w <- simpleGet fromIntegral glut_WINDOW_WIDTH + h <- simpleGet fromIntegral glut_WINDOW_HEIGHT + return $ Size w h + +-------------------------------------------------------------------------------- + +-- | Request that the /current window/ be made full screen. The exact semantics +-- of what full screen means may vary by window system. The intent is to make +-- the window as large as possible and disable any window decorations or borders +-- added the window system. The window width and height are not guaranteed to be +-- the same as the screen width and height, but that is the intent of making a +-- window full screen. +-- +-- 'fullScreen' is defined to work only on top-level windows. +-- +-- /X Implementation Notes:/ In the X implementation of GLUT, full screen is +-- implemented by sizing and positioning the window to cover the entire screen +-- and posting the @_MOTIF_WM_HINTS@ property on the window requesting +-- absolutely no decorations. Non-Motif window managers may not respond to +-- @_MOTIF_WM_HINTS@. + +fullScreen :: IO () +fullScreen = glutFullScreen + +-------------------------------------------------------------------------------- + +-- | (/freeglut only/) Toggle between windowed and full screen mode. + +fullScreenToggle :: IO () +fullScreenToggle = glutFullScreenToggle + +-------------------------------------------------------------------------------- + +-- $ManipulatingTheStackingOrder +-- 'pushWindow' and 'popWindow' work on both top-level windows and subwindows. +-- The effect of pushing and popping windows does not take place immediately. +-- Instead the push or pop is saved for execution upon return to the GLUT event +-- loop. Subsequent pop or push requests on a window replace the previously +-- saved request for that window. The effect of pushing and popping top-level +-- windows is subject to the window system\'s policy for restacking windows. + +-- | Change the stacking order of the /current window/ relative to its siblings +-- (lowering it). + +pushWindow :: IO () +pushWindow = glutPushWindow + +-- | Change the stacking order of the /current window/ relative to its siblings, +-- bringing the /current window/ closer to the top. + +popWindow :: IO () +popWindow = glutPopWindow + +-------------------------------------------------------------------------------- + +-- | The display status of a window. + +data WindowStatus + = Shown + | Hidden + | Iconified + deriving ( Eq, Ord, Show ) + +-- | Controls the display status of the /current window/. +-- +-- Note that the effect of showing, hiding, and iconifying windows does not take +-- place immediately. Instead the requests are saved for execution upon return +-- to the GLUT event loop. Subsequent show, hide, or iconification requests on a +-- window replace the previously saved request for that window. The effect of +-- hiding, showing, or iconifying top-level windows is subject to the window +-- system\'s policy for displaying windows. Subwindows can\'t be iconified. + +windowStatus :: SettableStateVar WindowStatus +windowStatus = makeSettableStateVar setStatus + where setStatus Shown = glutShowWindow + setStatus Hidden = glutHideWindow + setStatus Iconified = glutIconifyWindow + +-------------------------------------------------------------------------------- + +-- $ChangingTheWindowIconTitle +-- 'windowTitle' and 'iconTitle' should be set only when the /current +-- window/ is a top-level window. Upon creation of a top-level window, the +-- window and icon names are determined by the name given to 'createWindow'. +-- Once created, setting 'windowTitle' and 'iconTitle' can change the window and +-- icon names respectively of top-level windows. Each call requests the window +-- system change the title appropriately. Requests are not buffered or +-- coalesced. The policy by which the window and icon name are displayed is +-- window system dependent. + +-- | Controls the window title of the /current top-level window/. + +windowTitle :: SettableStateVar String +windowTitle = + makeSettableStateVar $ \name -> + withCString name glutSetWindowTitle + +-- | Controls the icon title of the /current top-level window/. + +iconTitle :: SettableStateVar String +iconTitle = + makeSettableStateVar $ \name -> + withCString name glutSetIconTitle + +-------------------------------------------------------------------------------- + +-- | The different cursor images GLUT supports. + +data Cursor + = RightArrow -- ^ Arrow pointing up and to the right. + | LeftArrow -- ^ Arrow pointing up and to the left. + | Info -- ^ Pointing hand. + | Destroy -- ^ Skull & cross bones. + | Help -- ^ Question mark. + | Cycle -- ^ Arrows rotating in a circle. + | Spray -- ^ Spray can. + | Wait -- ^ Wrist watch. + | Text -- ^ Insertion point cursor for text. + | Crosshair -- ^ Simple cross-hair. + | UpDown -- ^ Bi-directional pointing up & down. + | LeftRight -- ^ Bi-directional pointing left & right. + | TopSide -- ^ Arrow pointing to top side. + | BottomSide -- ^ Arrow pointing to bottom side. + | LeftSide -- ^ Arrow pointing to left side. + | RightSide -- ^ Arrow pointing to right side. + | TopLeftCorner -- ^ Arrow pointing to top-left corner. + | TopRightCorner -- ^ Arrow pointing to top-right corner. + | BottomRightCorner -- ^ Arrow pointing to bottom-left corner. + | BottomLeftCorner -- ^ Arrow pointing to bottom-right corner. + | Inherit -- ^ Use parent\'s cursor. + | None -- ^ Invisible cursor. + | FullCrosshair -- ^ Full-screen cross-hair cursor (if possible, otherwise 'Crosshair'). + deriving ( Eq, Ord, Show ) + +marshalCursor :: Cursor -> CInt +marshalCursor x = case x of + RightArrow -> glut_CURSOR_RIGHT_ARROW + LeftArrow -> glut_CURSOR_LEFT_ARROW + Info -> glut_CURSOR_INFO + Destroy -> glut_CURSOR_DESTROY + Help -> glut_CURSOR_HELP + Cycle -> glut_CURSOR_CYCLE + Spray -> glut_CURSOR_SPRAY + Wait -> glut_CURSOR_WAIT + Text -> glut_CURSOR_TEXT + Crosshair -> glut_CURSOR_CROSSHAIR + UpDown -> glut_CURSOR_UP_DOWN + LeftRight -> glut_CURSOR_LEFT_RIGHT + TopSide -> glut_CURSOR_TOP_SIDE + BottomSide -> glut_CURSOR_BOTTOM_SIDE + LeftSide -> glut_CURSOR_LEFT_SIDE + RightSide -> glut_CURSOR_RIGHT_SIDE + TopLeftCorner -> glut_CURSOR_TOP_LEFT_CORNER + TopRightCorner -> glut_CURSOR_TOP_RIGHT_CORNER + BottomRightCorner -> glut_CURSOR_BOTTOM_RIGHT_CORNER + BottomLeftCorner -> glut_CURSOR_BOTTOM_LEFT_CORNER + Inherit -> glut_CURSOR_INHERIT + None -> glut_CURSOR_NONE + FullCrosshair -> glut_CURSOR_FULL_CROSSHAIR + +unmarshalCursor :: CInt -> Cursor +unmarshalCursor x + | x == glut_CURSOR_RIGHT_ARROW = RightArrow + | x == glut_CURSOR_LEFT_ARROW = LeftArrow + | x == glut_CURSOR_INFO = Info + | x == glut_CURSOR_DESTROY = Destroy + | x == glut_CURSOR_HELP = Help + | x == glut_CURSOR_CYCLE = Cycle + | x == glut_CURSOR_SPRAY = Spray + | x == glut_CURSOR_WAIT = Wait + | x == glut_CURSOR_TEXT = Text + | x == glut_CURSOR_CROSSHAIR = Crosshair + | x == glut_CURSOR_UP_DOWN = UpDown + | x == glut_CURSOR_LEFT_RIGHT = LeftRight + | x == glut_CURSOR_TOP_SIDE = TopSide + | x == glut_CURSOR_BOTTOM_SIDE = BottomSide + | x == glut_CURSOR_LEFT_SIDE = LeftSide + | x == glut_CURSOR_RIGHT_SIDE = RightSide + | x == glut_CURSOR_TOP_LEFT_CORNER = TopLeftCorner + | x == glut_CURSOR_TOP_RIGHT_CORNER = TopRightCorner + | x == glut_CURSOR_BOTTOM_RIGHT_CORNER = BottomRightCorner + | x == glut_CURSOR_BOTTOM_LEFT_CORNER = BottomLeftCorner + | x == glut_CURSOR_INHERIT = Inherit + | x == glut_CURSOR_NONE = None + | x == glut_CURSOR_FULL_CROSSHAIR = FullCrosshair + | otherwise = error ("unmarshalCursor: illegal value " ++ show x) + +-------------------------------------------------------------------------------- + +-- | Change the cursor image of the /current window/. Each call requests the +-- window system change the cursor appropriately. The cursor image when a window +-- is created is 'Inherit'. The exact cursor images used are implementation +-- dependent. The intent is for the image to convey the meaning of the cursor +-- name. For a top-level window, 'Inherit' uses the default window system +-- cursor. +-- +-- /X Implementation Notes:/ GLUT for X uses SGI\'s @_SGI_CROSSHAIR_CURSOR@ +-- convention to access a full-screen cross-hair cursor if possible. + +cursor :: StateVar Cursor +cursor = makeStateVar getCursor setCursor + +setCursor :: Cursor -> IO () +setCursor = glutSetCursor . marshalCursor + +getCursor :: IO Cursor +getCursor = simpleGet unmarshalCursor glut_WINDOW_CURSOR + +-------------------------------------------------------------------------------- + +-- | Setting 'pointerPosition' warps the window system\'s pointer to a new +-- location relative to the origin of the /current window/ by the specified +-- pixel offset, which may be negative. The warp is done immediately. +-- +-- If the pointer would be warped outside the screen\'s frame buffer region, the +-- location will be clamped to the nearest screen edge. The window system is +-- allowed to further constrain the pointer\'s location in window system +-- dependent ways. +-- +-- Good advice from Xlib\'s @XWarpPointer@ man page: \"There is seldom any +-- reason for calling this function. The pointer should normally be left to the +-- user.\" + +pointerPosition :: SettableStateVar Position +pointerPosition = + makeSettableStateVar $ \(Position x y) -> + glutWarpPointer (fromIntegral x) (fromIntegral y) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,1 +1,1 @@ -[![Build Status](https://travis-ci.org/haskell-opengl/GLUT.png)](https://travis-ci.org/haskell-opengl/GLUT) +[![Build Status](https://travis-ci.org/haskell-opengl/GLUT.png)](https://travis-ci.org/haskell-opengl/GLUT) diff --git a/cbits/HsGLUT.c b/cbits/HsGLUT.c --- a/cbits/HsGLUT.c +++ b/cbits/HsGLUT.c @@ -1,154 +1,154 @@ -/* ----------------------------------------------------------------------------- - * - * Module : C support for Graphics.UI.GLUT.Raw - * Copyright : (c) Sven Panne 2002-2013 - * License : BSD3 - * - * Maintainer : Sven Panne - * Stability : stable - * Portability : portable - * - * -------------------------------------------------------------------------- */ - -#if defined(_MSC_VER) || defined(__CYGWIN__) || defined(__MINGW32__) || defined(__WATCOMC__) - -#define GLUT_STROKE_ROMAN ((void *)0x0000) -#define GLUT_STROKE_MONO_ROMAN ((void *)0x0001) -#define GLUT_BITMAP_9_BY_15 ((void *)0x0002) -#define GLUT_BITMAP_8_BY_13 ((void *)0x0003) -#define GLUT_BITMAP_TIMES_ROMAN_10 ((void *)0x0004) -#define GLUT_BITMAP_TIMES_ROMAN_24 ((void *)0x0005) -#define GLUT_BITMAP_HELVETICA_10 ((void *)0x0006) -#define GLUT_BITMAP_HELVETICA_12 ((void *)0x0007) -#define GLUT_BITMAP_HELVETICA_18 ((void *)0x0008) - -#else - -extern void* glutStrokeRoman; -extern void* glutStrokeMonoRoman; -extern void* glutBitmap9By15; -extern void* glutBitmap8By13; -extern void* glutBitmapTimesRoman10; -extern void* glutBitmapTimesRoman24; -extern void* glutBitmapHelvetica10; -extern void* glutBitmapHelvetica12; -extern void* glutBitmapHelvetica18; - -#define GLUT_STROKE_ROMAN ((void *)&glutStrokeRoman) -#define GLUT_STROKE_MONO_ROMAN ((void *)&glutStrokeMonoRoman) -#define GLUT_BITMAP_9_BY_15 ((void *)&glutBitmap9By15) -#define GLUT_BITMAP_8_BY_13 ((void *)&glutBitmap8By13) -#define GLUT_BITMAP_TIMES_ROMAN_10 ((void *)&glutBitmapTimesRoman10) -#define GLUT_BITMAP_TIMES_ROMAN_24 ((void *)&glutBitmapTimesRoman24) -#define GLUT_BITMAP_HELVETICA_10 ((void *)&glutBitmapHelvetica10) -#define GLUT_BITMAP_HELVETICA_12 ((void *)&glutBitmapHelvetica12) -#define GLUT_BITMAP_HELVETICA_18 ((void *)&glutBitmapHelvetica18) - -#endif - -void* -hs_GLUT_marshalBitmapFont(int fontID) -{ - switch (fontID) { - case 0 : return GLUT_BITMAP_8_BY_13; - case 1 : return GLUT_BITMAP_9_BY_15; - case 2 : return GLUT_BITMAP_TIMES_ROMAN_10; - case 3 : return GLUT_BITMAP_TIMES_ROMAN_24; - case 4 : return GLUT_BITMAP_HELVETICA_10; - case 5 : return GLUT_BITMAP_HELVETICA_12; - case 6 : return GLUT_BITMAP_HELVETICA_18; - } - return (void*)0; -} - -void* -hs_GLUT_marshalStrokeFont(int fontID) -{ - switch (fontID) { - case 0 : return GLUT_STROKE_ROMAN; - case 1 : return GLUT_STROKE_MONO_ROMAN; - } - return (void*)0; -} - -/* -------------------------------------------------------------------------- */ -#if defined(USE_GETPROCADDRESS) - -#define WIN32_LEAN_AND_MEAN -#include - -void* -hs_GLUT_getProcAddress(const char *name) -{ - static int firstTime = 1; - static HMODULE handle = NULL; - - if (firstTime) { - firstTime = 0; - handle = LoadLibrary(TEXT("glut32")); - } - - return handle ? GetProcAddress(handle, name) : NULL; -} - -/* -------------------------------------------------------------------------- */ -#elif defined(USE_NSADDRESSOFSYMBOL) - -#include -#include -#include - -void* -hs_GLUT_getProcAddress(const char *name) -{ - NSSymbol symbol; - - /* Prepend a '_' for the Unix C symbol mangling convention */ - char* symbolName = (char*)malloc(strlen(name) + 2); - if (!symbolName) { - return NULL; - } - symbolName[0] = '_'; - strcpy(symbolName + 1, name); - - if (!NSIsSymbolNameDefined(symbolName)) { - free(symbolName); - return NULL; - } - - symbol = NSLookupAndBindSymbol(symbolName); - free(symbolName); - if (!symbol) { - return NULL; - } - - return NSAddressOfSymbol(symbol); -} - -/* -------------------------------------------------------------------------- */ -#elif defined(USE_DLSYM) - -#include -#include - -void* -hs_GLUT_getProcAddress(const char *name) -{ - static int firstTime = 1; - static void *handle = NULL; - - if (firstTime) { - firstTime = 0; - /* Get a handle for our executable. */ - handle = dlopen(NULL, RTLD_LAZY); - } - - return handle ? dlsym(handle, name) : NULL; -} - -/* -------------------------------------------------------------------------- */ -#else - -#error "Don't know how to retrieve GLUT entries" - -#endif +/* ----------------------------------------------------------------------------- + * + * Module : C support for Graphics.UI.GLUT.Raw + * Copyright : (c) Sven Panne 2002-2013 + * License : BSD3 + * + * Maintainer : Sven Panne + * Stability : stable + * Portability : portable + * + * -------------------------------------------------------------------------- */ + +#if defined(_MSC_VER) || defined(__CYGWIN__) || defined(__MINGW32__) || defined(__WATCOMC__) + +#define GLUT_STROKE_ROMAN ((void *)0x0000) +#define GLUT_STROKE_MONO_ROMAN ((void *)0x0001) +#define GLUT_BITMAP_9_BY_15 ((void *)0x0002) +#define GLUT_BITMAP_8_BY_13 ((void *)0x0003) +#define GLUT_BITMAP_TIMES_ROMAN_10 ((void *)0x0004) +#define GLUT_BITMAP_TIMES_ROMAN_24 ((void *)0x0005) +#define GLUT_BITMAP_HELVETICA_10 ((void *)0x0006) +#define GLUT_BITMAP_HELVETICA_12 ((void *)0x0007) +#define GLUT_BITMAP_HELVETICA_18 ((void *)0x0008) + +#else + +extern void* glutStrokeRoman; +extern void* glutStrokeMonoRoman; +extern void* glutBitmap9By15; +extern void* glutBitmap8By13; +extern void* glutBitmapTimesRoman10; +extern void* glutBitmapTimesRoman24; +extern void* glutBitmapHelvetica10; +extern void* glutBitmapHelvetica12; +extern void* glutBitmapHelvetica18; + +#define GLUT_STROKE_ROMAN ((void *)&glutStrokeRoman) +#define GLUT_STROKE_MONO_ROMAN ((void *)&glutStrokeMonoRoman) +#define GLUT_BITMAP_9_BY_15 ((void *)&glutBitmap9By15) +#define GLUT_BITMAP_8_BY_13 ((void *)&glutBitmap8By13) +#define GLUT_BITMAP_TIMES_ROMAN_10 ((void *)&glutBitmapTimesRoman10) +#define GLUT_BITMAP_TIMES_ROMAN_24 ((void *)&glutBitmapTimesRoman24) +#define GLUT_BITMAP_HELVETICA_10 ((void *)&glutBitmapHelvetica10) +#define GLUT_BITMAP_HELVETICA_12 ((void *)&glutBitmapHelvetica12) +#define GLUT_BITMAP_HELVETICA_18 ((void *)&glutBitmapHelvetica18) + +#endif + +void* +hs_GLUT_marshalBitmapFont(int fontID) +{ + switch (fontID) { + case 0 : return GLUT_BITMAP_8_BY_13; + case 1 : return GLUT_BITMAP_9_BY_15; + case 2 : return GLUT_BITMAP_TIMES_ROMAN_10; + case 3 : return GLUT_BITMAP_TIMES_ROMAN_24; + case 4 : return GLUT_BITMAP_HELVETICA_10; + case 5 : return GLUT_BITMAP_HELVETICA_12; + case 6 : return GLUT_BITMAP_HELVETICA_18; + } + return (void*)0; +} + +void* +hs_GLUT_marshalStrokeFont(int fontID) +{ + switch (fontID) { + case 0 : return GLUT_STROKE_ROMAN; + case 1 : return GLUT_STROKE_MONO_ROMAN; + } + return (void*)0; +} + +/* -------------------------------------------------------------------------- */ +#if defined(USE_GETPROCADDRESS) + +#define WIN32_LEAN_AND_MEAN +#include + +void* +hs_GLUT_getProcAddress(const char *name) +{ + static int firstTime = 1; + static HMODULE handle = NULL; + + if (firstTime) { + firstTime = 0; + handle = LoadLibrary(TEXT("glut32")); + } + + return handle ? GetProcAddress(handle, name) : NULL; +} + +/* -------------------------------------------------------------------------- */ +#elif defined(USE_NSADDRESSOFSYMBOL) + +#include +#include +#include + +void* +hs_GLUT_getProcAddress(const char *name) +{ + NSSymbol symbol; + + /* Prepend a '_' for the Unix C symbol mangling convention */ + char* symbolName = (char*)malloc(strlen(name) + 2); + if (!symbolName) { + return NULL; + } + symbolName[0] = '_'; + strcpy(symbolName + 1, name); + + if (!NSIsSymbolNameDefined(symbolName)) { + free(symbolName); + return NULL; + } + + symbol = NSLookupAndBindSymbol(symbolName); + free(symbolName); + if (!symbol) { + return NULL; + } + + return NSAddressOfSymbol(symbol); +} + +/* -------------------------------------------------------------------------- */ +#elif defined(USE_DLSYM) + +#include +#include + +void* +hs_GLUT_getProcAddress(const char *name) +{ + static int firstTime = 1; + static void *handle = NULL; + + if (firstTime) { + firstTime = 0; + /* Get a handle for our executable. */ + handle = dlopen(NULL, RTLD_LAZY); + } + + return handle ? dlsym(handle, name) : NULL; +} + +/* -------------------------------------------------------------------------- */ +#else + +#error "Don't know how to retrieve GLUT entries" + +#endif diff --git a/examples/00-README b/examples/00-README new file mode 100644 --- /dev/null +++ b/examples/00-README @@ -0,0 +1,24 @@ +This directory contains OpenGL example programs from various sources: + + * BOGLP: Contains some examples from the book "Beginning OpenGL Game + Programming", 2nd ed., by Benstead/Astle/Hawkins. + + * Misc: Contains a few random examples from e.g. the Mesa sources. + + * OrangeBook: Contains an example from the book "OpenGL Shading Language", + 3rd ed, by Rost/Licea-Kane/Ginsburg/Kessenich/Lichtenbelt/Malan/Weiblen. + + * RedBook4: Contains all examples from the book "OpenGL Programming Guide: + The Official Guide to Learning OpenGL, Version 1.4", 4th ed., by + Shreiner/Woo/Neider/Davis. + + * RedBook8: Contains various examples from the book "OpenGL Programming + Guide: The Official Guide to Learning OpenGL, Version 4.3", 8th ed., by + Shreiner/Sellers/Kessenich/Licea-Kane. + +If you have 'make' and 'ghc' installed, you can just issue 'make' at any +directory level to compile the examples. 'make clean' cleans up afterwards, and +you can use '-j [N]' for parallel builds. Directly loading the examples into +e.g. ghci is possible, too, just ':load' an example and run it via 'main'. For +some examples, you might have to extend the search path like '-i../common', see +the corresponding Makefile. diff --git a/examples/BOGLGP/00-README b/examples/BOGLGP/00-README new file mode 100644 --- /dev/null +++ b/examples/BOGLGP/00-README @@ -0,0 +1,2 @@ +This directory contains some examples from the book "Beginning OpenGL Game +Programming", 2nd ed., by Benstead/Astle/Hawkins. diff --git a/examples/BOGLGP/Chapter01/Makefile b/examples/BOGLGP/Chapter01/Makefile --- a/examples/BOGLGP/Chapter01/Makefile +++ b/examples/BOGLGP/Chapter01/Makefile @@ -1,1 +1,1 @@ -include ../../examples.mk +include ../../examples.mk diff --git a/examples/BOGLGP/Chapter01/OnYourOwn1.hs b/examples/BOGLGP/Chapter01/OnYourOwn1.hs --- a/examples/BOGLGP/Chapter01/OnYourOwn1.hs +++ b/examples/BOGLGP/Chapter01/OnYourOwn1.hs @@ -1,111 +1,111 @@ -{- - OnYourOwn1.hs (adapted from Simple.cpp which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2004-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE --} - -import Control.Monad ( unless ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT hiding ( initialize ) - --------------------------------------------------------------------------------- --- Setup GLUT and OpenGL, drop into the event loop. --------------------------------------------------------------------------------- -main :: IO () -main = do - -- Setup the basic GLUT stuff - _ <- getArgsAndInitialize - initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] - - -- Create the window - initialWindowSize $= Size 1024 768 - initialWindowPosition $= Position 100 150 - _ <- createWindow "BOGLGP - Chapter 1 - On Your Own 1" - - initialize - - -- Register the event callback functions - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboardMouseHandler - -- No need for an idle callback here, this would just hog the CPU - -- without any visible effect - - -- At this point, control is relinquished to the GLUT event handler. - -- Control is returned as events occur, via the callback functions. - mainLoop - --------------------------------------------------------------------------------- --- One time setup, including creating menus, creating a light, setting the --- shading mode and clear color, and loading textures. --------------------------------------------------------------------------------- -initialize :: IO () -initialize = do - -- set up the only meny - attachMenu RightButton (Menu [MenuEntry "Exit" (exitWith ExitSuccess)]) - - depthFunc $= Just Less - --------------------------------------------------------------------------------- --- Handle mouse and keyboard events. For this simple demo, just exit on a --- left click or when q is pressed. --------------------------------------------------------------------------------- -keyboardMouseHandler :: KeyboardMouseCallback -keyboardMouseHandler (MouseButton LeftButton)_ _ _ = exitWith ExitSuccess -keyboardMouseHandler (Char 'q') _ _ _ = exitWith ExitSuccess -keyboardMouseHandler _ _ _ _ = postRedisplay Nothing - --------------------------------------------------------------------------------- --- Reset the viewport for window changes. --------------------------------------------------------------------------------- -reshape :: ReshapeCallback -reshape size@(Size width height) = - unless (height == 0) $ do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 90 (fromIntegral width / fromIntegral height) 1 100 - - matrixMode $= Modelview 0 - --------------------------------------------------------------------------------- --- Clear and redraw the scene. --------------------------------------------------------------------------------- -display :: DisplayCallback -display = do - -- set up the camera - loadIdentity - lookAt (Vertex3 0 1 6) (Vertex3 0 0 0) (Vector3 0 1 0) - - -- clear the screen - clear [ ColorBuffer, DepthBuffer ] - - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - - -- draw a triangle - renderPrimitive Triangles $ do - color3f (Color3 1 0 0) - vertex3f (Vertex3 2 2.5 (-1)) - color3f (Color3 1 0 0) - vertex3f (Vertex3 (-3.5) (-2.5) (-1)) - color3f (Color3 1 0 0) - vertex3f (Vertex3 2 (-4) 0) - - -- draw a polygon - renderPrimitive Polygon $ do - color3f (Color3 0 0 1) - vertex3f (Vertex3 (-1) 2 0) - color3f (Color3 0 0 1) - vertex3f (Vertex3 (-3) (-0.5) 0) - color3f (Color3 0 0 1) - vertex3f (Vertex3 (-1.5) (-3) 0) - color3f (Color3 0 0 1) - vertex3f (Vertex3 1 (-2) 0) - color3f (Color3 0 0 1) - vertex3f (Vertex3 1 1 0) - - -- draw everything and swap the display buffer - swapBuffers +{- + OnYourOwn1.hs (adapted from Simple.cpp which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2004-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( unless ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT hiding ( initialize ) + +-------------------------------------------------------------------------------- +-- Setup GLUT and OpenGL, drop into the event loop. +-------------------------------------------------------------------------------- +main :: IO () +main = do + -- Setup the basic GLUT stuff + _ <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] + + -- Create the window + initialWindowSize $= Size 1024 768 + initialWindowPosition $= Position 100 150 + _ <- createWindow "BOGLGP - Chapter 1 - On Your Own 1" + + initialize + + -- Register the event callback functions + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboardMouseHandler + -- No need for an idle callback here, this would just hog the CPU + -- without any visible effect + + -- At this point, control is relinquished to the GLUT event handler. + -- Control is returned as events occur, via the callback functions. + mainLoop + +-------------------------------------------------------------------------------- +-- One time setup, including creating menus, creating a light, setting the +-- shading mode and clear color, and loading textures. +-------------------------------------------------------------------------------- +initialize :: IO () +initialize = do + -- set up the only meny + attachMenu RightButton (Menu [MenuEntry "Exit" (exitWith ExitSuccess)]) + + depthFunc $= Just Less + +-------------------------------------------------------------------------------- +-- Handle mouse and keyboard events. For this simple demo, just exit on a +-- left click or when q is pressed. +-------------------------------------------------------------------------------- +keyboardMouseHandler :: KeyboardMouseCallback +keyboardMouseHandler (MouseButton LeftButton)_ _ _ = exitWith ExitSuccess +keyboardMouseHandler (Char 'q') _ _ _ = exitWith ExitSuccess +keyboardMouseHandler _ _ _ _ = postRedisplay Nothing + +-------------------------------------------------------------------------------- +-- Reset the viewport for window changes. +-------------------------------------------------------------------------------- +reshape :: ReshapeCallback +reshape size@(Size width height) = + unless (height == 0) $ do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 90 (fromIntegral width / fromIntegral height) 1 100 + + matrixMode $= Modelview 0 + +-------------------------------------------------------------------------------- +-- Clear and redraw the scene. +-------------------------------------------------------------------------------- +display :: DisplayCallback +display = do + -- set up the camera + loadIdentity + lookAt (Vertex3 0 1 6) (Vertex3 0 0 0) (Vector3 0 1 0) + + -- clear the screen + clear [ ColorBuffer, DepthBuffer ] + + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + + -- draw a triangle + renderPrimitive Triangles $ do + color3f (Color3 1 0 0) + vertex3f (Vertex3 2 2.5 (-1)) + color3f (Color3 1 0 0) + vertex3f (Vertex3 (-3.5) (-2.5) (-1)) + color3f (Color3 1 0 0) + vertex3f (Vertex3 2 (-4) 0) + + -- draw a polygon + renderPrimitive Polygon $ do + color3f (Color3 0 0 1) + vertex3f (Vertex3 (-1) 2 0) + color3f (Color3 0 0 1) + vertex3f (Vertex3 (-3) (-0.5) 0) + color3f (Color3 0 0 1) + vertex3f (Vertex3 (-1.5) (-3) 0) + color3f (Color3 0 0 1) + vertex3f (Vertex3 1 (-2) 0) + color3f (Color3 0 0 1) + vertex3f (Vertex3 1 1 0) + + -- draw everything and swap the display buffer + swapBuffers diff --git a/examples/BOGLGP/Chapter01/Simple.hs b/examples/BOGLGP/Chapter01/Simple.hs --- a/examples/BOGLGP/Chapter01/Simple.hs +++ b/examples/BOGLGP/Chapter01/Simple.hs @@ -1,111 +1,111 @@ -{- - Simple.hs (adapted from Simple.cpp which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2004-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE --} - -import Control.Monad ( unless ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT hiding ( initialize ) - --------------------------------------------------------------------------------- --- Setup GLUT and OpenGL, drop into the event loop. --------------------------------------------------------------------------------- -main :: IO () -main = do - -- Setup the basic GLUT stuff - _ <- getArgsAndInitialize - initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] - - -- Create the window - initialWindowSize $= Size 1024 768 - initialWindowPosition $= Position 100 150 - _ <- createWindow "BOGLGP - Chapter 1 - Simple" - - initialize - - -- Register the event callback functions - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboardMouseHandler - -- No need for an idle callback here, this would just hog the CPU - -- without any visible effect - - -- At this point, control is relinquished to the GLUT event handler. - -- Control is returned as events occur, via the callback functions. - mainLoop - --------------------------------------------------------------------------------- --- One time setup, including creating menus, creating a light, setting the --- shading mode and clear color, and loading textures. --------------------------------------------------------------------------------- -initialize :: IO () -initialize = do - -- set up the only meny - attachMenu RightButton (Menu [MenuEntry "Exit" (exitWith ExitSuccess)]) - - depthFunc $= Just Less - --------------------------------------------------------------------------------- --- Handle mouse and keyboard events. For this simple demo, just exit on a --- left click or when q is pressed. --------------------------------------------------------------------------------- -keyboardMouseHandler :: KeyboardMouseCallback -keyboardMouseHandler (MouseButton LeftButton)_ _ _ = exitWith ExitSuccess -keyboardMouseHandler (Char 'q') _ _ _ = exitWith ExitSuccess -keyboardMouseHandler _ _ _ _ = postRedisplay Nothing - --------------------------------------------------------------------------------- --- Reset the viewport for window changes. --------------------------------------------------------------------------------- -reshape :: ReshapeCallback -reshape size@(Size width height) = - unless (height == 0) $ do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 90 (fromIntegral width / fromIntegral height) 1 100 - - matrixMode $= Modelview 0 - --------------------------------------------------------------------------------- --- Clear and redraw the scene. --------------------------------------------------------------------------------- -display :: DisplayCallback -display = do - -- set up the camera - loadIdentity - lookAt (Vertex3 0 1 6) (Vertex3 0 0 0) (Vector3 0 1 0) - - -- clear the screen - clear [ ColorBuffer, DepthBuffer ] - - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - - -- draw a triangle - renderPrimitive Triangles $ do - color3f (Color3 1 0 0) - vertex3f (Vertex3 2 2.5 (-1)) - color3f (Color3 0 1 0) - vertex3f (Vertex3 (-3.5) (-2.5) (-1)) - color3f (Color3 0 0 1) - vertex3f (Vertex3 2 (-4) 0) - - -- draw a polygon - renderPrimitive Polygon $ do - color3f (Color3 1 1 1) - vertex3f (Vertex3 (-1) 2 0) - color3f (Color3 1 1 0) - vertex3f (Vertex3 (-3) (-0.5) 0) - color3f (Color3 0 1 1) - vertex3f (Vertex3 (-1.5) (-3) 0) - color3f (Color3 0 0 0) - vertex3f (Vertex3 1 (-2) 0) - color3f (Color3 1 0 1) - vertex3f (Vertex3 1 1 0) - - -- draw everything and swap the display buffer - swapBuffers +{- + Simple.hs (adapted from Simple.cpp which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2004-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( unless ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT hiding ( initialize ) + +-------------------------------------------------------------------------------- +-- Setup GLUT and OpenGL, drop into the event loop. +-------------------------------------------------------------------------------- +main :: IO () +main = do + -- Setup the basic GLUT stuff + _ <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] + + -- Create the window + initialWindowSize $= Size 1024 768 + initialWindowPosition $= Position 100 150 + _ <- createWindow "BOGLGP - Chapter 1 - Simple" + + initialize + + -- Register the event callback functions + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboardMouseHandler + -- No need for an idle callback here, this would just hog the CPU + -- without any visible effect + + -- At this point, control is relinquished to the GLUT event handler. + -- Control is returned as events occur, via the callback functions. + mainLoop + +-------------------------------------------------------------------------------- +-- One time setup, including creating menus, creating a light, setting the +-- shading mode and clear color, and loading textures. +-------------------------------------------------------------------------------- +initialize :: IO () +initialize = do + -- set up the only meny + attachMenu RightButton (Menu [MenuEntry "Exit" (exitWith ExitSuccess)]) + + depthFunc $= Just Less + +-------------------------------------------------------------------------------- +-- Handle mouse and keyboard events. For this simple demo, just exit on a +-- left click or when q is pressed. +-------------------------------------------------------------------------------- +keyboardMouseHandler :: KeyboardMouseCallback +keyboardMouseHandler (MouseButton LeftButton)_ _ _ = exitWith ExitSuccess +keyboardMouseHandler (Char 'q') _ _ _ = exitWith ExitSuccess +keyboardMouseHandler _ _ _ _ = postRedisplay Nothing + +-------------------------------------------------------------------------------- +-- Reset the viewport for window changes. +-------------------------------------------------------------------------------- +reshape :: ReshapeCallback +reshape size@(Size width height) = + unless (height == 0) $ do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 90 (fromIntegral width / fromIntegral height) 1 100 + + matrixMode $= Modelview 0 + +-------------------------------------------------------------------------------- +-- Clear and redraw the scene. +-------------------------------------------------------------------------------- +display :: DisplayCallback +display = do + -- set up the camera + loadIdentity + lookAt (Vertex3 0 1 6) (Vertex3 0 0 0) (Vector3 0 1 0) + + -- clear the screen + clear [ ColorBuffer, DepthBuffer ] + + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + + -- draw a triangle + renderPrimitive Triangles $ do + color3f (Color3 1 0 0) + vertex3f (Vertex3 2 2.5 (-1)) + color3f (Color3 0 1 0) + vertex3f (Vertex3 (-3.5) (-2.5) (-1)) + color3f (Color3 0 0 1) + vertex3f (Vertex3 2 (-4) 0) + + -- draw a polygon + renderPrimitive Polygon $ do + color3f (Color3 1 1 1) + vertex3f (Vertex3 (-1) 2 0) + color3f (Color3 1 1 0) + vertex3f (Vertex3 (-3) (-0.5) 0) + color3f (Color3 0 1 1) + vertex3f (Vertex3 (-1.5) (-3) 0) + color3f (Color3 0 0 0) + vertex3f (Vertex3 1 (-2) 0) + color3f (Color3 1 0 1) + vertex3f (Vertex3 1 1 0) + + -- draw everything and swap the display buffer + swapBuffers diff --git a/examples/BOGLGP/Chapter02/Makefile b/examples/BOGLGP/Chapter02/Makefile --- a/examples/BOGLGP/Chapter02/Makefile +++ b/examples/BOGLGP/Chapter02/Makefile @@ -1,1 +1,1 @@ -include ../../examples.mk +include ../../examples.mk diff --git a/examples/BOGLGP/Chapter02/OnYourOwn1.hs b/examples/BOGLGP/Chapter02/OnYourOwn1.hs --- a/examples/BOGLGP/Chapter02/OnYourOwn1.hs +++ b/examples/BOGLGP/Chapter02/OnYourOwn1.hs @@ -1,230 +1,230 @@ -{- - OnYourOwn1.hs (adapted from OpenGLApplication which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2004-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE --} - -import Control.Monad ( when, unless ) -import Data.IORef ( IORef, newIORef ) -import Data.Maybe ( isJust ) -import Graphics.UI.GLUT hiding ( initialize ) -import System.Console.GetOpt -import System.Environment ( getProgName ) -import System.Exit ( exitWith, ExitCode(..) ) -import System.IO ( hPutStr, stderr ) - --------------------------------------------------------------------------------- --- Setup GLUT and OpenGL, drop into the event loop. --------------------------------------------------------------------------------- -main :: IO () -main = do - -- Setup the basic GLUT stuff - (_, args) <- getArgsAndInitialize - opts <- parseOptions args - initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] - (if useFullscreen opts then fullscreenMode else windowedMode) opts - - state <- initialize - - -- Register the event callback functions - displayCallback $= do render state; swapBuffers - reshapeCallback $= Just setupProjection - keyboardMouseCallback $= Just keyboardMouseHandler - idleCallback $= Just (do prepare state; postRedisplay Nothing) - - -- At this point, control is relinquished to the GLUT event handler. - -- Control is returned as events occur, via the callback functions. - mainLoop - -fullscreenMode :: Options -> IO () -fullscreenMode opts = do - let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :)) - gameModeCapabilities $= - (addCapability GameModeWidth (Just (windowWidth opts)) . - addCapability GameModeHeight (Just (windowHeight opts)) . - addCapability GameModeBitsPerPlane (bpp opts) . - addCapability GameModeRefreshRate (refreshRate opts)) [] - _ <- enterGameMode - maybeWin <- get currentWindow - if isJust maybeWin - then cursor $= None - else do - hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n" - windowedMode (opts { useFullscreen = False } ) - -windowedMode :: Options -> IO () -windowedMode opts = do - initialWindowSize $= - Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) - _ <- createWindow "BOGLGP - Chapter 2 - On Your Own 1" - return () - --------------------------------------------------------------------------------- --- Option handling --------------------------------------------------------------------------------- -data Options = Options { - useFullscreen :: Bool, - windowWidth :: Int, - windowHeight :: Int, - bpp :: Maybe Int, - refreshRate :: Maybe Int - } - -startOpt :: Options -startOpt = Options { - useFullscreen = False, - windowWidth = 800, - windowHeight = 600, - bpp = Nothing, - refreshRate = Nothing - } - -options :: [OptDescr (Options -> IO Options)] -options = [ - Option ['f'] ["fullscreen"] - (NoArg (\opt -> return opt { useFullscreen = True })) - "use fullscreen mode if possible", - Option ['w'] ["width"] - (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg - return opt { windowWidth = w }) - "WIDTH") - "use window width WIDTH", - Option ['h'] ["height"] - (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg - return opt { windowHeight = h }) - "HEIGHT") - "use window height HEIGHT", - Option ['b'] ["bpp"] - (ReqArg (\arg opt -> do b <- readInt "BPP" arg - return opt { bpp = Just b }) - "BPP") - "use BPP bits per plane (ignored in windowed mode)", - Option ['r'] ["refresh-rate"] - (ReqArg (\arg opt -> do r <- readInt "HZ" arg - return opt { refreshRate = Just r }) - "HZ") - "use refresh rate HZ (ignored in windowed mode)", - Option ['?'] ["help"] - (NoArg (\_ -> do usage >>= putStr - safeExitWith ExitSuccess)) - "show help" ] - -readInt :: String -> String -> IO Int -readInt name arg = - case reads arg of - ((x,[]) : _) -> return x - _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"] - -usage :: IO String -usage = do - progName <- getProgName - return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options - -parseOptions :: [String] -> IO Options -parseOptions args = do - let (optsActions, nonOptions, errs) = getOpt Permute options args - unless (null nonOptions && null errs) (dieWith errs) - foldl (>>=) (return startOpt) optsActions - -dieWith :: [String] -> IO a -dieWith errs = do - u <- usage - mapM_ (hPutStr stderr) (errs ++ [u]) - safeExitWith (ExitFailure 1) - --------------------------------------------------------------------------------- --- Handle mouse and keyboard events. For this simple demo, just exit when --- ESCAPE is pressed. --------------------------------------------------------------------------------- -keyboardMouseHandler :: KeyboardMouseCallback -keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess -keyboardMouseHandler _ _ _ _ = return () - -safeExitWith :: ExitCode -> IO a -safeExitWith code = do - gma <- get gameModeActive - when gma leaveGameMode - exitWith code - --------------------------------------------------------------------------------- --- The globale state, which is only the current angle in this simple demo. --- We don't need the window dimensions here, they are not used and would --- be easily available via GLUT anyway. --------------------------------------------------------------------------------- -data State = State { angle :: IORef GLfloat } - -makeState :: IO State -makeState = do - a <- newIORef 0 - return $ State { angle = a } - --------------------------------------------------------------------------------- --- Do one time setup, i.e. set the clear color and create the global state. --------------------------------------------------------------------------------- -initialize :: IO State -initialize = do - -- clear to white background - clearColor $= Color4 1 1 1 0 - - makeState - --------------------------------------------------------------------------------- --- Reset the viewport for window changes. --------------------------------------------------------------------------------- -setupProjection :: ReshapeCallback -setupProjection (Size width height) = do - -- don't want a divide by zero - let h = max 1 height - -- reset the viewport to new dimensions - viewport $= (Position 0 0, Size width h) - -- set projection matrix as the current matrix - matrixMode $= Projection - -- reset projection matrix - loadIdentity - - -- calculate aspect ratio of window - perspective 52 (fromIntegral width / fromIntegral h) 1 1000 - - -- set modelview matrix - matrixMode $= Modelview 0 - -- reset modelview matrix - loadIdentity - --------------------------------------------------------------------------------- --- Perform any data-specific updates for a frame. Here we only increment the --- angle for the rotation of the triangle. --------------------------------------------------------------------------------- -prepare :: State -> IdleCallback -prepare state = do - angle state $~ (+ 0.1) - --------------------------------------------------------------------------------- --- Clear and redraw the scene. --------------------------------------------------------------------------------- -render :: State -> DisplayCallback -render state = do - -- clear screen and depth buffer - clear [ ColorBuffer, DepthBuffer ] - loadIdentity - - -- resolve overloading, not needed in "real" programs - let translate3f = translate :: Vector3 GLfloat -> IO () - color3f = color :: Color3 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - - -- move back 5 units and rotate about all 3 axes - translate3f (Vector3 0 0 (-5)) - a <- get (angle state) - rotate a (Vector3 1 0 0) - rotate a (Vector3 0 1 0) - rotate a (Vector3 0 0 1) - - -- red color - color3f (Color3 1 0 0) - - -- draw the triangle such that the rotation point is in the center - renderPrimitive Triangles $ do - vertex3f (Vertex3 1 (-1) 0) - vertex3f (Vertex3 (-1) (-1) 0) - vertex3f (Vertex3 0 1 0) +{- + OnYourOwn1.hs (adapted from OpenGLApplication which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2004-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( when, unless ) +import Data.IORef ( IORef, newIORef ) +import Data.Maybe ( isJust ) +import Graphics.UI.GLUT hiding ( initialize ) +import System.Console.GetOpt +import System.Environment ( getProgName ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.IO ( hPutStr, stderr ) + +-------------------------------------------------------------------------------- +-- Setup GLUT and OpenGL, drop into the event loop. +-------------------------------------------------------------------------------- +main :: IO () +main = do + -- Setup the basic GLUT stuff + (_, args) <- getArgsAndInitialize + opts <- parseOptions args + initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] + (if useFullscreen opts then fullscreenMode else windowedMode) opts + + state <- initialize + + -- Register the event callback functions + displayCallback $= do render state; swapBuffers + reshapeCallback $= Just setupProjection + keyboardMouseCallback $= Just keyboardMouseHandler + idleCallback $= Just (do prepare state; postRedisplay Nothing) + + -- At this point, control is relinquished to the GLUT event handler. + -- Control is returned as events occur, via the callback functions. + mainLoop + +fullscreenMode :: Options -> IO () +fullscreenMode opts = do + let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :)) + gameModeCapabilities $= + (addCapability GameModeWidth (Just (windowWidth opts)) . + addCapability GameModeHeight (Just (windowHeight opts)) . + addCapability GameModeBitsPerPlane (bpp opts) . + addCapability GameModeRefreshRate (refreshRate opts)) [] + _ <- enterGameMode + maybeWin <- get currentWindow + if isJust maybeWin + then cursor $= None + else do + hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n" + windowedMode (opts { useFullscreen = False } ) + +windowedMode :: Options -> IO () +windowedMode opts = do + initialWindowSize $= + Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) + _ <- createWindow "BOGLGP - Chapter 2 - On Your Own 1" + return () + +-------------------------------------------------------------------------------- +-- Option handling +-------------------------------------------------------------------------------- +data Options = Options { + useFullscreen :: Bool, + windowWidth :: Int, + windowHeight :: Int, + bpp :: Maybe Int, + refreshRate :: Maybe Int + } + +startOpt :: Options +startOpt = Options { + useFullscreen = False, + windowWidth = 800, + windowHeight = 600, + bpp = Nothing, + refreshRate = Nothing + } + +options :: [OptDescr (Options -> IO Options)] +options = [ + Option ['f'] ["fullscreen"] + (NoArg (\opt -> return opt { useFullscreen = True })) + "use fullscreen mode if possible", + Option ['w'] ["width"] + (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg + return opt { windowWidth = w }) + "WIDTH") + "use window width WIDTH", + Option ['h'] ["height"] + (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg + return opt { windowHeight = h }) + "HEIGHT") + "use window height HEIGHT", + Option ['b'] ["bpp"] + (ReqArg (\arg opt -> do b <- readInt "BPP" arg + return opt { bpp = Just b }) + "BPP") + "use BPP bits per plane (ignored in windowed mode)", + Option ['r'] ["refresh-rate"] + (ReqArg (\arg opt -> do r <- readInt "HZ" arg + return opt { refreshRate = Just r }) + "HZ") + "use refresh rate HZ (ignored in windowed mode)", + Option ['?'] ["help"] + (NoArg (\_ -> do usage >>= putStr + safeExitWith ExitSuccess)) + "show help" ] + +readInt :: String -> String -> IO Int +readInt name arg = + case reads arg of + ((x,[]) : _) -> return x + _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"] + +usage :: IO String +usage = do + progName <- getProgName + return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options + +parseOptions :: [String] -> IO Options +parseOptions args = do + let (optsActions, nonOptions, errs) = getOpt Permute options args + unless (null nonOptions && null errs) (dieWith errs) + foldl (>>=) (return startOpt) optsActions + +dieWith :: [String] -> IO a +dieWith errs = do + u <- usage + mapM_ (hPutStr stderr) (errs ++ [u]) + safeExitWith (ExitFailure 1) + +-------------------------------------------------------------------------------- +-- Handle mouse and keyboard events. For this simple demo, just exit when +-- ESCAPE is pressed. +-------------------------------------------------------------------------------- +keyboardMouseHandler :: KeyboardMouseCallback +keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess +keyboardMouseHandler _ _ _ _ = return () + +safeExitWith :: ExitCode -> IO a +safeExitWith code = do + gma <- get gameModeActive + when gma leaveGameMode + exitWith code + +-------------------------------------------------------------------------------- +-- The globale state, which is only the current angle in this simple demo. +-- We don't need the window dimensions here, they are not used and would +-- be easily available via GLUT anyway. +-------------------------------------------------------------------------------- +data State = State { angle :: IORef GLfloat } + +makeState :: IO State +makeState = do + a <- newIORef 0 + return $ State { angle = a } + +-------------------------------------------------------------------------------- +-- Do one time setup, i.e. set the clear color and create the global state. +-------------------------------------------------------------------------------- +initialize :: IO State +initialize = do + -- clear to white background + clearColor $= Color4 1 1 1 0 + + makeState + +-------------------------------------------------------------------------------- +-- Reset the viewport for window changes. +-------------------------------------------------------------------------------- +setupProjection :: ReshapeCallback +setupProjection (Size width height) = do + -- don't want a divide by zero + let h = max 1 height + -- reset the viewport to new dimensions + viewport $= (Position 0 0, Size width h) + -- set projection matrix as the current matrix + matrixMode $= Projection + -- reset projection matrix + loadIdentity + + -- calculate aspect ratio of window + perspective 52 (fromIntegral width / fromIntegral h) 1 1000 + + -- set modelview matrix + matrixMode $= Modelview 0 + -- reset modelview matrix + loadIdentity + +-------------------------------------------------------------------------------- +-- Perform any data-specific updates for a frame. Here we only increment the +-- angle for the rotation of the triangle. +-------------------------------------------------------------------------------- +prepare :: State -> IdleCallback +prepare state = do + angle state $~ (+ 0.1) + +-------------------------------------------------------------------------------- +-- Clear and redraw the scene. +-------------------------------------------------------------------------------- +render :: State -> DisplayCallback +render state = do + -- clear screen and depth buffer + clear [ ColorBuffer, DepthBuffer ] + loadIdentity + + -- resolve overloading, not needed in "real" programs + let translate3f = translate :: Vector3 GLfloat -> IO () + color3f = color :: Color3 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + + -- move back 5 units and rotate about all 3 axes + translate3f (Vector3 0 0 (-5)) + a <- get (angle state) + rotate a (Vector3 1 0 0) + rotate a (Vector3 0 1 0) + rotate a (Vector3 0 0 1) + + -- red color + color3f (Color3 1 0 0) + + -- draw the triangle such that the rotation point is in the center + renderPrimitive Triangles $ do + vertex3f (Vertex3 1 (-1) 0) + vertex3f (Vertex3 (-1) (-1) 0) + vertex3f (Vertex3 0 1 0) diff --git a/examples/BOGLGP/Chapter02/OpenGLApplication.hs b/examples/BOGLGP/Chapter02/OpenGLApplication.hs --- a/examples/BOGLGP/Chapter02/OpenGLApplication.hs +++ b/examples/BOGLGP/Chapter02/OpenGLApplication.hs @@ -1,230 +1,230 @@ -{- - OpenGLApplication.hs (adapted from OpenGLApplication which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2004-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE --} - -import Control.Monad ( when, unless ) -import Data.IORef ( IORef, newIORef ) -import Data.Maybe ( isJust ) -import Graphics.UI.GLUT hiding ( initialize ) -import System.Console.GetOpt -import System.Environment ( getProgName ) -import System.Exit ( exitWith, ExitCode(..) ) -import System.IO ( hPutStr, stderr ) - --------------------------------------------------------------------------------- --- Setup GLUT and OpenGL, drop into the event loop. --------------------------------------------------------------------------------- -main :: IO () -main = do - -- Setup the basic GLUT stuff - (_, args) <- getArgsAndInitialize - opts <- parseOptions args - initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] - (if useFullscreen opts then fullscreenMode else windowedMode) opts - - state <- initialize - - -- Register the event callback functions - displayCallback $= do render state; swapBuffers - reshapeCallback $= Just setupProjection - keyboardMouseCallback $= Just keyboardMouseHandler - idleCallback $= Just (do prepare state; postRedisplay Nothing) - - -- At this point, control is relinquished to the GLUT event handler. - -- Control is returned as events occur, via the callback functions. - mainLoop - -fullscreenMode :: Options -> IO () -fullscreenMode opts = do - let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :)) - gameModeCapabilities $= - (addCapability GameModeWidth (Just (windowWidth opts)) . - addCapability GameModeHeight (Just (windowHeight opts)) . - addCapability GameModeBitsPerPlane (bpp opts) . - addCapability GameModeRefreshRate (refreshRate opts)) [] - _ <- enterGameMode - maybeWin <- get currentWindow - if isJust maybeWin - then cursor $= None - else do - hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n" - windowedMode (opts { useFullscreen = False } ) - -windowedMode :: Options -> IO () -windowedMode opts = do - initialWindowSize $= - Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) - _ <- createWindow "BOGLGP - Chapter 2 - OpenGL Application" - return () - --------------------------------------------------------------------------------- --- Option handling --------------------------------------------------------------------------------- -data Options = Options { - useFullscreen :: Bool, - windowWidth :: Int, - windowHeight :: Int, - bpp :: Maybe Int, - refreshRate :: Maybe Int - } - -startOpt :: Options -startOpt = Options { - useFullscreen = False, - windowWidth = 800, - windowHeight = 600, - bpp = Nothing, - refreshRate = Nothing - } - -options :: [OptDescr (Options -> IO Options)] -options = [ - Option ['f'] ["fullscreen"] - (NoArg (\opt -> return opt { useFullscreen = True })) - "use fullscreen mode if possible", - Option ['w'] ["width"] - (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg - return opt { windowWidth = w }) - "WIDTH") - "use window width WIDTH", - Option ['h'] ["height"] - (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg - return opt { windowHeight = h }) - "HEIGHT") - "use window height HEIGHT", - Option ['b'] ["bpp"] - (ReqArg (\arg opt -> do b <- readInt "BPP" arg - return opt { bpp = Just b }) - "BPP") - "use BPP bits per plane (ignored in windowed mode)", - Option ['r'] ["refresh-rate"] - (ReqArg (\arg opt -> do r <- readInt "HZ" arg - return opt { refreshRate = Just r }) - "HZ") - "use refresh rate HZ (ignored in windowed mode)", - Option ['?'] ["help"] - (NoArg (\_ -> do usage >>= putStr - safeExitWith ExitSuccess)) - "show help" ] - -readInt :: String -> String -> IO Int -readInt name arg = - case reads arg of - ((x,[]) : _) -> return x - _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"] - -usage :: IO String -usage = do - progName <- getProgName - return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options - -parseOptions :: [String] -> IO Options -parseOptions args = do - let (optsActions, nonOptions, errs) = getOpt Permute options args - unless (null nonOptions && null errs) (dieWith errs) - foldl (>>=) (return startOpt) optsActions - -dieWith :: [String] -> IO a -dieWith errs = do - u <- usage - mapM_ (hPutStr stderr) (errs ++ [u]) - safeExitWith (ExitFailure 1) - --------------------------------------------------------------------------------- --- Handle mouse and keyboard events. For this simple demo, just exit when --- ESCAPE is pressed. --------------------------------------------------------------------------------- -keyboardMouseHandler :: KeyboardMouseCallback -keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess -keyboardMouseHandler _ _ _ _ = return () - -safeExitWith :: ExitCode -> IO a -safeExitWith code = do - gma <- get gameModeActive - when gma leaveGameMode - exitWith code - --------------------------------------------------------------------------------- --- The globale state, which is only the current angle in this simple demo. --- We don't need the window dimensions here, they are not used and would --- be easily available via GLUT anyway. --------------------------------------------------------------------------------- -data State = State { angle :: IORef GLfloat } - -makeState :: IO State -makeState = do - a <- newIORef 0 - return $ State { angle = a } - --------------------------------------------------------------------------------- --- Do one time setup, i.e. set the clear color and create the global state. --------------------------------------------------------------------------------- -initialize :: IO State -initialize = do - -- clear to black background - clearColor $= Color4 0 0 0 0 - - makeState - --------------------------------------------------------------------------------- --- Reset the viewport for window changes. --------------------------------------------------------------------------------- -setupProjection :: ReshapeCallback -setupProjection (Size width height) = do - -- don't want a divide by zero - let h = max 1 height - -- reset the viewport to new dimensions - viewport $= (Position 0 0, Size width h) - -- set projection matrix as the current matrix - matrixMode $= Projection - -- reset projection matrix - loadIdentity - - -- calculate aspect ratio of window - perspective 52 (fromIntegral width / fromIntegral h) 1 1000 - - -- set modelview matrix - matrixMode $= Modelview 0 - -- reset modelview matrix - loadIdentity - --------------------------------------------------------------------------------- --- Perform any data-specific updates for a frame. Here we only increment the --- angle for the rotation of the triangle. --------------------------------------------------------------------------------- -prepare :: State -> IdleCallback -prepare state = do - angle state $~ (+ 0.1) - --------------------------------------------------------------------------------- --- Clear and redraw the scene. --------------------------------------------------------------------------------- -render :: State -> DisplayCallback -render state = do - -- clear screen and depth buffer - clear [ ColorBuffer, DepthBuffer ] - loadIdentity - - -- resolve overloading, not needed in "real" programs - let translate3f = translate :: Vector3 GLfloat -> IO () - color3f = color :: Color3 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - - -- move back 5 units and rotate about all 3 axes - translate3f (Vector3 0 0 (-5)) - a <- get (angle state) - rotate a (Vector3 1 0 0) - rotate a (Vector3 0 1 0) - rotate a (Vector3 0 0 1) - - -- lime greenish color - color3f (Color3 0.7 1 0.3) - - -- draw the triangle such that the rotation point is in the center - renderPrimitive Triangles $ do - vertex3f (Vertex3 1 (-1) 0) - vertex3f (Vertex3 (-1) (-1) 0) - vertex3f (Vertex3 0 1 0) +{- + OpenGLApplication.hs (adapted from OpenGLApplication which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2004-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( when, unless ) +import Data.IORef ( IORef, newIORef ) +import Data.Maybe ( isJust ) +import Graphics.UI.GLUT hiding ( initialize ) +import System.Console.GetOpt +import System.Environment ( getProgName ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.IO ( hPutStr, stderr ) + +-------------------------------------------------------------------------------- +-- Setup GLUT and OpenGL, drop into the event loop. +-------------------------------------------------------------------------------- +main :: IO () +main = do + -- Setup the basic GLUT stuff + (_, args) <- getArgsAndInitialize + opts <- parseOptions args + initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] + (if useFullscreen opts then fullscreenMode else windowedMode) opts + + state <- initialize + + -- Register the event callback functions + displayCallback $= do render state; swapBuffers + reshapeCallback $= Just setupProjection + keyboardMouseCallback $= Just keyboardMouseHandler + idleCallback $= Just (do prepare state; postRedisplay Nothing) + + -- At this point, control is relinquished to the GLUT event handler. + -- Control is returned as events occur, via the callback functions. + mainLoop + +fullscreenMode :: Options -> IO () +fullscreenMode opts = do + let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :)) + gameModeCapabilities $= + (addCapability GameModeWidth (Just (windowWidth opts)) . + addCapability GameModeHeight (Just (windowHeight opts)) . + addCapability GameModeBitsPerPlane (bpp opts) . + addCapability GameModeRefreshRate (refreshRate opts)) [] + _ <- enterGameMode + maybeWin <- get currentWindow + if isJust maybeWin + then cursor $= None + else do + hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n" + windowedMode (opts { useFullscreen = False } ) + +windowedMode :: Options -> IO () +windowedMode opts = do + initialWindowSize $= + Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) + _ <- createWindow "BOGLGP - Chapter 2 - OpenGL Application" + return () + +-------------------------------------------------------------------------------- +-- Option handling +-------------------------------------------------------------------------------- +data Options = Options { + useFullscreen :: Bool, + windowWidth :: Int, + windowHeight :: Int, + bpp :: Maybe Int, + refreshRate :: Maybe Int + } + +startOpt :: Options +startOpt = Options { + useFullscreen = False, + windowWidth = 800, + windowHeight = 600, + bpp = Nothing, + refreshRate = Nothing + } + +options :: [OptDescr (Options -> IO Options)] +options = [ + Option ['f'] ["fullscreen"] + (NoArg (\opt -> return opt { useFullscreen = True })) + "use fullscreen mode if possible", + Option ['w'] ["width"] + (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg + return opt { windowWidth = w }) + "WIDTH") + "use window width WIDTH", + Option ['h'] ["height"] + (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg + return opt { windowHeight = h }) + "HEIGHT") + "use window height HEIGHT", + Option ['b'] ["bpp"] + (ReqArg (\arg opt -> do b <- readInt "BPP" arg + return opt { bpp = Just b }) + "BPP") + "use BPP bits per plane (ignored in windowed mode)", + Option ['r'] ["refresh-rate"] + (ReqArg (\arg opt -> do r <- readInt "HZ" arg + return opt { refreshRate = Just r }) + "HZ") + "use refresh rate HZ (ignored in windowed mode)", + Option ['?'] ["help"] + (NoArg (\_ -> do usage >>= putStr + safeExitWith ExitSuccess)) + "show help" ] + +readInt :: String -> String -> IO Int +readInt name arg = + case reads arg of + ((x,[]) : _) -> return x + _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"] + +usage :: IO String +usage = do + progName <- getProgName + return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options + +parseOptions :: [String] -> IO Options +parseOptions args = do + let (optsActions, nonOptions, errs) = getOpt Permute options args + unless (null nonOptions && null errs) (dieWith errs) + foldl (>>=) (return startOpt) optsActions + +dieWith :: [String] -> IO a +dieWith errs = do + u <- usage + mapM_ (hPutStr stderr) (errs ++ [u]) + safeExitWith (ExitFailure 1) + +-------------------------------------------------------------------------------- +-- Handle mouse and keyboard events. For this simple demo, just exit when +-- ESCAPE is pressed. +-------------------------------------------------------------------------------- +keyboardMouseHandler :: KeyboardMouseCallback +keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess +keyboardMouseHandler _ _ _ _ = return () + +safeExitWith :: ExitCode -> IO a +safeExitWith code = do + gma <- get gameModeActive + when gma leaveGameMode + exitWith code + +-------------------------------------------------------------------------------- +-- The globale state, which is only the current angle in this simple demo. +-- We don't need the window dimensions here, they are not used and would +-- be easily available via GLUT anyway. +-------------------------------------------------------------------------------- +data State = State { angle :: IORef GLfloat } + +makeState :: IO State +makeState = do + a <- newIORef 0 + return $ State { angle = a } + +-------------------------------------------------------------------------------- +-- Do one time setup, i.e. set the clear color and create the global state. +-------------------------------------------------------------------------------- +initialize :: IO State +initialize = do + -- clear to black background + clearColor $= Color4 0 0 0 0 + + makeState + +-------------------------------------------------------------------------------- +-- Reset the viewport for window changes. +-------------------------------------------------------------------------------- +setupProjection :: ReshapeCallback +setupProjection (Size width height) = do + -- don't want a divide by zero + let h = max 1 height + -- reset the viewport to new dimensions + viewport $= (Position 0 0, Size width h) + -- set projection matrix as the current matrix + matrixMode $= Projection + -- reset projection matrix + loadIdentity + + -- calculate aspect ratio of window + perspective 52 (fromIntegral width / fromIntegral h) 1 1000 + + -- set modelview matrix + matrixMode $= Modelview 0 + -- reset modelview matrix + loadIdentity + +-------------------------------------------------------------------------------- +-- Perform any data-specific updates for a frame. Here we only increment the +-- angle for the rotation of the triangle. +-------------------------------------------------------------------------------- +prepare :: State -> IdleCallback +prepare state = do + angle state $~ (+ 0.1) + +-------------------------------------------------------------------------------- +-- Clear and redraw the scene. +-------------------------------------------------------------------------------- +render :: State -> DisplayCallback +render state = do + -- clear screen and depth buffer + clear [ ColorBuffer, DepthBuffer ] + loadIdentity + + -- resolve overloading, not needed in "real" programs + let translate3f = translate :: Vector3 GLfloat -> IO () + color3f = color :: Color3 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + + -- move back 5 units and rotate about all 3 axes + translate3f (Vector3 0 0 (-5)) + a <- get (angle state) + rotate a (Vector3 1 0 0) + rotate a (Vector3 0 1 0) + rotate a (Vector3 0 0 1) + + -- lime greenish color + color3f (Color3 0.7 1 0.3) + + -- draw the triangle such that the rotation point is in the center + renderPrimitive Triangles $ do + vertex3f (Vertex3 1 (-1) 0) + vertex3f (Vertex3 (-1) (-1) 0) + vertex3f (Vertex3 0 1 0) diff --git a/examples/BOGLGP/Chapter03/Lines.hs b/examples/BOGLGP/Chapter03/Lines.hs --- a/examples/BOGLGP/Chapter03/Lines.hs +++ b/examples/BOGLGP/Chapter03/Lines.hs @@ -1,210 +1,210 @@ -{- - Lines.hs (adapted from Lines which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2004-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE --} - -import Control.Monad ( when, unless, zipWithM_ ) -import Data.Maybe ( isJust ) -import Graphics.UI.GLUT hiding ( initialize ) -import System.Console.GetOpt -import System.Environment ( getProgName ) -import System.Exit ( exitWith, ExitCode(..) ) -import System.IO ( hPutStr, stderr ) - --------------------------------------------------------------------------------- --- Setup GLUT and OpenGL, drop into the event loop. --------------------------------------------------------------------------------- -main :: IO () -main = do - -- Setup the basic GLUT stuff - (_, args) <- getArgsAndInitialize - opts <- parseOptions args - initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] - (if useFullscreen opts then fullscreenMode else windowedMode) opts - - initialize - - -- Register the event callback functions - displayCallback $= do render; swapBuffers - reshapeCallback $= Just setupProjection - keyboardMouseCallback $= Just keyboardMouseHandler - -- No need for an idle callback here, this would just hog the CPU - -- without any visible effect - - -- At this point, control is relinquished to the GLUT event handler. - -- Control is returned as events occur, via the callback functions. - mainLoop - -fullscreenMode :: Options -> IO () -fullscreenMode opts = do - let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :)) - gameModeCapabilities $= - (addCapability GameModeWidth (Just (windowWidth opts)) . - addCapability GameModeHeight (Just (windowHeight opts)) . - addCapability GameModeBitsPerPlane (bpp opts) . - addCapability GameModeRefreshRate (refreshRate opts)) [] - _ <- enterGameMode - maybeWin <- get currentWindow - if isJust maybeWin - then cursor $= None - else do - hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n" - windowedMode (opts { useFullscreen = False } ) - -windowedMode :: Options -> IO () -windowedMode opts = do - initialWindowSize $= - Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) - _ <- createWindow "BOGLGP - Chapter 3 - Lines" - return () - --------------------------------------------------------------------------------- --- Option handling --------------------------------------------------------------------------------- -data Options = Options { - useFullscreen :: Bool, - windowWidth :: Int, - windowHeight :: Int, - bpp :: Maybe Int, - refreshRate :: Maybe Int - } - -startOpt :: Options -startOpt = Options { - useFullscreen = False, - windowWidth = 800, - windowHeight = 600, - bpp = Nothing, - refreshRate = Nothing - } - -options :: [OptDescr (Options -> IO Options)] -options = [ - Option ['f'] ["fullscreen"] - (NoArg (\opt -> return opt { useFullscreen = True })) - "use fullscreen mode if possible", - Option ['w'] ["width"] - (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg - return opt { windowWidth = w }) - "WIDTH") - "use window width WIDTH", - Option ['h'] ["height"] - (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg - return opt { windowHeight = h }) - "HEIGHT") - "use window height HEIGHT", - Option ['b'] ["bpp"] - (ReqArg (\arg opt -> do b <- readInt "BPP" arg - return opt { bpp = Just b }) - "BPP") - "use BPP bits per plane (ignored in windowed mode)", - Option ['r'] ["refresh-rate"] - (ReqArg (\arg opt -> do r <- readInt "HZ" arg - return opt { refreshRate = Just r }) - "HZ") - "use refresh rate HZ (ignored in windowed mode)", - Option ['?'] ["help"] - (NoArg (\_ -> do usage >>= putStr - safeExitWith ExitSuccess)) - "show help" ] - -readInt :: String -> String -> IO Int -readInt name arg = - case reads arg of - ((x,[]) : _) -> return x - _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"] - -usage :: IO String -usage = do - progName <- getProgName - return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options - -parseOptions :: [String] -> IO Options -parseOptions args = do - let (optsActions, nonOptions, errs) = getOpt Permute options args - unless (null nonOptions && null errs) (dieWith errs) - foldl (>>=) (return startOpt) optsActions - -dieWith :: [String] -> IO a -dieWith errs = do - u <- usage - mapM_ (hPutStr stderr) (errs ++ [u]) - safeExitWith (ExitFailure 1) - --------------------------------------------------------------------------------- --- Handle mouse and keyboard events. For this simple demo, just exit when --- ESCAPE is pressed. --------------------------------------------------------------------------------- -keyboardMouseHandler :: KeyboardMouseCallback -keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess -keyboardMouseHandler _ _ _ _ = return () - -safeExitWith :: ExitCode -> IO a -safeExitWith code = do - gma <- get gameModeActive - when gma leaveGameMode - exitWith code - --------------------------------------------------------------------------------- --- Do one time setup, i.e. set the clear color. --------------------------------------------------------------------------------- -initialize :: IO () -initialize = clearColor $= Color4 0 0 0 0 - --------------------------------------------------------------------------------- --- Reset the viewport for window changes. --------------------------------------------------------------------------------- -setupProjection :: ReshapeCallback -setupProjection (Size width height) = do - -- don't want a divide by zero - let h = max 1 height - -- reset the viewport to new dimensions - viewport $= (Position 0 0, Size width h) - -- set projection matrix as the current matrix - matrixMode $= Projection - -- reset projection matrix - loadIdentity - - -- calculate aspect ratio of window - perspective 52 (fromIntegral width / fromIntegral h) 1 1000 - - -- set modelview matrix - matrixMode $= Modelview 0 - -- reset modelview matrix - loadIdentity - --------------------------------------------------------------------------------- --- Clear and redraw the scene. --------------------------------------------------------------------------------- -render :: DisplayCallback -render = do - -- clear screen and depth buffer - clear [ ColorBuffer, DepthBuffer ] - loadIdentity - lookAt (Vertex3 0 10 0.1) (Vertex3 0 0 0) (Vector3 0 1 0) - - -- function to draw a series of lines of increasing width - let drawLines x = zipWithM_ (\lw line -> do - -- set the line width - lineWidth $= lw - - -- draw the line - renderPrimitive Lines $ do - vertex (Vertex3 x 0 (line - 3)) - vertex (Vertex3 (x + 4) 0 (line - 3))) - [ 0.5 .. ] - [ 0, 0.5 .. 6.5 :: GLfloat ] - - -- draw a series of lines of increasing width without stippling - drawLines (-5) - - -- set the stipple pattern, 0xAAAA = 1010 1010 1010 1010 - lineStipple $= Just (2, 0xAAAA) - - -- draw a series of lines of increasing width with stippling - drawLines 1 - - -- disable stippling - lineStipple $= Nothing +{- + Lines.hs (adapted from Lines which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2004-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( when, unless, zipWithM_ ) +import Data.Maybe ( isJust ) +import Graphics.UI.GLUT hiding ( initialize ) +import System.Console.GetOpt +import System.Environment ( getProgName ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.IO ( hPutStr, stderr ) + +-------------------------------------------------------------------------------- +-- Setup GLUT and OpenGL, drop into the event loop. +-------------------------------------------------------------------------------- +main :: IO () +main = do + -- Setup the basic GLUT stuff + (_, args) <- getArgsAndInitialize + opts <- parseOptions args + initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] + (if useFullscreen opts then fullscreenMode else windowedMode) opts + + initialize + + -- Register the event callback functions + displayCallback $= do render; swapBuffers + reshapeCallback $= Just setupProjection + keyboardMouseCallback $= Just keyboardMouseHandler + -- No need for an idle callback here, this would just hog the CPU + -- without any visible effect + + -- At this point, control is relinquished to the GLUT event handler. + -- Control is returned as events occur, via the callback functions. + mainLoop + +fullscreenMode :: Options -> IO () +fullscreenMode opts = do + let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :)) + gameModeCapabilities $= + (addCapability GameModeWidth (Just (windowWidth opts)) . + addCapability GameModeHeight (Just (windowHeight opts)) . + addCapability GameModeBitsPerPlane (bpp opts) . + addCapability GameModeRefreshRate (refreshRate opts)) [] + _ <- enterGameMode + maybeWin <- get currentWindow + if isJust maybeWin + then cursor $= None + else do + hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n" + windowedMode (opts { useFullscreen = False } ) + +windowedMode :: Options -> IO () +windowedMode opts = do + initialWindowSize $= + Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) + _ <- createWindow "BOGLGP - Chapter 3 - Lines" + return () + +-------------------------------------------------------------------------------- +-- Option handling +-------------------------------------------------------------------------------- +data Options = Options { + useFullscreen :: Bool, + windowWidth :: Int, + windowHeight :: Int, + bpp :: Maybe Int, + refreshRate :: Maybe Int + } + +startOpt :: Options +startOpt = Options { + useFullscreen = False, + windowWidth = 800, + windowHeight = 600, + bpp = Nothing, + refreshRate = Nothing + } + +options :: [OptDescr (Options -> IO Options)] +options = [ + Option ['f'] ["fullscreen"] + (NoArg (\opt -> return opt { useFullscreen = True })) + "use fullscreen mode if possible", + Option ['w'] ["width"] + (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg + return opt { windowWidth = w }) + "WIDTH") + "use window width WIDTH", + Option ['h'] ["height"] + (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg + return opt { windowHeight = h }) + "HEIGHT") + "use window height HEIGHT", + Option ['b'] ["bpp"] + (ReqArg (\arg opt -> do b <- readInt "BPP" arg + return opt { bpp = Just b }) + "BPP") + "use BPP bits per plane (ignored in windowed mode)", + Option ['r'] ["refresh-rate"] + (ReqArg (\arg opt -> do r <- readInt "HZ" arg + return opt { refreshRate = Just r }) + "HZ") + "use refresh rate HZ (ignored in windowed mode)", + Option ['?'] ["help"] + (NoArg (\_ -> do usage >>= putStr + safeExitWith ExitSuccess)) + "show help" ] + +readInt :: String -> String -> IO Int +readInt name arg = + case reads arg of + ((x,[]) : _) -> return x + _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"] + +usage :: IO String +usage = do + progName <- getProgName + return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options + +parseOptions :: [String] -> IO Options +parseOptions args = do + let (optsActions, nonOptions, errs) = getOpt Permute options args + unless (null nonOptions && null errs) (dieWith errs) + foldl (>>=) (return startOpt) optsActions + +dieWith :: [String] -> IO a +dieWith errs = do + u <- usage + mapM_ (hPutStr stderr) (errs ++ [u]) + safeExitWith (ExitFailure 1) + +-------------------------------------------------------------------------------- +-- Handle mouse and keyboard events. For this simple demo, just exit when +-- ESCAPE is pressed. +-------------------------------------------------------------------------------- +keyboardMouseHandler :: KeyboardMouseCallback +keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess +keyboardMouseHandler _ _ _ _ = return () + +safeExitWith :: ExitCode -> IO a +safeExitWith code = do + gma <- get gameModeActive + when gma leaveGameMode + exitWith code + +-------------------------------------------------------------------------------- +-- Do one time setup, i.e. set the clear color. +-------------------------------------------------------------------------------- +initialize :: IO () +initialize = clearColor $= Color4 0 0 0 0 + +-------------------------------------------------------------------------------- +-- Reset the viewport for window changes. +-------------------------------------------------------------------------------- +setupProjection :: ReshapeCallback +setupProjection (Size width height) = do + -- don't want a divide by zero + let h = max 1 height + -- reset the viewport to new dimensions + viewport $= (Position 0 0, Size width h) + -- set projection matrix as the current matrix + matrixMode $= Projection + -- reset projection matrix + loadIdentity + + -- calculate aspect ratio of window + perspective 52 (fromIntegral width / fromIntegral h) 1 1000 + + -- set modelview matrix + matrixMode $= Modelview 0 + -- reset modelview matrix + loadIdentity + +-------------------------------------------------------------------------------- +-- Clear and redraw the scene. +-------------------------------------------------------------------------------- +render :: DisplayCallback +render = do + -- clear screen and depth buffer + clear [ ColorBuffer, DepthBuffer ] + loadIdentity + lookAt (Vertex3 0 10 0.1) (Vertex3 0 0 0) (Vector3 0 1 0) + + -- function to draw a series of lines of increasing width + let drawLines x = zipWithM_ (\lw line -> do + -- set the line width + lineWidth $= lw + + -- draw the line + renderPrimitive Lines $ do + vertex (Vertex3 x 0 (line - 3)) + vertex (Vertex3 (x + 4) 0 (line - 3))) + [ 0.5 .. ] + [ 0, 0.5 .. 6.5 :: GLfloat ] + + -- draw a series of lines of increasing width without stippling + drawLines (-5) + + -- set the stipple pattern, 0xAAAA = 1010 1010 1010 1010 + lineStipple $= Just (2, 0xAAAA) + + -- draw a series of lines of increasing width with stippling + drawLines 1 + + -- disable stippling + lineStipple $= Nothing diff --git a/examples/BOGLGP/Chapter03/Makefile b/examples/BOGLGP/Chapter03/Makefile --- a/examples/BOGLGP/Chapter03/Makefile +++ b/examples/BOGLGP/Chapter03/Makefile @@ -1,1 +1,1 @@ -include ../../examples.mk +include ../../examples.mk diff --git a/examples/BOGLGP/Chapter03/OnYourOwn1.hs b/examples/BOGLGP/Chapter03/OnYourOwn1.hs --- a/examples/BOGLGP/Chapter03/OnYourOwn1.hs +++ b/examples/BOGLGP/Chapter03/OnYourOwn1.hs @@ -1,217 +1,217 @@ -{- - OnYourOwn1.hs (adapted from OnYourOwn1 which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE --} - -import Control.Monad ( when, unless ) -import Data.Maybe ( isJust ) -import Graphics.UI.GLUT hiding ( initialize ) -import System.Console.GetOpt -import System.Environment ( getProgName ) -import System.Exit ( exitWith, ExitCode(..) ) -import System.IO ( hPutStr, stderr ) - --------------------------------------------------------------------------------- --- Setup GLUT and OpenGL, drop into the event loop. --------------------------------------------------------------------------------- -main :: IO () -main = do - -- Setup the basic GLUT stuff - (_, args) <- getArgsAndInitialize - opts <- parseOptions args - initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] - (if useFullscreen opts then fullscreenMode else windowedMode) opts - - initialize - - -- Register the event callback functions - displayCallback $= do render; swapBuffers - reshapeCallback $= Just setupProjection - keyboardMouseCallback $= Just keyboardMouseHandler - -- No need for an idle callback here, this would just hog the CPU - -- without any visible effect - - -- At this point, control is relinquished to the GLUT event handler. - -- Control is returned as events occur, via the callback functions. - mainLoop - -fullscreenMode :: Options -> IO () -fullscreenMode opts = do - let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :)) - gameModeCapabilities $= - (addCapability GameModeWidth (Just (windowWidth opts)) . - addCapability GameModeHeight (Just (windowHeight opts)) . - addCapability GameModeBitsPerPlane (bpp opts) . - addCapability GameModeRefreshRate (refreshRate opts)) [] - _ <- enterGameMode - maybeWin <- get currentWindow - if isJust maybeWin - then cursor $= None - else do - hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n" - windowedMode (opts { useFullscreen = False } ) - -windowedMode :: Options -> IO () -windowedMode opts = do - initialWindowSize $= - Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) - _ <- createWindow "BOGLGP - Chapter 3 - On Your Own 1" - return () - --------------------------------------------------------------------------------- --- Option handling --------------------------------------------------------------------------------- -data Options = Options { - useFullscreen :: Bool, - windowWidth :: Int, - windowHeight :: Int, - bpp :: Maybe Int, - refreshRate :: Maybe Int - } - -startOpt :: Options -startOpt = Options { - useFullscreen = False, - windowWidth = 800, - windowHeight = 600, - bpp = Nothing, - refreshRate = Nothing - } - -options :: [OptDescr (Options -> IO Options)] -options = [ - Option ['f'] ["fullscreen"] - (NoArg (\opt -> return opt { useFullscreen = True })) - "use fullscreen mode if possible", - Option ['w'] ["width"] - (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg - return opt { windowWidth = w }) - "WIDTH") - "use window width WIDTH", - Option ['h'] ["height"] - (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg - return opt { windowHeight = h }) - "HEIGHT") - "use window height HEIGHT", - Option ['b'] ["bpp"] - (ReqArg (\arg opt -> do b <- readInt "BPP" arg - return opt { bpp = Just b }) - "BPP") - "use BPP bits per plane (ignored in windowed mode)", - Option ['r'] ["refresh-rate"] - (ReqArg (\arg opt -> do r <- readInt "HZ" arg - return opt { refreshRate = Just r }) - "HZ") - "use refresh rate HZ (ignored in windowed mode)", - Option ['?'] ["help"] - (NoArg (\_ -> do usage >>= putStr - safeExitWith ExitSuccess)) - "show help" ] - -readInt :: String -> String -> IO Int -readInt name arg = - case reads arg of - ((x,[]) : _) -> return x - _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"] - -usage :: IO String -usage = do - progName <- getProgName - return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options - -parseOptions :: [String] -> IO Options -parseOptions args = do - let (optsActions, nonOptions, errs) = getOpt Permute options args - unless (null nonOptions && null errs) (dieWith errs) - foldl (>>=) (return startOpt) optsActions - -dieWith :: [String] -> IO a -dieWith errs = do - u <- usage - mapM_ (hPutStr stderr) (errs ++ [u]) - safeExitWith (ExitFailure 1) - --------------------------------------------------------------------------------- --- Handle mouse and keyboard events. For this simple demo, just exit when --- ESCAPE is pressed. --------------------------------------------------------------------------------- -keyboardMouseHandler :: KeyboardMouseCallback -keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess -keyboardMouseHandler _ _ _ _ = return () - -safeExitWith :: ExitCode -> IO a -safeExitWith code = do - gma <- get gameModeActive - when gma leaveGameMode - exitWith code - --------------------------------------------------------------------------------- --- Do one time setup, i.e. set the clear color. --------------------------------------------------------------------------------- -initialize :: IO () -initialize = do - -- clear to black background - clearColor $= Color4 0 0 0 0 - --------------------------------------------------------------------------------- --- Reset the viewport for window changes. --------------------------------------------------------------------------------- -setupProjection :: ReshapeCallback -setupProjection (Size width height) = do - -- don't want a divide by zero - let h = max 1 height - -- reset the viewport to new dimensions - viewport $= (Position 0 0, Size width h) - -- set projection matrix as the current matrix - matrixMode $= Projection - -- reset projection matrix - loadIdentity - - -- calculate aspect ratio of window - perspective 52 (fromIntegral width / fromIntegral h) 1 1000 - - -- set modelview matrix - matrixMode $= Modelview 0 - -- reset modelview matrix - loadIdentity - --------------------------------------------------------------------------------- --- Clear and redraw the scene. --------------------------------------------------------------------------------- -render :: DisplayCallback -render = do - -- clear screen and depth buffer - clear [ ColorBuffer, DepthBuffer ] - loadIdentity - lookAt (Vertex3 0 10 0.1) (Vertex3 0 0 0) (Vector3 0 1 0) - - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - - color3f (Color3 1 1 1) - - drawCircleApproximation 2 10 False - --- Hello, this is C... :-) -for :: [GLint] -> (GLint -> IO ()) -> IO () -for = flip mapM_ - -drawCircleApproximation :: GLfloat -> GLint -> Bool -> IO () -drawCircleApproximation radius numberOfSides edgeOnly = - -- if edge only, use line strips; otherwise, use polygons - renderPrimitive (if edgeOnly then LineStrip else Polygon) $ do - - -- calculate each vertex on the circle - for [ 0 .. numberOfSides - 1 ] $ \v -> do - - -- calculate the angle of the current vertex - let angle = fromIntegral v * 2 * pi / fromIntegral numberOfSides - - -- draw the current vertex at the correct radius - vertex (Vertex3 (cos angle * radius) 0 (sin angle * radius)) - - -- if drawing edge only, then need to complete the loop with first vertex - when edgeOnly $ - vertex (Vertex3 radius 0 0) +{- + OnYourOwn1.hs (adapted from OnYourOwn1 which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( when, unless ) +import Data.Maybe ( isJust ) +import Graphics.UI.GLUT hiding ( initialize ) +import System.Console.GetOpt +import System.Environment ( getProgName ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.IO ( hPutStr, stderr ) + +-------------------------------------------------------------------------------- +-- Setup GLUT and OpenGL, drop into the event loop. +-------------------------------------------------------------------------------- +main :: IO () +main = do + -- Setup the basic GLUT stuff + (_, args) <- getArgsAndInitialize + opts <- parseOptions args + initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] + (if useFullscreen opts then fullscreenMode else windowedMode) opts + + initialize + + -- Register the event callback functions + displayCallback $= do render; swapBuffers + reshapeCallback $= Just setupProjection + keyboardMouseCallback $= Just keyboardMouseHandler + -- No need for an idle callback here, this would just hog the CPU + -- without any visible effect + + -- At this point, control is relinquished to the GLUT event handler. + -- Control is returned as events occur, via the callback functions. + mainLoop + +fullscreenMode :: Options -> IO () +fullscreenMode opts = do + let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :)) + gameModeCapabilities $= + (addCapability GameModeWidth (Just (windowWidth opts)) . + addCapability GameModeHeight (Just (windowHeight opts)) . + addCapability GameModeBitsPerPlane (bpp opts) . + addCapability GameModeRefreshRate (refreshRate opts)) [] + _ <- enterGameMode + maybeWin <- get currentWindow + if isJust maybeWin + then cursor $= None + else do + hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n" + windowedMode (opts { useFullscreen = False } ) + +windowedMode :: Options -> IO () +windowedMode opts = do + initialWindowSize $= + Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) + _ <- createWindow "BOGLGP - Chapter 3 - On Your Own 1" + return () + +-------------------------------------------------------------------------------- +-- Option handling +-------------------------------------------------------------------------------- +data Options = Options { + useFullscreen :: Bool, + windowWidth :: Int, + windowHeight :: Int, + bpp :: Maybe Int, + refreshRate :: Maybe Int + } + +startOpt :: Options +startOpt = Options { + useFullscreen = False, + windowWidth = 800, + windowHeight = 600, + bpp = Nothing, + refreshRate = Nothing + } + +options :: [OptDescr (Options -> IO Options)] +options = [ + Option ['f'] ["fullscreen"] + (NoArg (\opt -> return opt { useFullscreen = True })) + "use fullscreen mode if possible", + Option ['w'] ["width"] + (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg + return opt { windowWidth = w }) + "WIDTH") + "use window width WIDTH", + Option ['h'] ["height"] + (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg + return opt { windowHeight = h }) + "HEIGHT") + "use window height HEIGHT", + Option ['b'] ["bpp"] + (ReqArg (\arg opt -> do b <- readInt "BPP" arg + return opt { bpp = Just b }) + "BPP") + "use BPP bits per plane (ignored in windowed mode)", + Option ['r'] ["refresh-rate"] + (ReqArg (\arg opt -> do r <- readInt "HZ" arg + return opt { refreshRate = Just r }) + "HZ") + "use refresh rate HZ (ignored in windowed mode)", + Option ['?'] ["help"] + (NoArg (\_ -> do usage >>= putStr + safeExitWith ExitSuccess)) + "show help" ] + +readInt :: String -> String -> IO Int +readInt name arg = + case reads arg of + ((x,[]) : _) -> return x + _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"] + +usage :: IO String +usage = do + progName <- getProgName + return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options + +parseOptions :: [String] -> IO Options +parseOptions args = do + let (optsActions, nonOptions, errs) = getOpt Permute options args + unless (null nonOptions && null errs) (dieWith errs) + foldl (>>=) (return startOpt) optsActions + +dieWith :: [String] -> IO a +dieWith errs = do + u <- usage + mapM_ (hPutStr stderr) (errs ++ [u]) + safeExitWith (ExitFailure 1) + +-------------------------------------------------------------------------------- +-- Handle mouse and keyboard events. For this simple demo, just exit when +-- ESCAPE is pressed. +-------------------------------------------------------------------------------- +keyboardMouseHandler :: KeyboardMouseCallback +keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess +keyboardMouseHandler _ _ _ _ = return () + +safeExitWith :: ExitCode -> IO a +safeExitWith code = do + gma <- get gameModeActive + when gma leaveGameMode + exitWith code + +-------------------------------------------------------------------------------- +-- Do one time setup, i.e. set the clear color. +-------------------------------------------------------------------------------- +initialize :: IO () +initialize = do + -- clear to black background + clearColor $= Color4 0 0 0 0 + +-------------------------------------------------------------------------------- +-- Reset the viewport for window changes. +-------------------------------------------------------------------------------- +setupProjection :: ReshapeCallback +setupProjection (Size width height) = do + -- don't want a divide by zero + let h = max 1 height + -- reset the viewport to new dimensions + viewport $= (Position 0 0, Size width h) + -- set projection matrix as the current matrix + matrixMode $= Projection + -- reset projection matrix + loadIdentity + + -- calculate aspect ratio of window + perspective 52 (fromIntegral width / fromIntegral h) 1 1000 + + -- set modelview matrix + matrixMode $= Modelview 0 + -- reset modelview matrix + loadIdentity + +-------------------------------------------------------------------------------- +-- Clear and redraw the scene. +-------------------------------------------------------------------------------- +render :: DisplayCallback +render = do + -- clear screen and depth buffer + clear [ ColorBuffer, DepthBuffer ] + loadIdentity + lookAt (Vertex3 0 10 0.1) (Vertex3 0 0 0) (Vector3 0 1 0) + + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + + color3f (Color3 1 1 1) + + drawCircleApproximation 2 10 False + +-- Hello, this is C... :-) +for :: [GLint] -> (GLint -> IO ()) -> IO () +for = flip mapM_ + +drawCircleApproximation :: GLfloat -> GLint -> Bool -> IO () +drawCircleApproximation radius numberOfSides edgeOnly = + -- if edge only, use line strips; otherwise, use polygons + renderPrimitive (if edgeOnly then LineStrip else Polygon) $ do + + -- calculate each vertex on the circle + for [ 0 .. numberOfSides - 1 ] $ \v -> do + + -- calculate the angle of the current vertex + let angle = fromIntegral v * 2 * pi / fromIntegral numberOfSides + + -- draw the current vertex at the correct radius + vertex (Vertex3 (cos angle * radius) 0 (sin angle * radius)) + + -- if drawing edge only, then need to complete the loop with first vertex + when edgeOnly $ + vertex (Vertex3 radius 0 0) diff --git a/examples/BOGLGP/Chapter03/Points.hs b/examples/BOGLGP/Chapter03/Points.hs --- a/examples/BOGLGP/Chapter03/Points.hs +++ b/examples/BOGLGP/Chapter03/Points.hs @@ -1,196 +1,196 @@ -{- - Points.hs (adapted from Points which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2004-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE --} - -import Control.Monad ( when, unless, zipWithM_ ) -import Data.Maybe ( isJust ) -import Graphics.UI.GLUT hiding ( initialize ) -import System.Console.GetOpt -import System.Environment ( getProgName ) -import System.Exit ( exitWith, ExitCode(..) ) -import System.IO ( hPutStr, stderr ) - --------------------------------------------------------------------------------- --- Setup GLUT and OpenGL, drop into the event loop. --------------------------------------------------------------------------------- -main :: IO () -main = do - -- Setup the basic GLUT stuff - (_, args) <- getArgsAndInitialize - opts <- parseOptions args - initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] - (if useFullscreen opts then fullscreenMode else windowedMode) opts - - initialize - - -- Register the event callback functions - displayCallback $= do render; swapBuffers - reshapeCallback $= Just setupProjection - keyboardMouseCallback $= Just keyboardMouseHandler - -- No need for an idle callback here, this would just hog the CPU - -- without any visible effect - - -- At this point, control is relinquished to the GLUT event handler. - -- Control is returned as events occur, via the callback functions. - mainLoop - -fullscreenMode :: Options -> IO () -fullscreenMode opts = do - let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :)) - gameModeCapabilities $= - (addCapability GameModeWidth (Just (windowWidth opts)) . - addCapability GameModeHeight (Just (windowHeight opts)) . - addCapability GameModeBitsPerPlane (bpp opts) . - addCapability GameModeRefreshRate (refreshRate opts)) [] - _ <- enterGameMode - maybeWin <- get currentWindow - if isJust maybeWin - then cursor $= None - else do - hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n" - windowedMode (opts { useFullscreen = False } ) - -windowedMode :: Options -> IO () -windowedMode opts = do - initialWindowSize $= - Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) - _ <- createWindow "BOGLGP - Chapter 3 - Points" - return () - --------------------------------------------------------------------------------- --- Option handling --------------------------------------------------------------------------------- -data Options = Options { - useFullscreen :: Bool, - windowWidth :: Int, - windowHeight :: Int, - bpp :: Maybe Int, - refreshRate :: Maybe Int - } - -startOpt :: Options -startOpt = Options { - useFullscreen = False, - windowWidth = 800, - windowHeight = 600, - bpp = Nothing, - refreshRate = Nothing - } - -options :: [OptDescr (Options -> IO Options)] -options = [ - Option ['f'] ["fullscreen"] - (NoArg (\opt -> return opt { useFullscreen = True })) - "use fullscreen mode if possible", - Option ['w'] ["width"] - (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg - return opt { windowWidth = w }) - "WIDTH") - "use window width WIDTH", - Option ['h'] ["height"] - (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg - return opt { windowHeight = h }) - "HEIGHT") - "use window height HEIGHT", - Option ['b'] ["bpp"] - (ReqArg (\arg opt -> do b <- readInt "BPP" arg - return opt { bpp = Just b }) - "BPP") - "use BPP bits per plane (ignored in windowed mode)", - Option ['r'] ["refresh-rate"] - (ReqArg (\arg opt -> do r <- readInt "HZ" arg - return opt { refreshRate = Just r }) - "HZ") - "use refresh rate HZ (ignored in windowed mode)", - Option ['?'] ["help"] - (NoArg (\_ -> do usage >>= putStr - safeExitWith ExitSuccess)) - "show help" ] - -readInt :: String -> String -> IO Int -readInt name arg = - case reads arg of - ((x,[]) : _) -> return x - _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"] - -usage :: IO String -usage = do - progName <- getProgName - return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options - -parseOptions :: [String] -> IO Options -parseOptions args = do - let (optsActions, nonOptions, errs) = getOpt Permute options args - unless (null nonOptions && null errs) (dieWith errs) - foldl (>>=) (return startOpt) optsActions - -dieWith :: [String] -> IO a -dieWith errs = do - u <- usage - mapM_ (hPutStr stderr) (errs ++ [u]) - safeExitWith (ExitFailure 1) - --------------------------------------------------------------------------------- --- Handle mouse and keyboard events. For this simple demo, just exit when --- ESCAPE is pressed. --------------------------------------------------------------------------------- -keyboardMouseHandler :: KeyboardMouseCallback -keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess -keyboardMouseHandler _ _ _ _ = return () - -safeExitWith :: ExitCode -> IO a -safeExitWith code = do - gma <- get gameModeActive - when gma leaveGameMode - exitWith code - --------------------------------------------------------------------------------- --- Do one time setup, i.e. set the clear color. --------------------------------------------------------------------------------- -initialize :: IO () -initialize = clearColor $= Color4 0 0 0 0 - --------------------------------------------------------------------------------- --- Reset the viewport for window changes. --------------------------------------------------------------------------------- -setupProjection :: ReshapeCallback -setupProjection (Size width height) = do - -- don't want a divide by zero - let h = max 1 height - -- reset the viewport to new dimensions - viewport $= (Position 0 0, Size width h) - -- set projection matrix as the current matrix - matrixMode $= Projection - -- reset projection matrix - loadIdentity - - -- calculate aspect ratio of window - perspective 52 (fromIntegral width / fromIntegral h) 1 1000 - - -- set modelview matrix - matrixMode $= Modelview 0 - -- reset modelview matrix - loadIdentity - --------------------------------------------------------------------------------- --- Clear and redraw the scene. --------------------------------------------------------------------------------- -render :: DisplayCallback -render = do - -- clear screen and depth buffer - clear [ ColorBuffer, DepthBuffer ] - loadIdentity - lookAt (Vertex3 0 6 0.1) (Vertex3 0 0 0) (Vector3 0 1 0) - - -- draw a line of points of increasing size - zipWithM_ (\ps point -> do - -- set the point size - pointSize $= ps - -- draw the point - renderPrimitive Points $ - vertex (Vertex3 point 0 0)) - [ 0.5 .. ] - [ -4, -3.5 .. 4.5 :: GLfloat ] +{- + Points.hs (adapted from Points which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2004-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( when, unless, zipWithM_ ) +import Data.Maybe ( isJust ) +import Graphics.UI.GLUT hiding ( initialize ) +import System.Console.GetOpt +import System.Environment ( getProgName ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.IO ( hPutStr, stderr ) + +-------------------------------------------------------------------------------- +-- Setup GLUT and OpenGL, drop into the event loop. +-------------------------------------------------------------------------------- +main :: IO () +main = do + -- Setup the basic GLUT stuff + (_, args) <- getArgsAndInitialize + opts <- parseOptions args + initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] + (if useFullscreen opts then fullscreenMode else windowedMode) opts + + initialize + + -- Register the event callback functions + displayCallback $= do render; swapBuffers + reshapeCallback $= Just setupProjection + keyboardMouseCallback $= Just keyboardMouseHandler + -- No need for an idle callback here, this would just hog the CPU + -- without any visible effect + + -- At this point, control is relinquished to the GLUT event handler. + -- Control is returned as events occur, via the callback functions. + mainLoop + +fullscreenMode :: Options -> IO () +fullscreenMode opts = do + let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :)) + gameModeCapabilities $= + (addCapability GameModeWidth (Just (windowWidth opts)) . + addCapability GameModeHeight (Just (windowHeight opts)) . + addCapability GameModeBitsPerPlane (bpp opts) . + addCapability GameModeRefreshRate (refreshRate opts)) [] + _ <- enterGameMode + maybeWin <- get currentWindow + if isJust maybeWin + then cursor $= None + else do + hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n" + windowedMode (opts { useFullscreen = False } ) + +windowedMode :: Options -> IO () +windowedMode opts = do + initialWindowSize $= + Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) + _ <- createWindow "BOGLGP - Chapter 3 - Points" + return () + +-------------------------------------------------------------------------------- +-- Option handling +-------------------------------------------------------------------------------- +data Options = Options { + useFullscreen :: Bool, + windowWidth :: Int, + windowHeight :: Int, + bpp :: Maybe Int, + refreshRate :: Maybe Int + } + +startOpt :: Options +startOpt = Options { + useFullscreen = False, + windowWidth = 800, + windowHeight = 600, + bpp = Nothing, + refreshRate = Nothing + } + +options :: [OptDescr (Options -> IO Options)] +options = [ + Option ['f'] ["fullscreen"] + (NoArg (\opt -> return opt { useFullscreen = True })) + "use fullscreen mode if possible", + Option ['w'] ["width"] + (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg + return opt { windowWidth = w }) + "WIDTH") + "use window width WIDTH", + Option ['h'] ["height"] + (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg + return opt { windowHeight = h }) + "HEIGHT") + "use window height HEIGHT", + Option ['b'] ["bpp"] + (ReqArg (\arg opt -> do b <- readInt "BPP" arg + return opt { bpp = Just b }) + "BPP") + "use BPP bits per plane (ignored in windowed mode)", + Option ['r'] ["refresh-rate"] + (ReqArg (\arg opt -> do r <- readInt "HZ" arg + return opt { refreshRate = Just r }) + "HZ") + "use refresh rate HZ (ignored in windowed mode)", + Option ['?'] ["help"] + (NoArg (\_ -> do usage >>= putStr + safeExitWith ExitSuccess)) + "show help" ] + +readInt :: String -> String -> IO Int +readInt name arg = + case reads arg of + ((x,[]) : _) -> return x + _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"] + +usage :: IO String +usage = do + progName <- getProgName + return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options + +parseOptions :: [String] -> IO Options +parseOptions args = do + let (optsActions, nonOptions, errs) = getOpt Permute options args + unless (null nonOptions && null errs) (dieWith errs) + foldl (>>=) (return startOpt) optsActions + +dieWith :: [String] -> IO a +dieWith errs = do + u <- usage + mapM_ (hPutStr stderr) (errs ++ [u]) + safeExitWith (ExitFailure 1) + +-------------------------------------------------------------------------------- +-- Handle mouse and keyboard events. For this simple demo, just exit when +-- ESCAPE is pressed. +-------------------------------------------------------------------------------- +keyboardMouseHandler :: KeyboardMouseCallback +keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess +keyboardMouseHandler _ _ _ _ = return () + +safeExitWith :: ExitCode -> IO a +safeExitWith code = do + gma <- get gameModeActive + when gma leaveGameMode + exitWith code + +-------------------------------------------------------------------------------- +-- Do one time setup, i.e. set the clear color. +-------------------------------------------------------------------------------- +initialize :: IO () +initialize = clearColor $= Color4 0 0 0 0 + +-------------------------------------------------------------------------------- +-- Reset the viewport for window changes. +-------------------------------------------------------------------------------- +setupProjection :: ReshapeCallback +setupProjection (Size width height) = do + -- don't want a divide by zero + let h = max 1 height + -- reset the viewport to new dimensions + viewport $= (Position 0 0, Size width h) + -- set projection matrix as the current matrix + matrixMode $= Projection + -- reset projection matrix + loadIdentity + + -- calculate aspect ratio of window + perspective 52 (fromIntegral width / fromIntegral h) 1 1000 + + -- set modelview matrix + matrixMode $= Modelview 0 + -- reset modelview matrix + loadIdentity + +-------------------------------------------------------------------------------- +-- Clear and redraw the scene. +-------------------------------------------------------------------------------- +render :: DisplayCallback +render = do + -- clear screen and depth buffer + clear [ ColorBuffer, DepthBuffer ] + loadIdentity + lookAt (Vertex3 0 6 0.1) (Vertex3 0 0 0) (Vector3 0 1 0) + + -- draw a line of points of increasing size + zipWithM_ (\ps point -> do + -- set the point size + pointSize $= ps + -- draw the point + renderPrimitive Points $ + vertex (Vertex3 point 0 0)) + [ 0.5 .. ] + [ -4, -3.5 .. 4.5 :: GLfloat ] diff --git a/examples/BOGLGP/Chapter03/Polygons.hs b/examples/BOGLGP/Chapter03/Polygons.hs --- a/examples/BOGLGP/Chapter03/Polygons.hs +++ b/examples/BOGLGP/Chapter03/Polygons.hs @@ -1,230 +1,230 @@ -{- - Polygons.hs (adapted from Polygons which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2004-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE --} - -import Control.Monad ( when, unless ) -import Data.IORef ( IORef, newIORef ) -import Data.Maybe ( isJust ) -import Graphics.UI.GLUT hiding ( initialize ) -import System.Console.GetOpt -import System.Environment ( getProgName ) -import System.Exit ( exitWith, ExitCode(..) ) -import System.IO ( hPutStr, stderr ) - --------------------------------------------------------------------------------- --- Setup GLUT and OpenGL, drop into the event loop. --------------------------------------------------------------------------------- -main :: IO () -main = do - -- Setup the basic GLUT stuff - (_, args) <- getArgsAndInitialize - opts <- parseOptions args - initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] - (if useFullscreen opts then fullscreenMode else windowedMode) opts - - state <- initialize - - -- Register the event callback functions - displayCallback $= do render state; swapBuffers - reshapeCallback $= Just setupProjection - keyboardMouseCallback $= Just keyboardMouseHandler - idleCallback $= Just (postRedisplay Nothing) - - -- At this point, control is relinquished to the GLUT event handler. - -- Control is returned as events occur, via the callback functions. - mainLoop - -fullscreenMode :: Options -> IO () -fullscreenMode opts = do - let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :)) - gameModeCapabilities $= - (addCapability GameModeWidth (Just (windowWidth opts)) . - addCapability GameModeHeight (Just (windowHeight opts)) . - addCapability GameModeBitsPerPlane (bpp opts) . - addCapability GameModeRefreshRate (refreshRate opts)) [] - _ <- enterGameMode - maybeWin <- get currentWindow - if isJust maybeWin - then cursor $= None - else do - hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n" - windowedMode (opts { useFullscreen = False } ) - -windowedMode :: Options -> IO () -windowedMode opts = do - initialWindowSize $= - Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) - _ <- createWindow "BOGLGP - Chapter 3 - Polygons" - return () - --------------------------------------------------------------------------------- --- Option handling --------------------------------------------------------------------------------- -data Options = Options { - useFullscreen :: Bool, - windowWidth :: Int, - windowHeight :: Int, - bpp :: Maybe Int, - refreshRate :: Maybe Int - } - -startOpt :: Options -startOpt = Options { - useFullscreen = False, - windowWidth = 800, - windowHeight = 600, - bpp = Nothing, - refreshRate = Nothing - } - -options :: [OptDescr (Options -> IO Options)] -options = [ - Option ['f'] ["fullscreen"] - (NoArg (\opt -> return opt { useFullscreen = True })) - "use fullscreen mode if possible", - Option ['w'] ["width"] - (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg - return opt { windowWidth = w }) - "WIDTH") - "use window width WIDTH", - Option ['h'] ["height"] - (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg - return opt { windowHeight = h }) - "HEIGHT") - "use window height HEIGHT", - Option ['b'] ["bpp"] - (ReqArg (\arg opt -> do b <- readInt "BPP" arg - return opt { bpp = Just b }) - "BPP") - "use BPP bits per plane (ignored in windowed mode)", - Option ['r'] ["refresh-rate"] - (ReqArg (\arg opt -> do r <- readInt "HZ" arg - return opt { refreshRate = Just r }) - "HZ") - "use refresh rate HZ (ignored in windowed mode)", - Option ['?'] ["help"] - (NoArg (\_ -> do usage >>= putStr - safeExitWith ExitSuccess)) - "show help" ] - -readInt :: String -> String -> IO Int -readInt name arg = - case reads arg of - ((x,[]) : _) -> return x - _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"] - -usage :: IO String -usage = do - progName <- getProgName - return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options - -parseOptions :: [String] -> IO Options -parseOptions args = do - let (optsActions, nonOptions, errs) = getOpt Permute options args - unless (null nonOptions && null errs) (dieWith errs) - foldl (>>=) (return startOpt) optsActions - -dieWith :: [String] -> IO a -dieWith errs = do - u <- usage - mapM_ (hPutStr stderr) (errs ++ [u]) - safeExitWith (ExitFailure 1) - --------------------------------------------------------------------------------- --- Handle mouse and keyboard events. For this simple demo, just exit when --- ESCAPE is pressed. --------------------------------------------------------------------------------- -keyboardMouseHandler :: KeyboardMouseCallback -keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess -keyboardMouseHandler _ _ _ _ = return () - -safeExitWith :: ExitCode -> IO a -safeExitWith code = do - gma <- get gameModeActive - when gma leaveGameMode - exitWith code - --------------------------------------------------------------------------------- --- The globale state, which is only the current angle in this simple demo. --- We don't need the window dimensions here, they are not used and would --- be easily available via GLUT anyway. --------------------------------------------------------------------------------- -data State = State { angle :: IORef GLfloat } - -makeState :: IO State -makeState = do - a <- newIORef 0 - return $ State { angle = a } - --------------------------------------------------------------------------------- --- Do one time setup, i.e. set the clear color and create the global state. --- Note that there is no need to set the polygon mode here, because we always --- set the front and back mode together. --------------------------------------------------------------------------------- -initialize :: IO State -initialize = do - -- clear to black background - clearColor $= Color4 0 0 0 0 - - makeState - --------------------------------------------------------------------------------- --- Reset the viewport for window changes. --------------------------------------------------------------------------------- -setupProjection :: ReshapeCallback -setupProjection (Size width height) = do - -- don't want a divide by zero - let h = max 1 height - -- reset the viewport to new dimensions - viewport $= (Position 0 0, Size width h) - -- set projection matrix as the current matrix - matrixMode $= Projection - -- reset projection matrix - loadIdentity - - -- calculate aspect ratio of window - perspective 52 (fromIntegral width / fromIntegral h) 1 1000 - - -- set modelview matrix - matrixMode $= Modelview 0 - -- reset modelview matrix - loadIdentity - --------------------------------------------------------------------------------- --- Clear and redraw the scene. --------------------------------------------------------------------------------- -render :: State -> DisplayCallback -render state = do - -- clear screen and depth buffer - clear [ ColorBuffer, DepthBuffer ] - loadIdentity - lookAt (Vertex3 0 10 0.1) (Vertex3 0 0 0) (Vector3 0 1 0) - - a <- get (angle state) - mapM_ (draw2DSquare a) [ - (Line, Fill, -4, Color3 1 0 0), - (Fill, Point, -2, Color3 0 1 0), - (Fill, Fill, 0, Color3 0 0 1), - (Fill, Line, 2, Color3 1 0 1), - (Line, Line, 4, Color3 1 1 0)] - - angle state $~ (+ 0.2) - -draw2DSquare :: - GLfloat -> (PolygonMode, PolygonMode, GLfloat, Color3 GLfloat) -> IO () -draw2DSquare a (polygonModeFront, polygonModeBack, deltaX, c) = do - polygonMode $= (polygonModeFront, polygonModeBack) - preservingMatrix $ do - translate (Vector3 deltaX 0 0) - rotate a (Vector3 0 0 1) - color c - renderPrimitive Polygon $ do - -- resolve overloading, not needed in "real" programs - let vertex3f = vertex :: Vertex3 GLfloat -> IO () - vertex3f (Vertex3 (-0.5) 0 0 ) - vertex3f (Vertex3 0.5 0 0 ) - vertex3f (Vertex3 0.5 0 (-1)) - vertex3f (Vertex3 (-0.5) 0 (-1)) +{- + Polygons.hs (adapted from Polygons which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2004-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( when, unless ) +import Data.IORef ( IORef, newIORef ) +import Data.Maybe ( isJust ) +import Graphics.UI.GLUT hiding ( initialize ) +import System.Console.GetOpt +import System.Environment ( getProgName ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.IO ( hPutStr, stderr ) + +-------------------------------------------------------------------------------- +-- Setup GLUT and OpenGL, drop into the event loop. +-------------------------------------------------------------------------------- +main :: IO () +main = do + -- Setup the basic GLUT stuff + (_, args) <- getArgsAndInitialize + opts <- parseOptions args + initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] + (if useFullscreen opts then fullscreenMode else windowedMode) opts + + state <- initialize + + -- Register the event callback functions + displayCallback $= do render state; swapBuffers + reshapeCallback $= Just setupProjection + keyboardMouseCallback $= Just keyboardMouseHandler + idleCallback $= Just (postRedisplay Nothing) + + -- At this point, control is relinquished to the GLUT event handler. + -- Control is returned as events occur, via the callback functions. + mainLoop + +fullscreenMode :: Options -> IO () +fullscreenMode opts = do + let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :)) + gameModeCapabilities $= + (addCapability GameModeWidth (Just (windowWidth opts)) . + addCapability GameModeHeight (Just (windowHeight opts)) . + addCapability GameModeBitsPerPlane (bpp opts) . + addCapability GameModeRefreshRate (refreshRate opts)) [] + _ <- enterGameMode + maybeWin <- get currentWindow + if isJust maybeWin + then cursor $= None + else do + hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n" + windowedMode (opts { useFullscreen = False } ) + +windowedMode :: Options -> IO () +windowedMode opts = do + initialWindowSize $= + Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) + _ <- createWindow "BOGLGP - Chapter 3 - Polygons" + return () + +-------------------------------------------------------------------------------- +-- Option handling +-------------------------------------------------------------------------------- +data Options = Options { + useFullscreen :: Bool, + windowWidth :: Int, + windowHeight :: Int, + bpp :: Maybe Int, + refreshRate :: Maybe Int + } + +startOpt :: Options +startOpt = Options { + useFullscreen = False, + windowWidth = 800, + windowHeight = 600, + bpp = Nothing, + refreshRate = Nothing + } + +options :: [OptDescr (Options -> IO Options)] +options = [ + Option ['f'] ["fullscreen"] + (NoArg (\opt -> return opt { useFullscreen = True })) + "use fullscreen mode if possible", + Option ['w'] ["width"] + (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg + return opt { windowWidth = w }) + "WIDTH") + "use window width WIDTH", + Option ['h'] ["height"] + (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg + return opt { windowHeight = h }) + "HEIGHT") + "use window height HEIGHT", + Option ['b'] ["bpp"] + (ReqArg (\arg opt -> do b <- readInt "BPP" arg + return opt { bpp = Just b }) + "BPP") + "use BPP bits per plane (ignored in windowed mode)", + Option ['r'] ["refresh-rate"] + (ReqArg (\arg opt -> do r <- readInt "HZ" arg + return opt { refreshRate = Just r }) + "HZ") + "use refresh rate HZ (ignored in windowed mode)", + Option ['?'] ["help"] + (NoArg (\_ -> do usage >>= putStr + safeExitWith ExitSuccess)) + "show help" ] + +readInt :: String -> String -> IO Int +readInt name arg = + case reads arg of + ((x,[]) : _) -> return x + _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"] + +usage :: IO String +usage = do + progName <- getProgName + return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options + +parseOptions :: [String] -> IO Options +parseOptions args = do + let (optsActions, nonOptions, errs) = getOpt Permute options args + unless (null nonOptions && null errs) (dieWith errs) + foldl (>>=) (return startOpt) optsActions + +dieWith :: [String] -> IO a +dieWith errs = do + u <- usage + mapM_ (hPutStr stderr) (errs ++ [u]) + safeExitWith (ExitFailure 1) + +-------------------------------------------------------------------------------- +-- Handle mouse and keyboard events. For this simple demo, just exit when +-- ESCAPE is pressed. +-------------------------------------------------------------------------------- +keyboardMouseHandler :: KeyboardMouseCallback +keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess +keyboardMouseHandler _ _ _ _ = return () + +safeExitWith :: ExitCode -> IO a +safeExitWith code = do + gma <- get gameModeActive + when gma leaveGameMode + exitWith code + +-------------------------------------------------------------------------------- +-- The globale state, which is only the current angle in this simple demo. +-- We don't need the window dimensions here, they are not used and would +-- be easily available via GLUT anyway. +-------------------------------------------------------------------------------- +data State = State { angle :: IORef GLfloat } + +makeState :: IO State +makeState = do + a <- newIORef 0 + return $ State { angle = a } + +-------------------------------------------------------------------------------- +-- Do one time setup, i.e. set the clear color and create the global state. +-- Note that there is no need to set the polygon mode here, because we always +-- set the front and back mode together. +-------------------------------------------------------------------------------- +initialize :: IO State +initialize = do + -- clear to black background + clearColor $= Color4 0 0 0 0 + + makeState + +-------------------------------------------------------------------------------- +-- Reset the viewport for window changes. +-------------------------------------------------------------------------------- +setupProjection :: ReshapeCallback +setupProjection (Size width height) = do + -- don't want a divide by zero + let h = max 1 height + -- reset the viewport to new dimensions + viewport $= (Position 0 0, Size width h) + -- set projection matrix as the current matrix + matrixMode $= Projection + -- reset projection matrix + loadIdentity + + -- calculate aspect ratio of window + perspective 52 (fromIntegral width / fromIntegral h) 1 1000 + + -- set modelview matrix + matrixMode $= Modelview 0 + -- reset modelview matrix + loadIdentity + +-------------------------------------------------------------------------------- +-- Clear and redraw the scene. +-------------------------------------------------------------------------------- +render :: State -> DisplayCallback +render state = do + -- clear screen and depth buffer + clear [ ColorBuffer, DepthBuffer ] + loadIdentity + lookAt (Vertex3 0 10 0.1) (Vertex3 0 0 0) (Vector3 0 1 0) + + a <- get (angle state) + mapM_ (draw2DSquare a) [ + (Line, Fill, -4, Color3 1 0 0), + (Fill, Point, -2, Color3 0 1 0), + (Fill, Fill, 0, Color3 0 0 1), + (Fill, Line, 2, Color3 1 0 1), + (Line, Line, 4, Color3 1 1 0)] + + angle state $~ (+ 0.2) + +draw2DSquare :: + GLfloat -> (PolygonMode, PolygonMode, GLfloat, Color3 GLfloat) -> IO () +draw2DSquare a (polygonModeFront, polygonModeBack, deltaX, c) = do + polygonMode $= (polygonModeFront, polygonModeBack) + preservingMatrix $ do + translate (Vector3 deltaX 0 0) + rotate a (Vector3 0 0 1) + color c + renderPrimitive Polygon $ do + -- resolve overloading, not needed in "real" programs + let vertex3f = vertex :: Vertex3 GLfloat -> IO () + vertex3f (Vertex3 (-0.5) 0 0 ) + vertex3f (Vertex3 0.5 0 0 ) + vertex3f (Vertex3 0.5 0 (-1)) + vertex3f (Vertex3 (-0.5) 0 (-1)) diff --git a/examples/BOGLGP/Chapter03/TrianglesQuads.hs b/examples/BOGLGP/Chapter03/TrianglesQuads.hs --- a/examples/BOGLGP/Chapter03/TrianglesQuads.hs +++ b/examples/BOGLGP/Chapter03/TrianglesQuads.hs @@ -1,294 +1,294 @@ -{- - TrianglesQuads.hs (adapted from TrianglesQuads which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2004-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE --} - -import Control.Monad ( when, unless ) -import Data.Maybe ( isJust ) -import Graphics.UI.GLUT hiding ( initialize ) -import System.Console.GetOpt -import System.Environment ( getProgName ) -import System.Exit ( exitWith, ExitCode(..) ) -import System.IO ( hPutStr, stderr ) - --------------------------------------------------------------------------------- --- Setup GLUT and OpenGL, drop into the event loop. --------------------------------------------------------------------------------- -main :: IO () -main = do - -- Setup the basic GLUT stuff - (_, args) <- getArgsAndInitialize - opts <- parseOptions args - initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] - (if useFullscreen opts then fullscreenMode else windowedMode) opts - - initialize - - -- Register the event callback functions - displayCallback $= do render; swapBuffers - reshapeCallback $= Just setupProjection - keyboardMouseCallback $= Just keyboardMouseHandler - -- No need for an idle callback here, this would just hog the CPU - -- without any visible effect - - -- At this point, control is relinquished to the GLUT event handler. - -- Control is returned as events occur, via the callback functions. - mainLoop - -fullscreenMode :: Options -> IO () -fullscreenMode opts = do - let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :)) - gameModeCapabilities $= - (addCapability GameModeWidth (Just (windowWidth opts)) . - addCapability GameModeHeight (Just (windowHeight opts)) . - addCapability GameModeBitsPerPlane (bpp opts) . - addCapability GameModeRefreshRate (refreshRate opts)) [] - _ <- enterGameMode - maybeWin <- get currentWindow - if isJust maybeWin - then cursor $= None - else do - hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n" - windowedMode (opts { useFullscreen = False } ) - -windowedMode :: Options -> IO () -windowedMode opts = do - initialWindowSize $= - Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) - _ <- createWindow "BOGLGP - Chapter 3 - TrianglesQuads" - return () - --------------------------------------------------------------------------------- --- Option handling --------------------------------------------------------------------------------- -data Options = Options { - useFullscreen :: Bool, - windowWidth :: Int, - windowHeight :: Int, - bpp :: Maybe Int, - refreshRate :: Maybe Int - } - -startOpt :: Options -startOpt = Options { - useFullscreen = False, - windowWidth = 800, - windowHeight = 600, - bpp = Nothing, - refreshRate = Nothing - } - -options :: [OptDescr (Options -> IO Options)] -options = [ - Option ['f'] ["fullscreen"] - (NoArg (\opt -> return opt { useFullscreen = True })) - "use fullscreen mode if possible", - Option ['w'] ["width"] - (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg - return opt { windowWidth = w }) - "WIDTH") - "use window width WIDTH", - Option ['h'] ["height"] - (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg - return opt { windowHeight = h }) - "HEIGHT") - "use window height HEIGHT", - Option ['b'] ["bpp"] - (ReqArg (\arg opt -> do b <- readInt "BPP" arg - return opt { bpp = Just b }) - "BPP") - "use BPP bits per plane (ignored in windowed mode)", - Option ['r'] ["refresh-rate"] - (ReqArg (\arg opt -> do r <- readInt "HZ" arg - return opt { refreshRate = Just r }) - "HZ") - "use refresh rate HZ (ignored in windowed mode)", - Option ['?'] ["help"] - (NoArg (\_ -> do usage >>= putStr - safeExitWith ExitSuccess)) - "show help" ] - -readInt :: String -> String -> IO Int -readInt name arg = - case reads arg of - ((x,[]) : _) -> return x - _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"] - -usage :: IO String -usage = do - progName <- getProgName - return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options - -parseOptions :: [String] -> IO Options -parseOptions args = do - let (optsActions, nonOptions, errs) = getOpt Permute options args - unless (null nonOptions && null errs) (dieWith errs) - foldl (>>=) (return startOpt) optsActions - -dieWith :: [String] -> IO a -dieWith errs = do - u <- usage - mapM_ (hPutStr stderr) (errs ++ [u]) - safeExitWith (ExitFailure 1) - --------------------------------------------------------------------------------- --- Handle mouse and keyboard events. For this simple demo, just exit when --- ESCAPE is pressed. --------------------------------------------------------------------------------- -keyboardMouseHandler :: KeyboardMouseCallback -keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess -keyboardMouseHandler _ _ _ _ = return () - -safeExitWith :: ExitCode -> IO a -safeExitWith code = do - gma <- get gameModeActive - when gma leaveGameMode - exitWith code - --------------------------------------------------------------------------------- --- Do one time setup, i.e. set the clear color. --------------------------------------------------------------------------------- -initialize :: IO () -initialize = clearColor $= Color4 0 0 0 0 - --------------------------------------------------------------------------------- --- Reset the viewport for window changes. --------------------------------------------------------------------------------- -setupProjection :: ReshapeCallback -setupProjection (Size width height) = do - -- don't want a divide by zero - let h = max 1 height - -- reset the viewport to new dimensions - viewport $= (Position 0 0, Size width h) - -- set projection matrix as the current matrix - matrixMode $= Projection - -- reset projection matrix - loadIdentity - - -- calculate aspect ratio of window - perspective 52 (fromIntegral width / fromIntegral h) 1 1000 - - -- set modelview matrix - matrixMode $= Modelview 0 - -- reset modelview matrix - loadIdentity - --------------------------------------------------------------------------------- --- Clear and redraw the scene. --------------------------------------------------------------------------------- -render :: DisplayCallback -render = do - -- clear screen and depth buffer - clear [ ColorBuffer, DepthBuffer ] - loadIdentity - lookAt (Vertex3 0 10 0.1) (Vertex3 0 0 0) (Vector3 0 1 0) - - -- resolve overloading, not needed in "real" programs - let translate3f = translate :: Vector3 GLfloat -> IO () - - -- top left - preservingMatrix $ do - translate3f (Vector3 (-6) 0 (-4)) - drawPoints - - -- top middle - preservingMatrix $ do - polygonMode $= (Fill, Fill) - translate3f (Vector3 (-2) 0 (-4)) - drawTriangles - - -- top right - preservingMatrix $ do - polygonMode $= (Line, Line) - translate3f (Vector3 2 0 (-4)) - drawQuads - - -- bottom left - preservingMatrix $ do - polygonMode $= (Line, Line) - translate3f (Vector3 (-6) 0 0.5) - drawTriangleStrip - - -- bottom middle - preservingMatrix $ do - polygonMode $= (Line, Line) - translate3f (Vector3 (-2) 0 0.5) - drawTriangleFan - - -- bottom right - preservingMatrix $ do - polygonMode $= (Line, Line) - translate3f (Vector3 2 0 0.5) - drawQuadStrip - --- Hello, this is C... :-) -for :: [GLfloat] -> (GLfloat -> IO ()) -> IO () -for = flip mapM_ - --- draw grid of points showing dataset we are working with -drawPoints :: IO () -drawPoints = do - pointSize $= 4 - renderPrimitive Points $ - for [ 0 .. 3 ] $ \x -> - for [ 0 .. 3 ] $ \z -> - vertex (Vertex3 x 0 z) - --- draw grid as individual triangles -drawTriangles :: IO () -drawTriangles = - renderPrimitive Triangles $ - for [ 0 .. 2 ] $ \x -> - for [ 0 .. 2 ] $ \z -> do - vertex (Vertex3 x 0 z ) - vertex (Vertex3 (x + 1) 0 z ) - vertex (Vertex3 x 0 (z + 1)) - --- draw grid as triangle fan -drawTriangleFan :: IO () -drawTriangleFan = - renderPrimitive TriangleFan $ do - -- center vertex of fan - vertex (Vertex3 0 0 (0 :: GLfloat)) - - -- bottom side - for [ 3, 2 .. 0 ] $ \x -> - vertex (Vertex3 x 0 3) - - -- right side - for [ 3, 2 .. 0 ] $ \z -> - vertex (Vertex3 3 0 z) - --- draw grid as triangle strips -drawTriangleStrip :: IO () -drawTriangleStrip = - -- 3 rows of triangle strips - for [ 0 .. 2 ] $ \x -> - renderPrimitive TriangleStrip $ - for [ 0 .. 2 ] $ \z -> do - vertex (Vertex3 x 0 z ) - vertex (Vertex3 (x + 1) 0 z ) - vertex (Vertex3 x 0 (z + 1)) - vertex (Vertex3 (x + 1) 0 (z + 1)) - --- draw grid as individual quads -drawQuads :: IO () -drawQuads = - renderPrimitive Quads $ - for [ 0 .. 2 ] $ \x -> - for [ 0 .. 2 ] $ \z -> do - vertex (Vertex3 x 0 z ) - vertex (Vertex3 (x + 1) 0 z ) - vertex (Vertex3 (x + 1) 0 (z + 1)) - vertex (Vertex3 x 0 (z + 1)) - --- draw grid as quad strips -drawQuadStrip :: IO () -drawQuadStrip = - for [ 0 .. 2 ] $ \x -> - renderPrimitive QuadStrip $ - for [ 0 .. 3 ] $ \z -> do - vertex (Vertex3 x 0 z) - vertex (Vertex3 (x + 1) 0 z) +{- + TrianglesQuads.hs (adapted from TrianglesQuads which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2004-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( when, unless ) +import Data.Maybe ( isJust ) +import Graphics.UI.GLUT hiding ( initialize ) +import System.Console.GetOpt +import System.Environment ( getProgName ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.IO ( hPutStr, stderr ) + +-------------------------------------------------------------------------------- +-- Setup GLUT and OpenGL, drop into the event loop. +-------------------------------------------------------------------------------- +main :: IO () +main = do + -- Setup the basic GLUT stuff + (_, args) <- getArgsAndInitialize + opts <- parseOptions args + initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] + (if useFullscreen opts then fullscreenMode else windowedMode) opts + + initialize + + -- Register the event callback functions + displayCallback $= do render; swapBuffers + reshapeCallback $= Just setupProjection + keyboardMouseCallback $= Just keyboardMouseHandler + -- No need for an idle callback here, this would just hog the CPU + -- without any visible effect + + -- At this point, control is relinquished to the GLUT event handler. + -- Control is returned as events occur, via the callback functions. + mainLoop + +fullscreenMode :: Options -> IO () +fullscreenMode opts = do + let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :)) + gameModeCapabilities $= + (addCapability GameModeWidth (Just (windowWidth opts)) . + addCapability GameModeHeight (Just (windowHeight opts)) . + addCapability GameModeBitsPerPlane (bpp opts) . + addCapability GameModeRefreshRate (refreshRate opts)) [] + _ <- enterGameMode + maybeWin <- get currentWindow + if isJust maybeWin + then cursor $= None + else do + hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n" + windowedMode (opts { useFullscreen = False } ) + +windowedMode :: Options -> IO () +windowedMode opts = do + initialWindowSize $= + Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) + _ <- createWindow "BOGLGP - Chapter 3 - TrianglesQuads" + return () + +-------------------------------------------------------------------------------- +-- Option handling +-------------------------------------------------------------------------------- +data Options = Options { + useFullscreen :: Bool, + windowWidth :: Int, + windowHeight :: Int, + bpp :: Maybe Int, + refreshRate :: Maybe Int + } + +startOpt :: Options +startOpt = Options { + useFullscreen = False, + windowWidth = 800, + windowHeight = 600, + bpp = Nothing, + refreshRate = Nothing + } + +options :: [OptDescr (Options -> IO Options)] +options = [ + Option ['f'] ["fullscreen"] + (NoArg (\opt -> return opt { useFullscreen = True })) + "use fullscreen mode if possible", + Option ['w'] ["width"] + (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg + return opt { windowWidth = w }) + "WIDTH") + "use window width WIDTH", + Option ['h'] ["height"] + (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg + return opt { windowHeight = h }) + "HEIGHT") + "use window height HEIGHT", + Option ['b'] ["bpp"] + (ReqArg (\arg opt -> do b <- readInt "BPP" arg + return opt { bpp = Just b }) + "BPP") + "use BPP bits per plane (ignored in windowed mode)", + Option ['r'] ["refresh-rate"] + (ReqArg (\arg opt -> do r <- readInt "HZ" arg + return opt { refreshRate = Just r }) + "HZ") + "use refresh rate HZ (ignored in windowed mode)", + Option ['?'] ["help"] + (NoArg (\_ -> do usage >>= putStr + safeExitWith ExitSuccess)) + "show help" ] + +readInt :: String -> String -> IO Int +readInt name arg = + case reads arg of + ((x,[]) : _) -> return x + _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"] + +usage :: IO String +usage = do + progName <- getProgName + return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options + +parseOptions :: [String] -> IO Options +parseOptions args = do + let (optsActions, nonOptions, errs) = getOpt Permute options args + unless (null nonOptions && null errs) (dieWith errs) + foldl (>>=) (return startOpt) optsActions + +dieWith :: [String] -> IO a +dieWith errs = do + u <- usage + mapM_ (hPutStr stderr) (errs ++ [u]) + safeExitWith (ExitFailure 1) + +-------------------------------------------------------------------------------- +-- Handle mouse and keyboard events. For this simple demo, just exit when +-- ESCAPE is pressed. +-------------------------------------------------------------------------------- +keyboardMouseHandler :: KeyboardMouseCallback +keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess +keyboardMouseHandler _ _ _ _ = return () + +safeExitWith :: ExitCode -> IO a +safeExitWith code = do + gma <- get gameModeActive + when gma leaveGameMode + exitWith code + +-------------------------------------------------------------------------------- +-- Do one time setup, i.e. set the clear color. +-------------------------------------------------------------------------------- +initialize :: IO () +initialize = clearColor $= Color4 0 0 0 0 + +-------------------------------------------------------------------------------- +-- Reset the viewport for window changes. +-------------------------------------------------------------------------------- +setupProjection :: ReshapeCallback +setupProjection (Size width height) = do + -- don't want a divide by zero + let h = max 1 height + -- reset the viewport to new dimensions + viewport $= (Position 0 0, Size width h) + -- set projection matrix as the current matrix + matrixMode $= Projection + -- reset projection matrix + loadIdentity + + -- calculate aspect ratio of window + perspective 52 (fromIntegral width / fromIntegral h) 1 1000 + + -- set modelview matrix + matrixMode $= Modelview 0 + -- reset modelview matrix + loadIdentity + +-------------------------------------------------------------------------------- +-- Clear and redraw the scene. +-------------------------------------------------------------------------------- +render :: DisplayCallback +render = do + -- clear screen and depth buffer + clear [ ColorBuffer, DepthBuffer ] + loadIdentity + lookAt (Vertex3 0 10 0.1) (Vertex3 0 0 0) (Vector3 0 1 0) + + -- resolve overloading, not needed in "real" programs + let translate3f = translate :: Vector3 GLfloat -> IO () + + -- top left + preservingMatrix $ do + translate3f (Vector3 (-6) 0 (-4)) + drawPoints + + -- top middle + preservingMatrix $ do + polygonMode $= (Fill, Fill) + translate3f (Vector3 (-2) 0 (-4)) + drawTriangles + + -- top right + preservingMatrix $ do + polygonMode $= (Line, Line) + translate3f (Vector3 2 0 (-4)) + drawQuads + + -- bottom left + preservingMatrix $ do + polygonMode $= (Line, Line) + translate3f (Vector3 (-6) 0 0.5) + drawTriangleStrip + + -- bottom middle + preservingMatrix $ do + polygonMode $= (Line, Line) + translate3f (Vector3 (-2) 0 0.5) + drawTriangleFan + + -- bottom right + preservingMatrix $ do + polygonMode $= (Line, Line) + translate3f (Vector3 2 0 0.5) + drawQuadStrip + +-- Hello, this is C... :-) +for :: [GLfloat] -> (GLfloat -> IO ()) -> IO () +for = flip mapM_ + +-- draw grid of points showing dataset we are working with +drawPoints :: IO () +drawPoints = do + pointSize $= 4 + renderPrimitive Points $ + for [ 0 .. 3 ] $ \x -> + for [ 0 .. 3 ] $ \z -> + vertex (Vertex3 x 0 z) + +-- draw grid as individual triangles +drawTriangles :: IO () +drawTriangles = + renderPrimitive Triangles $ + for [ 0 .. 2 ] $ \x -> + for [ 0 .. 2 ] $ \z -> do + vertex (Vertex3 x 0 z ) + vertex (Vertex3 (x + 1) 0 z ) + vertex (Vertex3 x 0 (z + 1)) + +-- draw grid as triangle fan +drawTriangleFan :: IO () +drawTriangleFan = + renderPrimitive TriangleFan $ do + -- center vertex of fan + vertex (Vertex3 0 0 (0 :: GLfloat)) + + -- bottom side + for [ 3, 2 .. 0 ] $ \x -> + vertex (Vertex3 x 0 3) + + -- right side + for [ 3, 2 .. 0 ] $ \z -> + vertex (Vertex3 3 0 z) + +-- draw grid as triangle strips +drawTriangleStrip :: IO () +drawTriangleStrip = + -- 3 rows of triangle strips + for [ 0 .. 2 ] $ \x -> + renderPrimitive TriangleStrip $ + for [ 0 .. 2 ] $ \z -> do + vertex (Vertex3 x 0 z ) + vertex (Vertex3 (x + 1) 0 z ) + vertex (Vertex3 x 0 (z + 1)) + vertex (Vertex3 (x + 1) 0 (z + 1)) + +-- draw grid as individual quads +drawQuads :: IO () +drawQuads = + renderPrimitive Quads $ + for [ 0 .. 2 ] $ \x -> + for [ 0 .. 2 ] $ \z -> do + vertex (Vertex3 x 0 z ) + vertex (Vertex3 (x + 1) 0 z ) + vertex (Vertex3 (x + 1) 0 (z + 1)) + vertex (Vertex3 x 0 (z + 1)) + +-- draw grid as quad strips +drawQuadStrip :: IO () +drawQuadStrip = + for [ 0 .. 2 ] $ \x -> + renderPrimitive QuadStrip $ + for [ 0 .. 3 ] $ \z -> do + vertex (Vertex3 x 0 z) + vertex (Vertex3 (x + 1) 0 z) diff --git a/examples/BOGLGP/Makefile b/examples/BOGLGP/Makefile --- a/examples/BOGLGP/Makefile +++ b/examples/BOGLGP/Makefile @@ -1,2 +1,2 @@ -SUBDIRS := $(wildcard Chapter*) -include ../examples.mk +SUBDIRS := $(wildcard Chapter*) +include ../examples.mk diff --git a/examples/Makefile b/examples/Makefile --- a/examples/Makefile +++ b/examples/Makefile @@ -1,2 +1,2 @@ -SUBDIRS := BOGLGP Misc OrangeBook RedBook4 RedBook8 -include examples.mk +SUBDIRS := BOGLGP Misc OrangeBook RedBook4 RedBook8 +include examples.mk diff --git a/examples/Misc/00-README b/examples/Misc/00-README new file mode 100644 --- /dev/null +++ b/examples/Misc/00-README @@ -0,0 +1,1 @@ +This directory contains a few random examples from e.g. the Mesa sources. diff --git a/examples/Misc/ARBOcclude.hs b/examples/Misc/ARBOcclude.hs --- a/examples/Misc/ARBOcclude.hs +++ b/examples/Misc/ARBOcclude.hs @@ -1,193 +1,193 @@ -{- - ARBOcclude.hs (adapted from arbocclude.c which is (c) Brian Paul) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE --} - -import Control.Monad ( unless, when ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure ) -import Graphics.UI.GLUT - -data State = State { - anim :: IORef Bool, - xPos :: IORef GLfloat, - sign :: IORef GLfloat, - lastTime :: IORef Int } - -makeState :: IO State -makeState = do - a <- newIORef True - x <- newIORef 0 - s <- newIORef 1 - l <- newIORef =<< get elapsedTime - return $ State { anim = a, xPos = x, sign = s, lastTime = l } - -petrol, orange, white :: Color3 GLfloat -petrol = Color3 0.0 0.6 0.8 -orange = Color3 0.8 0.5 0.0 -white = Color3 1.0 1.0 1.0 - -printString :: Vertex2 GLfloat -> String -> IO () -printString pos s = do - color white - rasterPos pos - renderString Fixed8By13 s - -idle :: State -> IdleCallback -idle state = do - time <- get elapsedTime - l <- get (lastTime state) - let timeDiff = fromIntegral (time - l) - - when (timeDiff >= 20) $ do -- 50Hz update - lastTime state $= time - - s <- get (sign state) - step state (timeDiff / 1000 * s) - x <- get (xPos state) - - when (x > 2.5) $ do - xPos state $= 2.5 - sign state $= (-1) - - when (x < -2.5) $ do - xPos state $= (-2.5) - sign state $= 1 - -display :: QueryObject -> State -> DisplayCallback -display occQuery state = do - clear [ ColorBuffer, DepthBuffer ] - - matrixMode $= Projection - loadIdentity - frustum (-1) 1 (-1) 1 5 25 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-15 :: GLfloat)) - - drawOccludingPolygons - - -- draw the test polygon with occlusion testing - passed <- preservingMatrix $ do - x <- get (xPos state) - translate (Vector3 x 0 (-0.5)) - scale 0.3 0.3 (1.0 :: GLfloat) - rotate (-90 * x) (Vector3 0 0 1) - - withQuery SamplesPassed occQuery $ do - colorMask $= Color4 Disabled Disabled Disabled Disabled - depthMask $= Disabled - drawRect - - p <- waitForResult occQuery - - -- turn off occlusion testing - colorMask $= Color4 Enabled Enabled Enabled Enabled - depthMask $= Enabled - - -- draw the orange rect, so we can see what's going on - color orange - drawRect - - return p - - -- Print result message - matrixMode $= Projection - loadIdentity - ortho (-1) 1 (-1) 1 (-1) 1 - matrixMode $= Modelview 0 - loadIdentity - - printString (Vertex2 (-0.50) (-0.7)) - (" " ++ flushRight 4 passed ++ " Fragments Visible") - when (passed == 0) $ - printString (Vertex2 (-0.25) (-0.8)) "Fully Occluded" - - swapBuffers - -drawOccludingPolygons :: IO () -drawOccludingPolygons = do - color petrol - drawQuads [ - Vertex2 (-1.6) (-1.5), - Vertex2 (-0.4) (-1.5), - Vertex2 (-0.4) 1.5 , - Vertex2 (-1.6) 1.5 , - - Vertex2 0.4 (-1.5), - Vertex2 1.6 (-1.5), - Vertex2 1.6 1.5 , - Vertex2 0.4 1.5 ] - -drawRect :: IO () -drawRect = do - drawQuads [ - Vertex2 (-1) (-1), - Vertex2 1 (-1), - Vertex2 1 1 , - Vertex2 (-1) 1 ] - -drawQuads :: [Vertex2 GLfloat] -> IO () -drawQuads = renderPrimitive Quads . mapM_ vertex - -waitForResult :: QueryObject -> IO GLuint -waitForResult occQuery = do - let loop = do -- do useful work here, if any - ready <- get (queryResultAvailable occQuery) - unless ready loop - loop - get (queryResult occQuery) - -flushRight :: Show a => Int -> a -> String -flushRight width x = replicate (width - length s) ' ' ++ s - where s = show x - -keyboard :: State -> KeyboardMouseCallback -keyboard _ (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard state (Char ' ') Down _ _ = do anim state $~ not - setIdleCallback state -keyboard state (SpecialKey KeyLeft) Down _ _ = step state (-0.1) -keyboard state (SpecialKey KeyRight) Down _ _ = step state 0.1 -keyboard _ _ _ _ _ = return () - -setIdleCallback :: State -> IO () -setIdleCallback state = do - a <- get (anim state) - idleCallback $= if a then Just (idle state) else Nothing - -step :: State -> GLfloat -> IO () -step state s = do - xPos state $~ (+ s) - postRedisplay Nothing - -myInit :: IO () -myInit = do - exts <- get glExtensions - unless ("GL_ARB_occlusion_query" `elem` exts) $ do - putStrLn "Sorry, this demo requires the GL_ARB_occlusion_query extension." - exitFailure - - bits <- get (queryCounterBits SamplesPassed) - unless (bits > 0) $ do - putStrLn "Hmmm, GL_QUERY_COUNTER_BITS_ARB is zero!" - exitFailure - - depthFunc $= Just Less - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialWindowPosition $= Position 0 0 - initialWindowSize $= Size 400 400 - initialDisplayMode $= [ RGBMode, DoubleBuffered, WithDepthBuffer ] - _ <- createWindow progName - state <- makeState - reshapeCallback $= Just (\size -> viewport $= (Position 0 0, size)) - keyboardMouseCallback $= Just (keyboard state) - setIdleCallback state - occQuery <- genObjectName - displayCallback $= display occQuery state - myInit - mainLoop +{- + ARBOcclude.hs (adapted from arbocclude.c which is (c) Brian Paul) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( unless, when ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure ) +import Graphics.UI.GLUT + +data State = State { + anim :: IORef Bool, + xPos :: IORef GLfloat, + sign :: IORef GLfloat, + lastTime :: IORef Int } + +makeState :: IO State +makeState = do + a <- newIORef True + x <- newIORef 0 + s <- newIORef 1 + l <- newIORef =<< get elapsedTime + return $ State { anim = a, xPos = x, sign = s, lastTime = l } + +petrol, orange, white :: Color3 GLfloat +petrol = Color3 0.0 0.6 0.8 +orange = Color3 0.8 0.5 0.0 +white = Color3 1.0 1.0 1.0 + +printString :: Vertex2 GLfloat -> String -> IO () +printString pos s = do + color white + rasterPos pos + renderString Fixed8By13 s + +idle :: State -> IdleCallback +idle state = do + time <- get elapsedTime + l <- get (lastTime state) + let timeDiff = fromIntegral (time - l) + + when (timeDiff >= 20) $ do -- 50Hz update + lastTime state $= time + + s <- get (sign state) + step state (timeDiff / 1000 * s) + x <- get (xPos state) + + when (x > 2.5) $ do + xPos state $= 2.5 + sign state $= (-1) + + when (x < -2.5) $ do + xPos state $= (-2.5) + sign state $= 1 + +display :: QueryObject -> State -> DisplayCallback +display occQuery state = do + clear [ ColorBuffer, DepthBuffer ] + + matrixMode $= Projection + loadIdentity + frustum (-1) 1 (-1) 1 5 25 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-15 :: GLfloat)) + + drawOccludingPolygons + + -- draw the test polygon with occlusion testing + passed <- preservingMatrix $ do + x <- get (xPos state) + translate (Vector3 x 0 (-0.5)) + scale 0.3 0.3 (1.0 :: GLfloat) + rotate (-90 * x) (Vector3 0 0 1) + + withQuery SamplesPassed occQuery $ do + colorMask $= Color4 Disabled Disabled Disabled Disabled + depthMask $= Disabled + drawRect + + p <- waitForResult occQuery + + -- turn off occlusion testing + colorMask $= Color4 Enabled Enabled Enabled Enabled + depthMask $= Enabled + + -- draw the orange rect, so we can see what's going on + color orange + drawRect + + return p + + -- Print result message + matrixMode $= Projection + loadIdentity + ortho (-1) 1 (-1) 1 (-1) 1 + matrixMode $= Modelview 0 + loadIdentity + + printString (Vertex2 (-0.50) (-0.7)) + (" " ++ flushRight 4 passed ++ " Fragments Visible") + when (passed == 0) $ + printString (Vertex2 (-0.25) (-0.8)) "Fully Occluded" + + swapBuffers + +drawOccludingPolygons :: IO () +drawOccludingPolygons = do + color petrol + drawQuads [ + Vertex2 (-1.6) (-1.5), + Vertex2 (-0.4) (-1.5), + Vertex2 (-0.4) 1.5 , + Vertex2 (-1.6) 1.5 , + + Vertex2 0.4 (-1.5), + Vertex2 1.6 (-1.5), + Vertex2 1.6 1.5 , + Vertex2 0.4 1.5 ] + +drawRect :: IO () +drawRect = do + drawQuads [ + Vertex2 (-1) (-1), + Vertex2 1 (-1), + Vertex2 1 1 , + Vertex2 (-1) 1 ] + +drawQuads :: [Vertex2 GLfloat] -> IO () +drawQuads = renderPrimitive Quads . mapM_ vertex + +waitForResult :: QueryObject -> IO GLuint +waitForResult occQuery = do + let loop = do -- do useful work here, if any + ready <- get (queryResultAvailable occQuery) + unless ready loop + loop + get (queryResult occQuery) + +flushRight :: Show a => Int -> a -> String +flushRight width x = replicate (width - length s) ' ' ++ s + where s = show x + +keyboard :: State -> KeyboardMouseCallback +keyboard _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard state (Char ' ') Down _ _ = do anim state $~ not + setIdleCallback state +keyboard state (SpecialKey KeyLeft) Down _ _ = step state (-0.1) +keyboard state (SpecialKey KeyRight) Down _ _ = step state 0.1 +keyboard _ _ _ _ _ = return () + +setIdleCallback :: State -> IO () +setIdleCallback state = do + a <- get (anim state) + idleCallback $= if a then Just (idle state) else Nothing + +step :: State -> GLfloat -> IO () +step state s = do + xPos state $~ (+ s) + postRedisplay Nothing + +myInit :: IO () +myInit = do + exts <- get glExtensions + unless ("GL_ARB_occlusion_query" `elem` exts) $ do + putStrLn "Sorry, this demo requires the GL_ARB_occlusion_query extension." + exitFailure + + bits <- get (queryCounterBits SamplesPassed) + unless (bits > 0) $ do + putStrLn "Hmmm, GL_QUERY_COUNTER_BITS_ARB is zero!" + exitFailure + + depthFunc $= Just Less + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialWindowPosition $= Position 0 0 + initialWindowSize $= Size 400 400 + initialDisplayMode $= [ RGBMode, DoubleBuffered, WithDepthBuffer ] + _ <- createWindow progName + state <- makeState + reshapeCallback $= Just (\size -> viewport $= (Position 0 0, size)) + keyboardMouseCallback $= Just (keyboard state) + setIdleCallback state + occQuery <- genObjectName + displayCallback $= display occQuery state + myInit + mainLoop diff --git a/examples/Misc/ExtractContours.hs b/examples/Misc/ExtractContours.hs --- a/examples/Misc/ExtractContours.hs +++ b/examples/Misc/ExtractContours.hs @@ -1,117 +1,117 @@ -{- - ExtractContours.hs (adapted from tess.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates contour extraction. Two tesselated objects are - drawn. The first is a rectangle with a triangular hole. The second is a - smooth shaded, self-intersecting star. - - Note the exterior rectangle is drawn with its vertices in counter-clockwise - order, but its interior clockwise. Note the combineCallback is needed for the - self-intersecting star. Also note that removing the TessProperty for the - star will make the interior unshaded (TessWindingOdd). --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -display :: [DisplayList] -> DisplayCallback -display displayLists = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - color3f (Color3 1 1 1) - mapM_ callList displayLists - flush - --- 'Float' is a dummy, any marshalable type would do -type DontCare = Float - -rectangle :: ComplexContour DontCare -rectangle = ComplexContour [ - AnnotatedVertex (Vertex3 50 50 0) 0, - AnnotatedVertex (Vertex3 200 50 0) 0, - AnnotatedVertex (Vertex3 200 200 0) 0, - AnnotatedVertex (Vertex3 50 200 0) 0 ] - -tri :: ComplexContour DontCare -tri = ComplexContour [ - AnnotatedVertex (Vertex3 75 75 0) 0, - AnnotatedVertex (Vertex3 125 175 0) 0, - AnnotatedVertex (Vertex3 175 75 0) 0 ] - -rectAndTri :: ComplexPolygon DontCare -rectAndTri = ComplexPolygon [ rectangle, tri ] - -noOpCombiner :: Combiner DontCare -noOpCombiner _newVertex _weightedProperties = 0 - -star :: ComplexPolygon (Color3 GLfloat) -star = ComplexPolygon [ - ComplexContour [ - AnnotatedVertex (Vertex3 250 50 0) (Color3 1 0 1), - AnnotatedVertex (Vertex3 325 200 0) (Color3 1 1 0), - AnnotatedVertex (Vertex3 400 50 0) (Color3 0 1 1), - AnnotatedVertex (Vertex3 250 150 0) (Color3 1 0 0), - AnnotatedVertex (Vertex3 400 150 0) (Color3 0 1 0) ] ] - -combineColors :: Combiner (Color3 GLfloat) -combineColors - _newVertex - (WeightedProperties - (w0, Color3 r0 g0 b0) - (w1, Color3 r1 g1 b1) - (w2, Color3 r2 g2 b2) - (w3, Color3 r3 g3 b3)) = - Color3 (w0*r0 + w1*r1 + w2*r2 + w3*r3) - (w0*g0 + w1*g1 + w2*g2 + w3*g3) - (w0*b0 + w1*b1 + w2*b2 + w3*b3) - -myInit :: IO [DisplayList] -myInit = do - clearColor $= Color4 0 0 0 0 - - rectAndTriList <- defineNewList Compile $ - drawPolygonContours (\_ -> return ()) =<< - extractContours TessWindingOdd 0 (Normal3 0 0 0) noOpCombiner rectAndTri - - starList <- defineNewList Compile $ - drawPolygonContours color =<< - extractContours TessWindingPositive 0 (Normal3 0 0 0) combineColors star - - return [ rectAndTriList, starList ] - -drawPolygonContours :: (v -> IO ()) -> PolygonContours v -> IO () -drawPolygonContours colorHandler (PolygonContours simpleContours) = - flip mapM_ simpleContours $ \(SimpleContour vertices) -> - renderPrimitive LineLoop $ - flip mapM_ vertices $ \(AnnotatedVertex plainVertex col) -> do - colorHandler col - vertex plainVertex - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 (fromIntegral w) 0 (fromIntegral h) - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - _ <- createWindow progName - displayLists <- myInit - displayCallback $= display displayLists - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + ExtractContours.hs (adapted from tess.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates contour extraction. Two tesselated objects are + drawn. The first is a rectangle with a triangular hole. The second is a + smooth shaded, self-intersecting star. + + Note the exterior rectangle is drawn with its vertices in counter-clockwise + order, but its interior clockwise. Note the combineCallback is needed for the + self-intersecting star. Also note that removing the TessProperty for the + star will make the interior unshaded (TessWindingOdd). +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +display :: [DisplayList] -> DisplayCallback +display displayLists = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 1 1 1) + mapM_ callList displayLists + flush + +-- 'Float' is a dummy, any marshalable type would do +type DontCare = Float + +rectangle :: ComplexContour DontCare +rectangle = ComplexContour [ + AnnotatedVertex (Vertex3 50 50 0) 0, + AnnotatedVertex (Vertex3 200 50 0) 0, + AnnotatedVertex (Vertex3 200 200 0) 0, + AnnotatedVertex (Vertex3 50 200 0) 0 ] + +tri :: ComplexContour DontCare +tri = ComplexContour [ + AnnotatedVertex (Vertex3 75 75 0) 0, + AnnotatedVertex (Vertex3 125 175 0) 0, + AnnotatedVertex (Vertex3 175 75 0) 0 ] + +rectAndTri :: ComplexPolygon DontCare +rectAndTri = ComplexPolygon [ rectangle, tri ] + +noOpCombiner :: Combiner DontCare +noOpCombiner _newVertex _weightedProperties = 0 + +star :: ComplexPolygon (Color3 GLfloat) +star = ComplexPolygon [ + ComplexContour [ + AnnotatedVertex (Vertex3 250 50 0) (Color3 1 0 1), + AnnotatedVertex (Vertex3 325 200 0) (Color3 1 1 0), + AnnotatedVertex (Vertex3 400 50 0) (Color3 0 1 1), + AnnotatedVertex (Vertex3 250 150 0) (Color3 1 0 0), + AnnotatedVertex (Vertex3 400 150 0) (Color3 0 1 0) ] ] + +combineColors :: Combiner (Color3 GLfloat) +combineColors + _newVertex + (WeightedProperties + (w0, Color3 r0 g0 b0) + (w1, Color3 r1 g1 b1) + (w2, Color3 r2 g2 b2) + (w3, Color3 r3 g3 b3)) = + Color3 (w0*r0 + w1*r1 + w2*r2 + w3*r3) + (w0*g0 + w1*g1 + w2*g2 + w3*g3) + (w0*b0 + w1*b1 + w2*b2 + w3*b3) + +myInit :: IO [DisplayList] +myInit = do + clearColor $= Color4 0 0 0 0 + + rectAndTriList <- defineNewList Compile $ + drawPolygonContours (\_ -> return ()) =<< + extractContours TessWindingOdd 0 (Normal3 0 0 0) noOpCombiner rectAndTri + + starList <- defineNewList Compile $ + drawPolygonContours color =<< + extractContours TessWindingPositive 0 (Normal3 0 0 0) combineColors star + + return [ rectAndTriList, starList ] + +drawPolygonContours :: (v -> IO ()) -> PolygonContours v -> IO () +drawPolygonContours colorHandler (PolygonContours simpleContours) = + flip mapM_ simpleContours $ \(SimpleContour vertices) -> + renderPrimitive LineLoop $ + flip mapM_ vertices $ \(AnnotatedVertex plainVertex col) -> do + colorHandler col + vertex plainVertex + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + _ <- createWindow progName + displayLists <- myInit + displayCallback $= display displayLists + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/Misc/Gears.hs b/examples/Misc/Gears.hs --- a/examples/Misc/Gears.hs +++ b/examples/Misc/Gears.hs @@ -1,301 +1,301 @@ -{- - Gears.hs (adapted from gears.c which is (c) Brian Paul) - Copyright (c) Shawn P. Garbett 2004 - Further hacked by Sven Panne - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Command line options: - -info print GL implementation information - -exit automatically exit after 30 seconds --} - --------------------------------------------------------------------------------- - -import Control.Monad ( when ) -import Data.IORef ( IORef, newIORef ) -import Data.List ( intersperse ) -import System.Console.GetOpt -import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure ) -import Graphics.UI.GLUT - --------------------------------------------------------------------------------- - -type View = (GLfloat, GLfloat, GLfloat) - -data State = State { - frames :: IORef Int, - t0 :: IORef Int, - viewRot :: IORef View, - angle' :: IORef GLfloat } - -makeState :: IO State -makeState = do - f <- newIORef 0 - t <- newIORef 0 - v <- newIORef (20, 30, 0) - a <- newIORef 0 - return $ State { frames = f, t0 = t, viewRot = v, angle' = a } - --- Draw a gear wheel. You'll probably want to call this function when --- building a display list since we do a lot of trig here. --- --- Input: innerRadius - radius of hole at center --- outerRadius - radius at center of teeth --- width - width of gear --- teeth - number of teeth --- toothDepth - depth of tooth - -gear :: GLfloat -> GLfloat -> GLfloat -> GLint -> GLfloat -> IO () -gear innerRadius outerRadius width teeth toothDepth = do - let r0 = innerRadius - r1 = outerRadius - toothDepth / 2 - r2 = outerRadius + toothDepth / 2 - - da = 2 * pi / fromIntegral teeth / 4 - w = 0.5 * width - - render p f = - renderPrimitive p $ - mapM_ (\i -> let angle = fromIntegral i * 2 * pi / fromIntegral teeth - in f r0 r1 r2 w da teeth i angle) - [ 0 .. teeth ] - - shadeModel $= Flat - currentNormal $= Normal3 0 0 1 - render QuadStrip gearFront - render Quads teethFront - currentNormal $= Normal3 0 0 (-1) - render QuadStrip gearBack - render Quads teethBack - render QuadStrip teethFace - shadeModel $= Smooth - render QuadStrip gearInside - -type Renderer = - GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLint -> GLint -> GLfloat -> IO () - --- draw front face -gearFront :: Renderer -gearFront r0 r1 _ w da teeth i angle = do - vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) w) - vertex (Vertex3 (r1 * cos angle) (r1 * sin angle) w) - when (i < teeth) $ do - vertex (Vertex3 (r0 * cos angle ) (r0 * sin angle ) w) - vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) w) - --- draw front sides of teeth -teethFront :: Renderer -teethFront _ r1 r2 w da teeth i angle = - when (i < teeth) $ do - vertex (Vertex3 (r1 * cos angle ) (r1 * sin angle ) w) - vertex (Vertex3 (r2 * cos (angle + da)) (r2 * sin (angle + da)) w) - vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) w) - vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) w) - --- draw back face -gearBack :: Renderer -gearBack r0 r1 _ w da teeth i angle = do - vertex (Vertex3 (r1 * cos angle) (r1 * sin angle) (-w)) - vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) (-w)) - when (i < teeth) $ do - vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) (-w)) - vertex (Vertex3 (r0 * cos angle ) (r0 * sin angle ) (-w)) - --- draw back sides of teeth -teethBack :: Renderer -teethBack _ r1 r2 w da teeth i angle = - when (i < teeth) $ do - vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) (-w)) - vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) (-w)) - vertex (Vertex3 (r2 * cos (angle + da)) (r2 * sin (angle + da)) (-w)) - vertex (Vertex3 (r1 * cos angle ) (r1 * sin angle ) (-w)) - --- draw outward faces of teeth -teethFace :: Renderer -teethFace _ r1 r2 w da teeth i angle = - if (i < teeth) then do - vertex (Vertex3 (r1*(cos angle)) (r1*(sin angle)) w) - vertex (Vertex3 (r1*(cos angle)) (r1*(sin angle)) (-w)) - - let u' = r2 * cos (angle + da) - r1 * cos angle - v' = r2 * sin (angle + da) - r1 * sin angle - len = sqrt (u' * u' + v' * v') - u = u' / len - v = v' / len - currentNormal $= Normal3 v (-u) 0 - vertex (Vertex3 (r2 * cos (angle + da)) (r2 * sin (angle + da)) w ) - vertex (Vertex3 (r2 * cos (angle + da)) (r2 * sin (angle + da)) (-w)) - currentNormal $= Normal3 (cos angle) (sin angle) 0 - vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) w ) - vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) (-w)) - let u2 = r1 * cos (angle + 3 * da) - r2 * cos (angle + 2 * da); - v2 = r1 * sin (angle + 3 * da) - r2 * sin (angle + 2 * da); - currentNormal $= Normal3 v2 (-u2) 0 - vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) w ) - vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) (-w)) - currentNormal $= Normal3 (cos angle) (sin angle) 0 - else do - vertex (Vertex3 (r1 * cos 0) (r1 * sin 0) w ) - vertex (Vertex3 (r1 * cos 0) (r1 * sin 0) (-w)) - --- draw inside radius cylinder -gearInside :: Renderer -gearInside r0 _ _ w _ _ _ angle = do - currentNormal $= Normal3 (-cos angle) (-sin angle) 0 - vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) (-w)) - vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) w ) - -draw :: (DisplayList,DisplayList,DisplayList,Int) -> State -> IO () -draw (gear1, gear2, gear3, autoexit) state = do - clear [ ColorBuffer, DepthBuffer ] - (x, y, z) <- get (viewRot state) - a <- get (angle' state) - - let translatef = translate :: Vector3 GLfloat -> IO () - preservingMatrix $ do - rotate x (Vector3 1 0 0) - rotate y (Vector3 0 1 0) - rotate z (Vector3 0 0 1) - - preservingMatrix $ do - translatef (Vector3 (-3) (-2) 0) - rotate a (Vector3 0 0 1) - callList gear1 - - preservingMatrix $ do - translatef (Vector3 3.1 (-2) 0) - rotate (-2 * a - 9) (Vector3 0 0 1) - callList gear2 - - preservingMatrix $ do - translatef (Vector3 (-3.1) 4.2 0) - rotate (-2 * a - 25) (Vector3 0 0 1) - callList gear3 - - swapBuffers - frames state $~! (+1) - t0' <- get (t0 state) - t <- get elapsedTime - when (t - t0' >= 5000) $ do - f <- get (frames state) - let seconds = fromIntegral (t - t0') / 1000 :: GLfloat - fps = fromIntegral f / seconds - putStrLn (show f ++ " frames in " ++ show seconds ++ " seconds = "++ show fps ++ " FPS") - t0 state $= t - frames state $= 0 - when ((t >= 999 * autoexit) && (autoexit /= 0)) $ - exitWith ExitSuccess - -idle :: State -> IdleCallback -idle state = do - angle' state $~! (+2) - postRedisplay Nothing - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char 'z') _ _ _ = modRot state ( 0, 0, 5) -keyboard state (Char 'Z') _ _ _ = modRot state ( 0, 0, -5) -keyboard state (SpecialKey KeyUp) _ _ _ = modRot state ( 5, 0, 0) -keyboard state (SpecialKey KeyDown) _ _ _ = modRot state (-5, 0, 0) -keyboard state (SpecialKey KeyLeft) _ _ _ = modRot state ( 0, 5, 0) -keyboard state (SpecialKey KeyRight)_ _ _ = modRot state ( 0, -5, 0) -keyboard _ (Char '\27') _ _ _ = exitWith ExitSuccess -keyboard _ _ _ _ _ = return () - -modRot :: State -> View -> IO () -modRot state (dx,dy,dz) = do - (x, y, z) <- get (viewRot state) - viewRot state $= (x + dx, y + dy, z + dz) - postRedisplay Nothing - --- new window size or exposure -reshape :: ReshapeCallback -reshape s@(Size width height) = do - let h = fromIntegral height / fromIntegral width - - viewport $= (Position 0 0, s) - matrixMode $= Projection - loadIdentity - frustum (-1) 1 (-h) h 5 60 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-40 :: GLfloat)) - -data Flag = GLInfo | AutoExit deriving ( Eq, Ord, Show ) - -argInfo :: [OptDescr Flag] -argInfo = [ - Option ['i'] ["info"] (NoArg GLInfo) "print gl information", - Option ['e'] ["exit"] (NoArg AutoExit) "auto exit after 30 seconds" ] - -opts :: [String] -> IO [Flag] -opts args = - case getOpt Permute argInfo args of - (o,_,[]) -> return o - (_,_,errs) -> do - putStr (concat errs ++ usageInfo "Usage: Gears [OPTION...]" argInfo) - exitFailure - -info :: IO () -info = do - rendererStr <- get renderer - putStrLn ("GL_RENDERER = " ++ rendererStr) - vendorStr <- get vendor - putStrLn ("GL_VENDOR = " ++ vendorStr) - versionStr <- get glVersion - putStrLn ("GL_VERSION = " ++ versionStr) - exts <- get glExtensions - putStrLn ("GL_EXTENSIONS = " ++ concat (intersperse " " exts)) - -myInit :: [String] -> IO (DisplayList,DisplayList,DisplayList,Int) -myInit args = do - position (Light 0) $= Vertex4 5 5 10 0 - cullFace $= Just Back - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - - -- make the gears - g1 <- defineNewList Compile $ do - materialAmbientAndDiffuse Front $= Color4 0.8 0.1 0.0 1.0 - gear 1 4 1 20 0.7 - - g2 <- defineNewList Compile $ do - materialAmbientAndDiffuse Front $= Color4 0.0 0.8 0.2 1.0 - gear 0.5 2 2 10 0.7 - - g3 <- defineNewList Compile $ do - materialAmbientAndDiffuse Front $= Color4 0.2 0.2 1.0 1.0 - gear 1.3 2 0.5 10 0.7 - - normalize $= Enabled - - flags <- opts args - when (GLInfo `elem` flags) info - let autoexit = if AutoExit `elem` flags then 30 else 0 - when (autoexit /= 0) $ - putStrLn ("Auto Exit after " ++ show autoexit ++ " seconds.") - - return (g1, g2, g3, autoexit) - -visible :: State -> Visibility -> IO () -visible state Visible = idleCallback $= Just (idle state) -visible _ NotVisible = idleCallback $= Nothing - -main :: IO () -main = do - (_progName, args) <- getArgsAndInitialize - initialDisplayMode $= [ RGBMode, WithDepthBuffer, DoubleBuffered ] - - initialWindowPosition $= Position 0 0 - initialWindowSize $= Size 300 300 - _ <- createWindow "Gears" - state <- makeState - gearsAndAuto <- myInit args - - displayCallback $= draw gearsAndAuto state - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - visibilityCallback $= Just (visible state) - - mainLoop +{- + Gears.hs (adapted from gears.c which is (c) Brian Paul) + Copyright (c) Shawn P. Garbett 2004 + Further hacked by Sven Panne + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Command line options: + -info print GL implementation information + -exit automatically exit after 30 seconds +-} + +-------------------------------------------------------------------------------- + +import Control.Monad ( when ) +import Data.IORef ( IORef, newIORef ) +import Data.List ( intersperse ) +import System.Console.GetOpt +import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure ) +import Graphics.UI.GLUT + +-------------------------------------------------------------------------------- + +type View = (GLfloat, GLfloat, GLfloat) + +data State = State { + frames :: IORef Int, + t0 :: IORef Int, + viewRot :: IORef View, + angle' :: IORef GLfloat } + +makeState :: IO State +makeState = do + f <- newIORef 0 + t <- newIORef 0 + v <- newIORef (20, 30, 0) + a <- newIORef 0 + return $ State { frames = f, t0 = t, viewRot = v, angle' = a } + +-- Draw a gear wheel. You'll probably want to call this function when +-- building a display list since we do a lot of trig here. +-- +-- Input: innerRadius - radius of hole at center +-- outerRadius - radius at center of teeth +-- width - width of gear +-- teeth - number of teeth +-- toothDepth - depth of tooth + +gear :: GLfloat -> GLfloat -> GLfloat -> GLint -> GLfloat -> IO () +gear innerRadius outerRadius width teeth toothDepth = do + let r0 = innerRadius + r1 = outerRadius - toothDepth / 2 + r2 = outerRadius + toothDepth / 2 + + da = 2 * pi / fromIntegral teeth / 4 + w = 0.5 * width + + render p f = + renderPrimitive p $ + mapM_ (\i -> let angle = fromIntegral i * 2 * pi / fromIntegral teeth + in f r0 r1 r2 w da teeth i angle) + [ 0 .. teeth ] + + shadeModel $= Flat + currentNormal $= Normal3 0 0 1 + render QuadStrip gearFront + render Quads teethFront + currentNormal $= Normal3 0 0 (-1) + render QuadStrip gearBack + render Quads teethBack + render QuadStrip teethFace + shadeModel $= Smooth + render QuadStrip gearInside + +type Renderer = + GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLint -> GLint -> GLfloat -> IO () + +-- draw front face +gearFront :: Renderer +gearFront r0 r1 _ w da teeth i angle = do + vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) w) + vertex (Vertex3 (r1 * cos angle) (r1 * sin angle) w) + when (i < teeth) $ do + vertex (Vertex3 (r0 * cos angle ) (r0 * sin angle ) w) + vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) w) + +-- draw front sides of teeth +teethFront :: Renderer +teethFront _ r1 r2 w da teeth i angle = + when (i < teeth) $ do + vertex (Vertex3 (r1 * cos angle ) (r1 * sin angle ) w) + vertex (Vertex3 (r2 * cos (angle + da)) (r2 * sin (angle + da)) w) + vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) w) + vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) w) + +-- draw back face +gearBack :: Renderer +gearBack r0 r1 _ w da teeth i angle = do + vertex (Vertex3 (r1 * cos angle) (r1 * sin angle) (-w)) + vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) (-w)) + when (i < teeth) $ do + vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) (-w)) + vertex (Vertex3 (r0 * cos angle ) (r0 * sin angle ) (-w)) + +-- draw back sides of teeth +teethBack :: Renderer +teethBack _ r1 r2 w da teeth i angle = + when (i < teeth) $ do + vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) (-w)) + vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) (-w)) + vertex (Vertex3 (r2 * cos (angle + da)) (r2 * sin (angle + da)) (-w)) + vertex (Vertex3 (r1 * cos angle ) (r1 * sin angle ) (-w)) + +-- draw outward faces of teeth +teethFace :: Renderer +teethFace _ r1 r2 w da teeth i angle = + if (i < teeth) then do + vertex (Vertex3 (r1*(cos angle)) (r1*(sin angle)) w) + vertex (Vertex3 (r1*(cos angle)) (r1*(sin angle)) (-w)) + + let u' = r2 * cos (angle + da) - r1 * cos angle + v' = r2 * sin (angle + da) - r1 * sin angle + len = sqrt (u' * u' + v' * v') + u = u' / len + v = v' / len + currentNormal $= Normal3 v (-u) 0 + vertex (Vertex3 (r2 * cos (angle + da)) (r2 * sin (angle + da)) w ) + vertex (Vertex3 (r2 * cos (angle + da)) (r2 * sin (angle + da)) (-w)) + currentNormal $= Normal3 (cos angle) (sin angle) 0 + vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) w ) + vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) (-w)) + let u2 = r1 * cos (angle + 3 * da) - r2 * cos (angle + 2 * da); + v2 = r1 * sin (angle + 3 * da) - r2 * sin (angle + 2 * da); + currentNormal $= Normal3 v2 (-u2) 0 + vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) w ) + vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) (-w)) + currentNormal $= Normal3 (cos angle) (sin angle) 0 + else do + vertex (Vertex3 (r1 * cos 0) (r1 * sin 0) w ) + vertex (Vertex3 (r1 * cos 0) (r1 * sin 0) (-w)) + +-- draw inside radius cylinder +gearInside :: Renderer +gearInside r0 _ _ w _ _ _ angle = do + currentNormal $= Normal3 (-cos angle) (-sin angle) 0 + vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) (-w)) + vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) w ) + +draw :: (DisplayList,DisplayList,DisplayList,Int) -> State -> IO () +draw (gear1, gear2, gear3, autoexit) state = do + clear [ ColorBuffer, DepthBuffer ] + (x, y, z) <- get (viewRot state) + a <- get (angle' state) + + let translatef = translate :: Vector3 GLfloat -> IO () + preservingMatrix $ do + rotate x (Vector3 1 0 0) + rotate y (Vector3 0 1 0) + rotate z (Vector3 0 0 1) + + preservingMatrix $ do + translatef (Vector3 (-3) (-2) 0) + rotate a (Vector3 0 0 1) + callList gear1 + + preservingMatrix $ do + translatef (Vector3 3.1 (-2) 0) + rotate (-2 * a - 9) (Vector3 0 0 1) + callList gear2 + + preservingMatrix $ do + translatef (Vector3 (-3.1) 4.2 0) + rotate (-2 * a - 25) (Vector3 0 0 1) + callList gear3 + + swapBuffers + frames state $~! (+1) + t0' <- get (t0 state) + t <- get elapsedTime + when (t - t0' >= 5000) $ do + f <- get (frames state) + let seconds = fromIntegral (t - t0') / 1000 :: GLfloat + fps = fromIntegral f / seconds + putStrLn (show f ++ " frames in " ++ show seconds ++ " seconds = "++ show fps ++ " FPS") + t0 state $= t + frames state $= 0 + when ((t >= 999 * autoexit) && (autoexit /= 0)) $ + exitWith ExitSuccess + +idle :: State -> IdleCallback +idle state = do + angle' state $~! (+2) + postRedisplay Nothing + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char 'z') _ _ _ = modRot state ( 0, 0, 5) +keyboard state (Char 'Z') _ _ _ = modRot state ( 0, 0, -5) +keyboard state (SpecialKey KeyUp) _ _ _ = modRot state ( 5, 0, 0) +keyboard state (SpecialKey KeyDown) _ _ _ = modRot state (-5, 0, 0) +keyboard state (SpecialKey KeyLeft) _ _ _ = modRot state ( 0, 5, 0) +keyboard state (SpecialKey KeyRight)_ _ _ = modRot state ( 0, -5, 0) +keyboard _ (Char '\27') _ _ _ = exitWith ExitSuccess +keyboard _ _ _ _ _ = return () + +modRot :: State -> View -> IO () +modRot state (dx,dy,dz) = do + (x, y, z) <- get (viewRot state) + viewRot state $= (x + dx, y + dy, z + dz) + postRedisplay Nothing + +-- new window size or exposure +reshape :: ReshapeCallback +reshape s@(Size width height) = do + let h = fromIntegral height / fromIntegral width + + viewport $= (Position 0 0, s) + matrixMode $= Projection + loadIdentity + frustum (-1) 1 (-h) h 5 60 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-40 :: GLfloat)) + +data Flag = GLInfo | AutoExit deriving ( Eq, Ord, Show ) + +argInfo :: [OptDescr Flag] +argInfo = [ + Option ['i'] ["info"] (NoArg GLInfo) "print gl information", + Option ['e'] ["exit"] (NoArg AutoExit) "auto exit after 30 seconds" ] + +opts :: [String] -> IO [Flag] +opts args = + case getOpt Permute argInfo args of + (o,_,[]) -> return o + (_,_,errs) -> do + putStr (concat errs ++ usageInfo "Usage: Gears [OPTION...]" argInfo) + exitFailure + +info :: IO () +info = do + rendererStr <- get renderer + putStrLn ("GL_RENDERER = " ++ rendererStr) + vendorStr <- get vendor + putStrLn ("GL_VENDOR = " ++ vendorStr) + versionStr <- get glVersion + putStrLn ("GL_VERSION = " ++ versionStr) + exts <- get glExtensions + putStrLn ("GL_EXTENSIONS = " ++ concat (intersperse " " exts)) + +myInit :: [String] -> IO (DisplayList,DisplayList,DisplayList,Int) +myInit args = do + position (Light 0) $= Vertex4 5 5 10 0 + cullFace $= Just Back + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + + -- make the gears + g1 <- defineNewList Compile $ do + materialAmbientAndDiffuse Front $= Color4 0.8 0.1 0.0 1.0 + gear 1 4 1 20 0.7 + + g2 <- defineNewList Compile $ do + materialAmbientAndDiffuse Front $= Color4 0.0 0.8 0.2 1.0 + gear 0.5 2 2 10 0.7 + + g3 <- defineNewList Compile $ do + materialAmbientAndDiffuse Front $= Color4 0.2 0.2 1.0 1.0 + gear 1.3 2 0.5 10 0.7 + + normalize $= Enabled + + flags <- opts args + when (GLInfo `elem` flags) info + let autoexit = if AutoExit `elem` flags then 30 else 0 + when (autoexit /= 0) $ + putStrLn ("Auto Exit after " ++ show autoexit ++ " seconds.") + + return (g1, g2, g3, autoexit) + +visible :: State -> Visibility -> IO () +visible state Visible = idleCallback $= Just (idle state) +visible _ NotVisible = idleCallback $= Nothing + +main :: IO () +main = do + (_progName, args) <- getArgsAndInitialize + initialDisplayMode $= [ RGBMode, WithDepthBuffer, DoubleBuffered ] + + initialWindowPosition $= Position 0 0 + initialWindowSize $= Size 300 300 + _ <- createWindow "Gears" + state <- makeState + gearsAndAuto <- myInit args + + displayCallback $= draw gearsAndAuto state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + visibilityCallback $= Just (visible state) + + mainLoop diff --git a/examples/Misc/Makefile b/examples/Misc/Makefile --- a/examples/Misc/Makefile +++ b/examples/Misc/Makefile @@ -1,1 +1,1 @@ -include ../examples.mk +include ../examples.mk diff --git a/examples/Misc/Pitfall14.hs b/examples/Misc/Pitfall14.hs --- a/examples/Misc/Pitfall14.hs +++ b/examples/Misc/Pitfall14.hs @@ -1,33 +1,33 @@ -{- - Pitfall14 - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates pitfall 14 (Careful Enabling Color Material) - of Mark Kilgard's "16 Common OpenGL Pitfalls", see: - http://www.opengl.org/resources/features/KilgardTechniques/oglpitfall/ --} - -import Control.Monad ( unless ) -import System.Exit ( exitFailure ) -import Graphics.UI.GLUT - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - _ <- createWindow progName - - currentColor $= Color4 1 1 1 1 - materialAmbient Front $= Color4 0.1 0.1 0.1 1 - -- re-get to avoid any rounding issues - mafBefore <- get (materialAmbient Front) - - colorMaterial $= Just (Front, Diffuse) - mafAfter <- get (materialAmbient Front) - unless (mafBefore == mafAfter) $ do - putStrLn "ERROR: The ambient material property changed!" - putStrLn (" before: " ++ show mafBefore) - putStrLn (" after : " ++ show mafAfter) - exitFailure +{- + Pitfall14 + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates pitfall 14 (Careful Enabling Color Material) + of Mark Kilgard's "16 Common OpenGL Pitfalls", see: + http://www.opengl.org/resources/features/KilgardTechniques/oglpitfall/ +-} + +import Control.Monad ( unless ) +import System.Exit ( exitFailure ) +import Graphics.UI.GLUT + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + _ <- createWindow progName + + currentColor $= Color4 1 1 1 1 + materialAmbient Front $= Color4 0.1 0.1 0.1 1 + -- re-get to avoid any rounding issues + mafBefore <- get (materialAmbient Front) + + colorMaterial $= Just (Front, Diffuse) + mafAfter <- get (materialAmbient Front) + unless (mafBefore == mafAfter) $ do + putStrLn "ERROR: The ambient material property changed!" + putStrLn (" before: " ++ show mafBefore) + putStrLn (" after : " ++ show mafAfter) + exitFailure diff --git a/examples/Misc/SmoothOpenGL3.hs b/examples/Misc/SmoothOpenGL3.hs --- a/examples/Misc/SmoothOpenGL3.hs +++ b/examples/Misc/SmoothOpenGL3.hs @@ -1,272 +1,272 @@ -{- - SmoothOpenGL3.hs (adapted from freeglut's smooth_opengl3.c example) - Copyright (c) Sven Panne 2009 - This file is part of HOpenGL and distributed under a BSD-style license - See the file LICENSE --} - -import Control.Monad -import qualified Data.ByteString as B -import Data.List -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Foreign.Marshal.Array -import Foreign.Ptr -import Foreign.Storable -import Graphics.Rendering.OpenGL.Raw.Core31 -import Graphics.UI.GLUT -import System.Exit -import System.IO - -data State = State { - vertexBufferName :: BufferObject, - fgProjectionMatrixIndex :: UniformLocation, - fgColorIndex :: AttribLocation , - fgVertexIndex :: AttribLocation, - projectionMatrix :: GLmatrix GLfloat } - -checkError :: String -> IO () -checkError functionName = get errors >>= mapM_ reportError - where reportError e = - hPutStrLn stderr (showError e ++ " detected in " ++ functionName) - showError (Error category message) = - "GL error " ++ show category ++ " (" ++ message ++ ")" - -varray :: [GLfloat] -varray = [ - 1, 0, 0, -- red - 5, 5, -- lower left - - 0, 1, 0, -- green - 25, 5, -- lower right - - 0, 0, 1, -- blue - 5, 25 ] -- upper left - -numColorComponents :: NumComponents -numColorComponents = 3 - -numVertexComponents :: NumComponents -numVertexComponents = 2 - -sizeOfComponent :: Int -sizeOfComponent = sizeOf (head varray) - -stride :: Stride -stride = fromIntegral sizeOfComponent * fromIntegral (numColorComponents + numVertexComponents) - -sizeOfVarray :: Int -sizeOfVarray = length varray * sizeOfComponent - -numElements :: NumArrayIndices -numElements = fromIntegral sizeOfVarray `div` fromIntegral stride - -initBuffer :: IO BufferObject -initBuffer = do - bufferObject <- genObjectName - bindBuffer ArrayBuffer $= Just bufferObject - withArray varray $ \buffer -> - bufferData ArrayBuffer $= (fromIntegral sizeOfVarray, buffer, StaticDraw) - checkError "initBuffer" - return bufferObject - -packUtf8 :: String -> B.ByteString -packUtf8 = TE.encodeUtf8 . T.pack - -vertexShaderSource :: B.ByteString -vertexShaderSource = packUtf8 . unlines $ [ - "#version 140", - "uniform mat4 fg_ProjectionMatrix;", - "in vec4 fg_Color;", - "in vec4 fg_Vertex;", - "smooth out vec4 fg_SmoothColor;", - "void main()", - "{", - " fg_SmoothColor = fg_Color;", - " gl_Position = fg_ProjectionMatrix * fg_Vertex;", - "}" ] - -fragmentShaderSource :: B.ByteString -fragmentShaderSource = packUtf8 . unlines $ [ - "#version 140", - "smooth in vec4 fg_SmoothColor;", - "out vec4 fg_FragColor;", - "void main(void)", - "{", - " fg_FragColor = fg_SmoothColor;", - "}" ] - -checked :: (t -> IO ()) -> (t -> GettableStateVar Bool) -> (t -> GettableStateVar String) -> String -> t -> IO () -checked action getStatus getInfoLog message object = do - action object - status <- get (getStatus object) - unless status $ - hPutStrLn stderr . ((message ++ " log: ") ++) =<< get (getInfoLog object) - -compileAndCheck :: Shader -> IO () -compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile" - -compileShaderSource :: ShaderType -> B.ByteString -> IO Shader -compileShaderSource st source = do - shader <- createShader st - shaderSourceBS shader $= source - compileAndCheck shader - return shader - -linkAndCheck :: Program -> IO () -linkAndCheck = checked linkProgram linkStatus programInfoLog "link" - -createProgramUsing :: [Shader] -> IO Program -createProgramUsing shaders = do - program <- createProgram - attachedShaders program $= shaders - linkAndCheck program - return program - -initShader :: IO (UniformLocation, AttribLocation, AttribLocation) -initShader = do - vertexShader <- compileShaderSource VertexShader vertexShaderSource - fragmentShader <- compileShaderSource FragmentShader fragmentShaderSource - program <- createProgramUsing [vertexShader, fragmentShader] - currentProgram $= Just program - - projectionMatrixIndex <- get (uniformLocation program "fg_ProjectionMatrix") - - colorIndex <- get (attribLocation program "fg_Color") - vertexAttribArray colorIndex $= Enabled - - vertexIndex <- get (attribLocation program "fg_Vertex") - vertexAttribArray vertexIndex $= Enabled - - checkError "initShader" - return (projectionMatrixIndex, colorIndex, vertexIndex) - -initRendering :: IO () -initRendering = do - clearColor $= Color4 0 0 0 0 - checkError "initRendering" - -myInit :: IO State -myInit = do - bufferObject <- initBuffer - (projectionMatrixIndex, colorIndex, vertexIndex) <- initShader - initRendering - m <- newMatrix ColumnMajor (replicate 16 0) - return $ State { - vertexBufferName = bufferObject, - fgProjectionMatrixIndex = projectionMatrixIndex, - fgColorIndex = colorIndex, - fgVertexIndex = vertexIndex, - projectionMatrix = m } - -dumpInfo :: IO () -dumpInfo = do - let dump message var = putStrLn . ((message ++ ": ") ++) =<< get var - dump "Vendor" vendor - dump "Renderer" renderer - dump "Version" glVersion - dump "GLSL" shadingLanguageVersion - checkError "dumpInfo" - -bufferObjectPtr :: Integral a => a -> Ptr b -bufferObjectPtr = plusPtr (nullPtr :: Ptr GLchar) . fromIntegral - -vertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor a -vertexArrayDescriptor count offset = - VertexArrayDescriptor count Float stride (bufferObjectPtr (fromIntegral sizeOfComponent * offset)) - -triangle :: State -> IO () -triangle state = do - withMatrix (projectionMatrix state) $ \order buffer -> - uniformMatrix4fv (fgProjectionMatrixIndex state) 1 (order == RowMajor) buffer - bindBuffer ArrayBuffer $= Just (vertexBufferName state) - vertexAttribPointer (fgColorIndex state) $= - (ToFloat, vertexArrayDescriptor numColorComponents 0) - vertexAttribPointer (fgVertexIndex state) $= - (ToFloat, vertexArrayDescriptor numVertexComponents numColorComponents) - drawArrays Triangles 0 numElements - checkError "triangle" - --- The OpenGL package offers no interface for glUniformMatrix*fv yet -uniformMatrix4fv :: UniformLocation -> GLsizei -> Bool -> Ptr GLfloat -> IO () -uniformMatrix4fv location count = - glUniformMatrix4fv (uniformLocationToGLint location) count . marshalGLboolean - where marshalGLboolean x = fromIntegral $ case x of - False -> gl_FALSE - True -> gl_TRUE - -- MEGA HACK because UniformLocation is abstract - uniformLocationToGLint = read . head . tail . words . show - -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer ] - triangle state - flush - checkError "display" - -loadOrtho :: (Matrix m, MatrixComponent a, Fractional a) => m a -> a -> a -> a -> a -> a -> a -> IO () -loadOrtho m l r b t n f = - fillMatrix m [ - [2 / (r - l), - 0, - 0, - 0], - - [0, - 2 / (t - b), - 0, - 0], - - [0, - 0, - -2 / (f - n), - 0], - - [-(r + l) / (r - l), - -(t + b) / (t - b), - -(f + n) / (f - n), - 1 ]] - -fillMatrix :: (Matrix m, MatrixComponent a) => m a -> [[a]] -> IO () -fillMatrix m xs = - withMatrix m $ \order buffer -> - pokeArray buffer . concat . rearrange order $ xs - -rearrange :: MatrixOrder -> [[a]] -> [[a]] -rearrange ColumnMajor = id -rearrange RowMajor = transpose - -loadOrtho2D :: (Matrix m, MatrixComponent a, Fractional a) => m a -> a -> a -> a -> a -> IO () -loadOrtho2D m l r b t = loadOrtho m l r b t (-1) 1 - -reshape :: State -> ReshapeCallback -reshape state size@(Size w h) = do - viewport $= (Position 0 0, size) - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then loadOrtho2D (projectionMatrix state) 0 30 0 (30 * hf / wf) - else loadOrtho2D (projectionMatrix state) 0 (30 * wf / hf) 0 30 - checkError "reshape" - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - -- add command line argument "classic" for a pre-3.x context - unless (args == ["classic"]) $ do - initialContextVersion $= (3, 1) - initialContextFlags $= [ ForwardCompatibleContext, DebugContext ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - dumpInfo - state <- myInit - displayCallback $= display state - reshapeCallback $= Just (reshape state) - keyboardMouseCallback $= Just keyboard - mainLoop +{- + SmoothOpenGL3.hs (adapted from freeglut's smooth_opengl3.c example) + Copyright (c) Sven Panne 2009 + This file is part of HOpenGL and distributed under a BSD-style license + See the file LICENSE +-} + +import Control.Monad +import qualified Data.ByteString as B +import Data.List +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable +import Graphics.Rendering.OpenGL.Raw.Core31 +import Graphics.UI.GLUT +import System.Exit +import System.IO + +data State = State { + vertexBufferName :: BufferObject, + fgProjectionMatrixIndex :: UniformLocation, + fgColorIndex :: AttribLocation , + fgVertexIndex :: AttribLocation, + projectionMatrix :: GLmatrix GLfloat } + +checkError :: String -> IO () +checkError functionName = get errors >>= mapM_ reportError + where reportError e = + hPutStrLn stderr (showError e ++ " detected in " ++ functionName) + showError (Error category message) = + "GL error " ++ show category ++ " (" ++ message ++ ")" + +varray :: [GLfloat] +varray = [ + 1, 0, 0, -- red + 5, 5, -- lower left + + 0, 1, 0, -- green + 25, 5, -- lower right + + 0, 0, 1, -- blue + 5, 25 ] -- upper left + +numColorComponents :: NumComponents +numColorComponents = 3 + +numVertexComponents :: NumComponents +numVertexComponents = 2 + +sizeOfComponent :: Int +sizeOfComponent = sizeOf (head varray) + +stride :: Stride +stride = fromIntegral sizeOfComponent * fromIntegral (numColorComponents + numVertexComponents) + +sizeOfVarray :: Int +sizeOfVarray = length varray * sizeOfComponent + +numElements :: NumArrayIndices +numElements = fromIntegral sizeOfVarray `div` fromIntegral stride + +initBuffer :: IO BufferObject +initBuffer = do + bufferObject <- genObjectName + bindBuffer ArrayBuffer $= Just bufferObject + withArray varray $ \buffer -> + bufferData ArrayBuffer $= (fromIntegral sizeOfVarray, buffer, StaticDraw) + checkError "initBuffer" + return bufferObject + +packUtf8 :: String -> B.ByteString +packUtf8 = TE.encodeUtf8 . T.pack + +vertexShaderSource :: B.ByteString +vertexShaderSource = packUtf8 . unlines $ [ + "#version 140", + "uniform mat4 fg_ProjectionMatrix;", + "in vec4 fg_Color;", + "in vec4 fg_Vertex;", + "smooth out vec4 fg_SmoothColor;", + "void main()", + "{", + " fg_SmoothColor = fg_Color;", + " gl_Position = fg_ProjectionMatrix * fg_Vertex;", + "}" ] + +fragmentShaderSource :: B.ByteString +fragmentShaderSource = packUtf8 . unlines $ [ + "#version 140", + "smooth in vec4 fg_SmoothColor;", + "out vec4 fg_FragColor;", + "void main(void)", + "{", + " fg_FragColor = fg_SmoothColor;", + "}" ] + +checked :: (t -> IO ()) -> (t -> GettableStateVar Bool) -> (t -> GettableStateVar String) -> String -> t -> IO () +checked action getStatus getInfoLog message object = do + action object + status <- get (getStatus object) + unless status $ + hPutStrLn stderr . ((message ++ " log: ") ++) =<< get (getInfoLog object) + +compileAndCheck :: Shader -> IO () +compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile" + +compileShaderSource :: ShaderType -> B.ByteString -> IO Shader +compileShaderSource st source = do + shader <- createShader st + shaderSourceBS shader $= source + compileAndCheck shader + return shader + +linkAndCheck :: Program -> IO () +linkAndCheck = checked linkProgram linkStatus programInfoLog "link" + +createProgramUsing :: [Shader] -> IO Program +createProgramUsing shaders = do + program <- createProgram + attachedShaders program $= shaders + linkAndCheck program + return program + +initShader :: IO (UniformLocation, AttribLocation, AttribLocation) +initShader = do + vertexShader <- compileShaderSource VertexShader vertexShaderSource + fragmentShader <- compileShaderSource FragmentShader fragmentShaderSource + program <- createProgramUsing [vertexShader, fragmentShader] + currentProgram $= Just program + + projectionMatrixIndex <- get (uniformLocation program "fg_ProjectionMatrix") + + colorIndex <- get (attribLocation program "fg_Color") + vertexAttribArray colorIndex $= Enabled + + vertexIndex <- get (attribLocation program "fg_Vertex") + vertexAttribArray vertexIndex $= Enabled + + checkError "initShader" + return (projectionMatrixIndex, colorIndex, vertexIndex) + +initRendering :: IO () +initRendering = do + clearColor $= Color4 0 0 0 0 + checkError "initRendering" + +myInit :: IO State +myInit = do + bufferObject <- initBuffer + (projectionMatrixIndex, colorIndex, vertexIndex) <- initShader + initRendering + m <- newMatrix ColumnMajor (replicate 16 0) + return $ State { + vertexBufferName = bufferObject, + fgProjectionMatrixIndex = projectionMatrixIndex, + fgColorIndex = colorIndex, + fgVertexIndex = vertexIndex, + projectionMatrix = m } + +dumpInfo :: IO () +dumpInfo = do + let dump message var = putStrLn . ((message ++ ": ") ++) =<< get var + dump "Vendor" vendor + dump "Renderer" renderer + dump "Version" glVersion + dump "GLSL" shadingLanguageVersion + checkError "dumpInfo" + +bufferObjectPtr :: Integral a => a -> Ptr b +bufferObjectPtr = plusPtr (nullPtr :: Ptr GLchar) . fromIntegral + +vertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor a +vertexArrayDescriptor count offset = + VertexArrayDescriptor count Float stride (bufferObjectPtr (fromIntegral sizeOfComponent * offset)) + +triangle :: State -> IO () +triangle state = do + withMatrix (projectionMatrix state) $ \order buffer -> + uniformMatrix4fv (fgProjectionMatrixIndex state) 1 (order == RowMajor) buffer + bindBuffer ArrayBuffer $= Just (vertexBufferName state) + vertexAttribPointer (fgColorIndex state) $= + (ToFloat, vertexArrayDescriptor numColorComponents 0) + vertexAttribPointer (fgVertexIndex state) $= + (ToFloat, vertexArrayDescriptor numVertexComponents numColorComponents) + drawArrays Triangles 0 numElements + checkError "triangle" + +-- The OpenGL package offers no interface for glUniformMatrix*fv yet +uniformMatrix4fv :: UniformLocation -> GLsizei -> Bool -> Ptr GLfloat -> IO () +uniformMatrix4fv location count = + glUniformMatrix4fv (uniformLocationToGLint location) count . marshalGLboolean + where marshalGLboolean x = fromIntegral $ case x of + False -> gl_FALSE + True -> gl_TRUE + -- MEGA HACK because UniformLocation is abstract + uniformLocationToGLint = read . head . tail . words . show + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + triangle state + flush + checkError "display" + +loadOrtho :: (Matrix m, MatrixComponent a, Fractional a) => m a -> a -> a -> a -> a -> a -> a -> IO () +loadOrtho m l r b t n f = + fillMatrix m [ + [2 / (r - l), + 0, + 0, + 0], + + [0, + 2 / (t - b), + 0, + 0], + + [0, + 0, + -2 / (f - n), + 0], + + [-(r + l) / (r - l), + -(t + b) / (t - b), + -(f + n) / (f - n), + 1 ]] + +fillMatrix :: (Matrix m, MatrixComponent a) => m a -> [[a]] -> IO () +fillMatrix m xs = + withMatrix m $ \order buffer -> + pokeArray buffer . concat . rearrange order $ xs + +rearrange :: MatrixOrder -> [[a]] -> [[a]] +rearrange ColumnMajor = id +rearrange RowMajor = transpose + +loadOrtho2D :: (Matrix m, MatrixComponent a, Fractional a) => m a -> a -> a -> a -> a -> IO () +loadOrtho2D m l r b t = loadOrtho m l r b t (-1) 1 + +reshape :: State -> ReshapeCallback +reshape state size@(Size w h) = do + viewport $= (Position 0 0, size) + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then loadOrtho2D (projectionMatrix state) 0 30 0 (30 * hf / wf) + else loadOrtho2D (projectionMatrix state) 0 (30 * wf / hf) 0 30 + checkError "reshape" + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + -- add command line argument "classic" for a pre-3.x context + unless (args == ["classic"]) $ do + initialContextVersion $= (3, 1) + initialContextFlags $= [ ForwardCompatibleContext, DebugContext ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + dumpInfo + state <- myInit + displayCallback $= display state + reshapeCallback $= Just (reshape state) + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/Misc/Triangulate.hs b/examples/Misc/Triangulate.hs --- a/examples/Misc/Triangulate.hs +++ b/examples/Misc/Triangulate.hs @@ -1,122 +1,122 @@ -{- - Triangulate.hs (adapted from tess.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates polygon triangulation. Two tesselated objects are - drawn. The first is a rectangle with a triangular hole. The second is a - smooth shaded, self-intersecting star. - - Note the exterior rectangle is drawn with its vertices in counter-clockwise - order, but its interior clockwise. Note the combineCallback is needed for the - self-intersecting star. Also note that removing the TessProperty for the - star will make the interior unshaded (TessWindingOdd). --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import System.Random ( randomIO ) -import Graphics.UI.GLUT - -display :: [DisplayList] -> DisplayCallback -display displayLists = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - color3f (Color3 1 1 1) - mapM_ callList displayLists - flush - --- 'Float' is a dummy, any marshalable type would do -type DontCare = Float - -rectangle :: ComplexContour DontCare -rectangle = ComplexContour [ - AnnotatedVertex (Vertex3 50 50 0) 0, - AnnotatedVertex (Vertex3 200 50 0) 0, - AnnotatedVertex (Vertex3 200 200 0) 0, - AnnotatedVertex (Vertex3 50 200 0) 0 ] - -tri :: ComplexContour DontCare -tri = ComplexContour [ - AnnotatedVertex (Vertex3 75 75 0) 0, - AnnotatedVertex (Vertex3 125 175 0) 0, - AnnotatedVertex (Vertex3 175 75 0) 0 ] - -rectAndTri :: ComplexPolygon DontCare -rectAndTri = ComplexPolygon [ rectangle, tri ] - -star :: ComplexPolygon DontCare -star = ComplexPolygon [ - ComplexContour [ - AnnotatedVertex (Vertex3 250 50 0) 0, - AnnotatedVertex (Vertex3 325 200 0) 0, - AnnotatedVertex (Vertex3 400 50 0) 0, - AnnotatedVertex (Vertex3 250 150 0) 0, - AnnotatedVertex (Vertex3 400 150 0) 0 ] ] - -myInit :: IO [DisplayList] -myInit = do - clearColor $= Color4 0 0 0 0 - rectAndTriList <- compileNewList TessWindingOdd rectAndTri - starList <- compileNewList TessWindingPositive star - return [ rectAndTriList, starList ] - -compileNewList :: TessWinding -> ComplexPolygon DontCare -> IO DisplayList -compileNewList windingRule complexPolygon = - defineNewList Compile $ - drawTriangulation =<< - triangulate windingRule 0 (Normal3 0 0 0) noOpCombiner complexPolygon - -noOpCombiner :: Combiner DontCare -noOpCombiner _newVertex _weightedProperties = 0 - -drawTriangulation :: Triangulation DontCare -> IO () -drawTriangulation (Triangulation triangles) = - renderPrimitive Triangles $ - flip mapM_ triangles $ \(Triangle tv1 tv2 tv3) -> do - randomColor - drawTriangleVertex tv1 - drawTriangleVertex tv2 - drawTriangleVertex tv3 - --- CFloat has no Random instance, so we go via Float -randomGLfloat :: IO GLfloat -randomGLfloat = fmap (realToFrac :: Float -> GLfloat) randomIO - -randomColor :: IO () -randomColor = do - r <- randomGLfloat - g <- randomGLfloat - b <- randomGLfloat - color (Color3 r g b) - -drawTriangleVertex :: TriangleVertex DontCare -> IO () -drawTriangleVertex (AnnotatedVertex plainVertex (_, e)) = do - edgeFlag $= e - vertex plainVertex - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 (fromIntegral w) 0 (fromIntegral h) - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - _ <- createWindow progName - displayLists <- myInit - displayCallback $= display displayLists - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Triangulate.hs (adapted from tess.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates polygon triangulation. Two tesselated objects are + drawn. The first is a rectangle with a triangular hole. The second is a + smooth shaded, self-intersecting star. + + Note the exterior rectangle is drawn with its vertices in counter-clockwise + order, but its interior clockwise. Note the combineCallback is needed for the + self-intersecting star. Also note that removing the TessProperty for the + star will make the interior unshaded (TessWindingOdd). +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import System.Random ( randomIO ) +import Graphics.UI.GLUT + +display :: [DisplayList] -> DisplayCallback +display displayLists = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 1 1 1) + mapM_ callList displayLists + flush + +-- 'Float' is a dummy, any marshalable type would do +type DontCare = Float + +rectangle :: ComplexContour DontCare +rectangle = ComplexContour [ + AnnotatedVertex (Vertex3 50 50 0) 0, + AnnotatedVertex (Vertex3 200 50 0) 0, + AnnotatedVertex (Vertex3 200 200 0) 0, + AnnotatedVertex (Vertex3 50 200 0) 0 ] + +tri :: ComplexContour DontCare +tri = ComplexContour [ + AnnotatedVertex (Vertex3 75 75 0) 0, + AnnotatedVertex (Vertex3 125 175 0) 0, + AnnotatedVertex (Vertex3 175 75 0) 0 ] + +rectAndTri :: ComplexPolygon DontCare +rectAndTri = ComplexPolygon [ rectangle, tri ] + +star :: ComplexPolygon DontCare +star = ComplexPolygon [ + ComplexContour [ + AnnotatedVertex (Vertex3 250 50 0) 0, + AnnotatedVertex (Vertex3 325 200 0) 0, + AnnotatedVertex (Vertex3 400 50 0) 0, + AnnotatedVertex (Vertex3 250 150 0) 0, + AnnotatedVertex (Vertex3 400 150 0) 0 ] ] + +myInit :: IO [DisplayList] +myInit = do + clearColor $= Color4 0 0 0 0 + rectAndTriList <- compileNewList TessWindingOdd rectAndTri + starList <- compileNewList TessWindingPositive star + return [ rectAndTriList, starList ] + +compileNewList :: TessWinding -> ComplexPolygon DontCare -> IO DisplayList +compileNewList windingRule complexPolygon = + defineNewList Compile $ + drawTriangulation =<< + triangulate windingRule 0 (Normal3 0 0 0) noOpCombiner complexPolygon + +noOpCombiner :: Combiner DontCare +noOpCombiner _newVertex _weightedProperties = 0 + +drawTriangulation :: Triangulation DontCare -> IO () +drawTriangulation (Triangulation triangles) = + renderPrimitive Triangles $ + flip mapM_ triangles $ \(Triangle tv1 tv2 tv3) -> do + randomColor + drawTriangleVertex tv1 + drawTriangleVertex tv2 + drawTriangleVertex tv3 + +-- CFloat has no Random instance, so we go via Float +randomGLfloat :: IO GLfloat +randomGLfloat = fmap (realToFrac :: Float -> GLfloat) randomIO + +randomColor :: IO () +randomColor = do + r <- randomGLfloat + g <- randomGLfloat + b <- randomGLfloat + color (Color3 r g b) + +drawTriangleVertex :: TriangleVertex DontCare -> IO () +drawTriangleVertex (AnnotatedVertex plainVertex (_, e)) = do + edgeFlag $= e + vertex plainVertex + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + _ <- createWindow progName + displayLists <- myInit + displayCallback $= display displayLists + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/OrangeBook/00-README b/examples/OrangeBook/00-README new file mode 100644 --- /dev/null +++ b/examples/OrangeBook/00-README @@ -0,0 +1,2 @@ +This directory contains an example from the book "OpenGL Shading Language", 3rd +ed, by Rost/Licea-Kane/Ginsburg/Kessenich/Lichtenbelt/Malan/Weiblen. diff --git a/examples/OrangeBook/Makefile b/examples/OrangeBook/Makefile --- a/examples/OrangeBook/Makefile +++ b/examples/OrangeBook/Makefile @@ -1,2 +1,2 @@ -SUBDIRS := ogl2brick -include ../examples.mk +SUBDIRS := ogl2brick +include ../examples.mk diff --git a/examples/OrangeBook/ogl2brick/Brick.hs b/examples/OrangeBook/ogl2brick/Brick.hs --- a/examples/OrangeBook/ogl2brick/Brick.hs +++ b/examples/OrangeBook/ogl2brick/Brick.hs @@ -1,370 +1,370 @@ -{- - Brick.hs (adapted from ogl2brick.c which is (c) 3Dlabs Inc. Ltd.) - Copyright (c) Sven Panne 2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE --} - -import Prelude hiding ( sum ) -import Control.Applicative -import Control.Exception ( IOException, catch ) -import Control.Monad -import qualified Data.ByteString as B -import Data.Foldable ( Foldable, sum ) -import Data.IORef -import System.Exit -import Graphics.UI.GLUT - -infixl 6 $+, $- -infixl 7 $* - -inertiaThreshold, inertiaFactor :: GLfloat -inertiaThreshold = 1 -inertiaFactor = 0.5 - -scaleFactor, scaleIncrement :: GLfloat -scaleFactor = 0.01 -scaleIncrement = 0.5 - -timerFrequencyMillis :: Timeout -timerFrequencyMillis = 20 - -clearColors :: [Color4 GLclampf] -clearColors = [ - Color4 0.0 0.0 0.0 1, - Color4 0.2 0.2 0.3 1, - Color4 0.7 0.7 0.7 1 ] - -models :: [IO ()] -models = [ - drawCube, - renderObject Solid (Teapot 0.6), - renderObject Solid (Sphere' 0.6 64 64), - renderObject Solid (Torus 0.2 0.6 64 64) ] - -initialDiff :: Vector3 GLfloat -initialDiff = Vector3 206 16 10 - -initialInertia :: Vector3 GLfloat -initialInertia = Vector3 (-0.5) 0 0 - -data State = State { - diff :: IORef (Vector3 GLfloat), - lastIncr :: IORef (Vector3 GLfloat), - inertia :: IORef (Vector3 GLfloat), - inertiaOld :: IORef (Vector3 GLfloat), - theScale :: IORef GLfloat, - lastPosition :: IORef Position, - shouldRotate :: IORef Bool, - colorCycle :: IORef [Color4 GLclampf], - modelCycle :: IORef [IO ()], - modifiers :: IORef Modifiers - } - -makeState :: IO State -makeState = do - di <- newIORef initialDiff - li <- newIORef (pure 0) - ia <- newIORef initialInertia - io <- newIORef (pure 0) - sc <- newIORef 1 - lp <- newIORef (Position (-1) (-1)) - sr <- newIORef True - cc <- newIORef (cycle clearColors) - mc <- newIORef (cycle models) - mo <- newIORef (Modifiers Up Up Up) - return $ State { - diff = di, - lastIncr = li, - inertia = ia, - inertiaOld = io, - theScale = sc, - lastPosition = lp, - shouldRotate = sr, - colorCycle = cc, - modelCycle = mc, - modifiers = mo - } - --- Our tiny vector math library... -($+), ($-), ($*) :: (Applicative t, Num a) => t a -> t a -> t a -($+) = liftA2 (+) -($-) = liftA2 (-) -($*) = liftA2 (*) - -step :: (Applicative t, Num a, Ord a) => t a -> t a -> t a -step = liftA2 (\e x -> if x < e then 0 else 1) - -dot :: (Applicative t, Foldable t, Num a) => t a -> t a -> a -dot v1 v2 = sum (v1 $* v2) - -drawFace :: Normal3 GLfloat -> Vertex3 GLfloat -> Vertex3 GLfloat - -> Vertex3 GLfloat -> Vertex3 GLfloat -> IO () -drawFace p q r s t = do - let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () - normal p - texCoord2f (TexCoord2 1 1) - vertex q - texCoord2f (TexCoord2 0 1) - vertex r - texCoord2f (TexCoord2 0 0) - vertex s - texCoord2f (TexCoord2 1 0) - vertex t - -drawCube :: IO () -drawCube = do - let size = 1 - sc = 0.2 - delta = 0.1 - - a = Vertex3 size size ( size * sc + delta) - b = Vertex3 size size (-size * sc + delta) - c = Vertex3 size (-size) (-size * sc) - d = Vertex3 size (-size) ( size * sc) - e = Vertex3 (-size) size ( size * sc + delta) - f = Vertex3 (-size) size (-size * sc + delta) - g = Vertex3 (-size) (-size) (-size * sc) - h = Vertex3 (-size) (-size) ( size * sc) - - i = Normal3 1 0 0 - k = Normal3 (-1) 0 0 - l = Normal3 0 0 (-1) - m = Normal3 0 0 1 - n = Normal3 0 1 0 - o = Normal3 0 (-1) 0 - - renderPrimitive Quads $ do - drawFace i d c b a - drawFace k g h e f - drawFace l c g f b - drawFace m h d a e - drawFace n e a b f - drawFace o g c d h - -display :: State -> DisplayCallback -display state = do - loadIdentity - translate (Vector3 0 0 (-5 :: GLfloat)) - - Vector3 xDiff yDiff zDiff <- get (diff state) - rotate yDiff (Vector3 1 0 0) - rotate xDiff (Vector3 0 1 0) - rotate zDiff (Vector3 0 0 1) - - sc <- get (theScale state) - scale sc sc sc - - clear [ ColorBuffer, DepthBuffer ] - (drawModel:_) <- get (modelCycle state) - drawModel - - flush - swapBuffers - -nextClearColor :: State -> IO () -nextClearColor state = do - cc <- get (colorCycle state) - clearColor $= head cc - colorCycle state $~ tail - -toggleRotation :: State -> IO () -toggleRotation state = do - rot <- get (shouldRotate state) - shouldRotate state $~ not - if rot - then do - ia <- get (inertia state) - inertiaOld state $= ia - else do - io <- get (inertiaOld state) - inertia state $= io - -- To prevent confusion, force some rotation - when (dot io io == 0) $ - inertia state $= initialInertia - -printHelp :: IO () -printHelp = mapM_ putStrLn [ - "", - "Keyboard commands:", - "", - "b - Toggle among background clear colors", - "q, - Quit", - "t - Toggle among models to render", - "? - Help", - " - reset zoom and rotation", - " or - stop rotation", - "<+>, <-> or - zoom model", - " or - rotate model", - ""] - -resetState :: State -> IO () -resetState state = do - diff state $= initialDiff - lastIncr state $= pure 0 - inertia state $= initialInertia - theScale state $= 1 - -calcInertia :: State -> IO () -calcInertia state = do - lastPosition state $= Position (-1) (-1) - li <- get (lastIncr state) - ia <- get (inertia state) - let t = pure inertiaThreshold - f = pure inertiaFactor - l = (pure 1 $- (step (fmap negate t) li)) $* ((li $+ t) $* f $- ia) - r = (step t li) $* ((li $- t) $* f $- ia) - inertia state $= l $+ ia $+ r - lastIncr state $= pure 0 - -keyboard :: State -> KeyboardMouseCallback -keyboard state key keyState mods _ = do - modifiers state $= mods - postRedisplay Nothing - case (key, keyState) of - (Char 'b', Down) -> nextClearColor state - (Char 'q', Down) -> exitWith ExitSuccess - (Char '\27', Down) -> exitWith ExitSuccess - (Char 't', Down) -> modelCycle state $~ tail - (Char ' ', Down) -> toggleRotation state - (Char '+', Down) -> theScale state $~ (+ scaleIncrement) - (Char '-', Down) -> theScale state $~ (+ (- scaleIncrement)) - (Char _, Down) -> printHelp - (SpecialKey KeyHome, Down) -> resetState state - (SpecialKey KeyLeft, Down) -> diff state $~ ($- Vector3 1 0 0) - (SpecialKey KeyRight, Down) -> diff state $~ ($+ Vector3 1 0 0) - (SpecialKey KeyUp, Down) -> diff state $~ ($- Vector3 0 1 0) - (SpecialKey KeyDown, Down) -> diff state $~ ($+ Vector3 0 1 0) - (MouseButton LeftButton, Down) -> do - inertia state $= pure 0 - lastIncr state $= pure 0 - (MouseButton LeftButton, Up) -> calcInertia state - (_, _) -> return () - -motion :: State -> MotionCallback -motion state pos@(Position x y) = do - postRedisplay Nothing - Position xt yt <- get (lastPosition state) - lastPosition state $= pos - when (xt /= -1 || yt /= -1) $ do - let li@(Vector3 xl yl _) = Vector3 (fromIntegral (x - xt)) (fromIntegral (y - yt)) 0 - lastIncr state $= li - when (xt /= -1) $ do - mods <- get (modifiers state) - if ctrl mods == Down - then do diff state $~ ($+ Vector3 0 0 xl) - theScale state $~ (+ (yl * scaleFactor)) - else diff state $~ ($+ li) - -timer :: State -> TimerCallback -timer state = do - rot <- get (shouldRotate state) - when rot $ do - ia <- get (inertia state) - diff state $~ ($+ ia) - postRedisplay Nothing - addTimerCallback timerFrequencyMillis (timer state) - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - let vp = 0.8 - aspect = fromIntegral w / fromIntegral h - - viewport $= (Position 0 0, size) - - matrixMode $= Projection - loadIdentity - frustum (-vp) vp (-vp / aspect) (vp / aspect) 3 10 - - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-5 :: GLfloat)) - --- Make sure that GLSL is supported by the driver, either directly by the core --- or via an extension. -checkGLSLSupport :: IO () -checkGLSLSupport = do - version <- get (majorMinor glVersion) - unless (version >= (2,0)) $ do - extensions <- get glExtensions - unless ("GL_ARB_shading_language_100" `elem` extensions) $ - ioError (userError "No GLSL support found.") - -readAndCompileShader :: ShaderType -> FilePath -> IO Shader -readAndCompileShader st filePath = do - src <- B.readFile filePath - shader <- createShader st - shaderSourceBS shader $= src - compileShader shader - reportErrors - ok <- get (compileStatus shader) - infoLog <- get (shaderInfoLog shader) - mapM_ putStrLn ["Shader info log for '" ++ filePath ++ "':", infoLog, ""] - unless ok $ do - deleteObjectNames [shader] - ioError (userError "shader compilation failed") - return shader - -installBrickShaders :: [Shader] -> IO () -installBrickShaders shaders = do - brickProg <- createProgram - attachedShaders brickProg $= shaders - linkProgram brickProg - reportErrors - ok <- get (linkStatus brickProg) - infoLog <- get (programInfoLog brickProg) - mapM_ putStrLn ["Program info log:", infoLog, ""] - unless ok $ do - deleteObjectNames [brickProg] - ioError (userError "linking failed") - - currentProgram $= Just brickProg - - let setUniform var val = do - location <- get (uniformLocation brickProg var) - reportErrors - uniform location $= val - - setUniform "BrickColor" (Color3 1.0 0.3 (0.2 :: GLfloat)) - setUniform "MortarColor" (Color3 0.85 0.86 (0.84 :: GLfloat)) - setUniform "BrickSize" (Vertex2 0.30 (0.15 :: GLfloat)) - setUniform "BrickPct" (Vertex2 0.90 (0.85 :: GLfloat)) - setUniform "LightPosition" (Vertex3 0 0 (4 :: GLfloat)) - -main :: IO () -main = do - _ <- getArgsAndInitialize - initialDisplayMode $= [ RGBMode, WithDepthBuffer, DoubleBuffered ] - initialWindowSize $= Size 500 500 - _ <- createWindow "3Dlabs Brick Shader" - - -- Note: We don't use an idle callback, we redisplay more intelligently. - state <- makeState - displayCallback $= display state - keyboardMouseCallback $= Just (keyboard state) - reshapeCallback $= Just reshape - motionCallback $= Just (motion state) - addTimerCallback timerFrequencyMillis (timer state) - - Control.Exception.catch - (do checkGLSLSupport - vs <- readAndCompileShader VertexShader "Brick.vert" - fs <- readAndCompileShader FragmentShader "Brick.frag" - installBrickShaders [vs, fs]) - (\exception -> do - print (exception :: IOException) - putStrLn "Using fixed function pipeline." - materialDiffuse Front $= Color4 1 0.3 0.2 1 - materialSpecular Front $= Color4 0.3 0.3 0.3 1 - materialShininess Front $= 16 - position (Light 0) $= Vertex4 0 0 4 0 - lighting $= Enabled - light (Light 0) $= Enabled) - - depthFunc $= Just Less - nextClearColor state - - -- display help - keyboard state (Char '?') Down (Modifiers Up Up Up) (Position 0 0) - - mainLoop +{- + Brick.hs (adapted from ogl2brick.c which is (c) 3Dlabs Inc. Ltd.) + Copyright (c) Sven Panne 2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Prelude hiding ( sum ) +import Control.Applicative +import Control.Exception ( IOException, catch ) +import Control.Monad +import qualified Data.ByteString as B +import Data.Foldable ( Foldable, sum ) +import Data.IORef +import System.Exit +import Graphics.UI.GLUT + +infixl 6 $+, $- +infixl 7 $* + +inertiaThreshold, inertiaFactor :: GLfloat +inertiaThreshold = 1 +inertiaFactor = 0.5 + +scaleFactor, scaleIncrement :: GLfloat +scaleFactor = 0.01 +scaleIncrement = 0.5 + +timerFrequencyMillis :: Timeout +timerFrequencyMillis = 20 + +clearColors :: [Color4 GLclampf] +clearColors = [ + Color4 0.0 0.0 0.0 1, + Color4 0.2 0.2 0.3 1, + Color4 0.7 0.7 0.7 1 ] + +models :: [IO ()] +models = [ + drawCube, + renderObject Solid (Teapot 0.6), + renderObject Solid (Sphere' 0.6 64 64), + renderObject Solid (Torus 0.2 0.6 64 64) ] + +initialDiff :: Vector3 GLfloat +initialDiff = Vector3 206 16 10 + +initialInertia :: Vector3 GLfloat +initialInertia = Vector3 (-0.5) 0 0 + +data State = State { + diff :: IORef (Vector3 GLfloat), + lastIncr :: IORef (Vector3 GLfloat), + inertia :: IORef (Vector3 GLfloat), + inertiaOld :: IORef (Vector3 GLfloat), + theScale :: IORef GLfloat, + lastPosition :: IORef Position, + shouldRotate :: IORef Bool, + colorCycle :: IORef [Color4 GLclampf], + modelCycle :: IORef [IO ()], + modifiers :: IORef Modifiers + } + +makeState :: IO State +makeState = do + di <- newIORef initialDiff + li <- newIORef (pure 0) + ia <- newIORef initialInertia + io <- newIORef (pure 0) + sc <- newIORef 1 + lp <- newIORef (Position (-1) (-1)) + sr <- newIORef True + cc <- newIORef (cycle clearColors) + mc <- newIORef (cycle models) + mo <- newIORef (Modifiers Up Up Up) + return $ State { + diff = di, + lastIncr = li, + inertia = ia, + inertiaOld = io, + theScale = sc, + lastPosition = lp, + shouldRotate = sr, + colorCycle = cc, + modelCycle = mc, + modifiers = mo + } + +-- Our tiny vector math library... +($+), ($-), ($*) :: (Applicative t, Num a) => t a -> t a -> t a +($+) = liftA2 (+) +($-) = liftA2 (-) +($*) = liftA2 (*) + +step :: (Applicative t, Num a, Ord a) => t a -> t a -> t a +step = liftA2 (\e x -> if x < e then 0 else 1) + +dot :: (Applicative t, Foldable t, Num a) => t a -> t a -> a +dot v1 v2 = sum (v1 $* v2) + +drawFace :: Normal3 GLfloat -> Vertex3 GLfloat -> Vertex3 GLfloat + -> Vertex3 GLfloat -> Vertex3 GLfloat -> IO () +drawFace p q r s t = do + let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () + normal p + texCoord2f (TexCoord2 1 1) + vertex q + texCoord2f (TexCoord2 0 1) + vertex r + texCoord2f (TexCoord2 0 0) + vertex s + texCoord2f (TexCoord2 1 0) + vertex t + +drawCube :: IO () +drawCube = do + let size = 1 + sc = 0.2 + delta = 0.1 + + a = Vertex3 size size ( size * sc + delta) + b = Vertex3 size size (-size * sc + delta) + c = Vertex3 size (-size) (-size * sc) + d = Vertex3 size (-size) ( size * sc) + e = Vertex3 (-size) size ( size * sc + delta) + f = Vertex3 (-size) size (-size * sc + delta) + g = Vertex3 (-size) (-size) (-size * sc) + h = Vertex3 (-size) (-size) ( size * sc) + + i = Normal3 1 0 0 + k = Normal3 (-1) 0 0 + l = Normal3 0 0 (-1) + m = Normal3 0 0 1 + n = Normal3 0 1 0 + o = Normal3 0 (-1) 0 + + renderPrimitive Quads $ do + drawFace i d c b a + drawFace k g h e f + drawFace l c g f b + drawFace m h d a e + drawFace n e a b f + drawFace o g c d h + +display :: State -> DisplayCallback +display state = do + loadIdentity + translate (Vector3 0 0 (-5 :: GLfloat)) + + Vector3 xDiff yDiff zDiff <- get (diff state) + rotate yDiff (Vector3 1 0 0) + rotate xDiff (Vector3 0 1 0) + rotate zDiff (Vector3 0 0 1) + + sc <- get (theScale state) + scale sc sc sc + + clear [ ColorBuffer, DepthBuffer ] + (drawModel:_) <- get (modelCycle state) + drawModel + + flush + swapBuffers + +nextClearColor :: State -> IO () +nextClearColor state = do + cc <- get (colorCycle state) + clearColor $= head cc + colorCycle state $~ tail + +toggleRotation :: State -> IO () +toggleRotation state = do + rot <- get (shouldRotate state) + shouldRotate state $~ not + if rot + then do + ia <- get (inertia state) + inertiaOld state $= ia + else do + io <- get (inertiaOld state) + inertia state $= io + -- To prevent confusion, force some rotation + when (dot io io == 0) $ + inertia state $= initialInertia + +printHelp :: IO () +printHelp = mapM_ putStrLn [ + "", + "Keyboard commands:", + "", + "b - Toggle among background clear colors", + "q, - Quit", + "t - Toggle among models to render", + "? - Help", + " - reset zoom and rotation", + " or - stop rotation", + "<+>, <-> or - zoom model", + " or - rotate model", + ""] + +resetState :: State -> IO () +resetState state = do + diff state $= initialDiff + lastIncr state $= pure 0 + inertia state $= initialInertia + theScale state $= 1 + +calcInertia :: State -> IO () +calcInertia state = do + lastPosition state $= Position (-1) (-1) + li <- get (lastIncr state) + ia <- get (inertia state) + let t = pure inertiaThreshold + f = pure inertiaFactor + l = (pure 1 $- (step (fmap negate t) li)) $* ((li $+ t) $* f $- ia) + r = (step t li) $* ((li $- t) $* f $- ia) + inertia state $= l $+ ia $+ r + lastIncr state $= pure 0 + +keyboard :: State -> KeyboardMouseCallback +keyboard state key keyState mods _ = do + modifiers state $= mods + postRedisplay Nothing + case (key, keyState) of + (Char 'b', Down) -> nextClearColor state + (Char 'q', Down) -> exitWith ExitSuccess + (Char '\27', Down) -> exitWith ExitSuccess + (Char 't', Down) -> modelCycle state $~ tail + (Char ' ', Down) -> toggleRotation state + (Char '+', Down) -> theScale state $~ (+ scaleIncrement) + (Char '-', Down) -> theScale state $~ (+ (- scaleIncrement)) + (Char _, Down) -> printHelp + (SpecialKey KeyHome, Down) -> resetState state + (SpecialKey KeyLeft, Down) -> diff state $~ ($- Vector3 1 0 0) + (SpecialKey KeyRight, Down) -> diff state $~ ($+ Vector3 1 0 0) + (SpecialKey KeyUp, Down) -> diff state $~ ($- Vector3 0 1 0) + (SpecialKey KeyDown, Down) -> diff state $~ ($+ Vector3 0 1 0) + (MouseButton LeftButton, Down) -> do + inertia state $= pure 0 + lastIncr state $= pure 0 + (MouseButton LeftButton, Up) -> calcInertia state + (_, _) -> return () + +motion :: State -> MotionCallback +motion state pos@(Position x y) = do + postRedisplay Nothing + Position xt yt <- get (lastPosition state) + lastPosition state $= pos + when (xt /= -1 || yt /= -1) $ do + let li@(Vector3 xl yl _) = Vector3 (fromIntegral (x - xt)) (fromIntegral (y - yt)) 0 + lastIncr state $= li + when (xt /= -1) $ do + mods <- get (modifiers state) + if ctrl mods == Down + then do diff state $~ ($+ Vector3 0 0 xl) + theScale state $~ (+ (yl * scaleFactor)) + else diff state $~ ($+ li) + +timer :: State -> TimerCallback +timer state = do + rot <- get (shouldRotate state) + when rot $ do + ia <- get (inertia state) + diff state $~ ($+ ia) + postRedisplay Nothing + addTimerCallback timerFrequencyMillis (timer state) + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + let vp = 0.8 + aspect = fromIntegral w / fromIntegral h + + viewport $= (Position 0 0, size) + + matrixMode $= Projection + loadIdentity + frustum (-vp) vp (-vp / aspect) (vp / aspect) 3 10 + + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-5 :: GLfloat)) + +-- Make sure that GLSL is supported by the driver, either directly by the core +-- or via an extension. +checkGLSLSupport :: IO () +checkGLSLSupport = do + version <- get (majorMinor glVersion) + unless (version >= (2,0)) $ do + extensions <- get glExtensions + unless ("GL_ARB_shading_language_100" `elem` extensions) $ + ioError (userError "No GLSL support found.") + +readAndCompileShader :: ShaderType -> FilePath -> IO Shader +readAndCompileShader st filePath = do + src <- B.readFile filePath + shader <- createShader st + shaderSourceBS shader $= src + compileShader shader + reportErrors + ok <- get (compileStatus shader) + infoLog <- get (shaderInfoLog shader) + mapM_ putStrLn ["Shader info log for '" ++ filePath ++ "':", infoLog, ""] + unless ok $ do + deleteObjectNames [shader] + ioError (userError "shader compilation failed") + return shader + +installBrickShaders :: [Shader] -> IO () +installBrickShaders shaders = do + brickProg <- createProgram + attachedShaders brickProg $= shaders + linkProgram brickProg + reportErrors + ok <- get (linkStatus brickProg) + infoLog <- get (programInfoLog brickProg) + mapM_ putStrLn ["Program info log:", infoLog, ""] + unless ok $ do + deleteObjectNames [brickProg] + ioError (userError "linking failed") + + currentProgram $= Just brickProg + + let setUniform var val = do + location <- get (uniformLocation brickProg var) + reportErrors + uniform location $= val + + setUniform "BrickColor" (Color3 1.0 0.3 (0.2 :: GLfloat)) + setUniform "MortarColor" (Color3 0.85 0.86 (0.84 :: GLfloat)) + setUniform "BrickSize" (Vertex2 0.30 (0.15 :: GLfloat)) + setUniform "BrickPct" (Vertex2 0.90 (0.85 :: GLfloat)) + setUniform "LightPosition" (Vertex3 0 0 (4 :: GLfloat)) + +main :: IO () +main = do + _ <- getArgsAndInitialize + initialDisplayMode $= [ RGBMode, WithDepthBuffer, DoubleBuffered ] + initialWindowSize $= Size 500 500 + _ <- createWindow "3Dlabs Brick Shader" + + -- Note: We don't use an idle callback, we redisplay more intelligently. + state <- makeState + displayCallback $= display state + keyboardMouseCallback $= Just (keyboard state) + reshapeCallback $= Just reshape + motionCallback $= Just (motion state) + addTimerCallback timerFrequencyMillis (timer state) + + Control.Exception.catch + (do checkGLSLSupport + vs <- readAndCompileShader VertexShader "Brick.vert" + fs <- readAndCompileShader FragmentShader "Brick.frag" + installBrickShaders [vs, fs]) + (\exception -> do + print (exception :: IOException) + putStrLn "Using fixed function pipeline." + materialDiffuse Front $= Color4 1 0.3 0.2 1 + materialSpecular Front $= Color4 0.3 0.3 0.3 1 + materialShininess Front $= 16 + position (Light 0) $= Vertex4 0 0 4 0 + lighting $= Enabled + light (Light 0) $= Enabled) + + depthFunc $= Just Less + nextClearColor state + + -- display help + keyboard state (Char '?') Down (Modifiers Up Up Up) (Position 0 0) + + mainLoop diff --git a/examples/OrangeBook/ogl2brick/Makefile b/examples/OrangeBook/ogl2brick/Makefile --- a/examples/OrangeBook/ogl2brick/Makefile +++ b/examples/OrangeBook/ogl2brick/Makefile @@ -1,1 +1,1 @@ -include ../../examples.mk +include ../../examples.mk diff --git a/examples/RedBook4/AAIndex.hs b/examples/RedBook4/AAIndex.hs --- a/examples/RedBook4/AAIndex.hs +++ b/examples/RedBook4/AAIndex.hs @@ -1,104 +1,104 @@ -{- - AAIndex.hs (adapted from aaindex.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws shows how to draw anti-aliased lines in color index - mode. It draws two diagonal lines to form an X; when 'r' is typed in the - window, the lines are rotated in opposite directions. --} - -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { rotAngle :: IORef Int } - -makeState :: IO State -makeState = do - r <- newIORef 0 - return $ State { rotAngle = r } - -rampSize, ramp1Start, ramp2Start :: GLint -rampSize = 16 -ramp1Start = 32 -ramp2Start = 48 - --- Initialize antialiasing for color index mode, including loading a green color --- ramp starting at ramp1Start, and a blue color ramp starting at ramp2Start. --- The ramps must be a multiple of 16. -myInit :: IO () -myInit = do - flip mapM_ [ 0 .. rampSize - 1 ] $ \i -> do - let shade = fromIntegral i / fromIntegral rampSize - colorMapEntry (Index1 (ramp1Start + i)) $= Color3 0 shade 0 - colorMapEntry (Index1 (ramp2Start + i)) $= Color3 0 0 shade - - lineSmooth $= Enabled - hint LineSmooth $= DontCare - lineWidth $= 1.5 - - clearIndex $= Index1 (fromIntegral ramp1Start) - --- Draw 2 diagonal lines to form an X -display :: State -> DisplayCallback -display state = do - r <- get (rotAngle state) - clear [ ColorBuffer ] - - -- resolve overloading, not needed in "real" programs - let vertex2f = vertex :: Vertex2 GLfloat -> IO () - - index (Index1 ramp1Start) - preservingMatrix $ do - rotate (-(fromIntegral r :: GLfloat)) (Vector3 0 0 0.1) - renderPrimitive Lines $ do - vertex2f (Vertex2 (-0.5) 0.5) - vertex2f (Vertex2 0.5 (-0.5)) - - index (Index1 ramp2Start) - preservingMatrix $ do - rotate (fromIntegral r :: GLfloat) (Vector3 0 0 0.1) - renderPrimitive Lines $ do - vertex2f (Vertex2 0.5 0.5) - vertex2f (Vertex2 (-0.5) (-0.5)) - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho2D (-1) 1 (-1*hf/wf) (1*hf/wf) - else ortho2D (-1*wf/hf) (1*wf/hf) (-1) 1 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case toLower c of - 'r' -> do rotAngle state $~ ((`mod` 360) . (+ 30)); postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ = return () - --- Main Loop --- Open window with initial window size, title bar, --- color index display mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, IndexMode ] - initialWindowSize $= Size 200 200 - _ <- createWindow progName - state <- makeState - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - displayCallback $= display state - mainLoop +{- + AAIndex.hs (adapted from aaindex.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws shows how to draw anti-aliased lines in color index + mode. It draws two diagonal lines to form an X; when 'r' is typed in the + window, the lines are rotated in opposite directions. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { rotAngle :: IORef Int } + +makeState :: IO State +makeState = do + r <- newIORef 0 + return $ State { rotAngle = r } + +rampSize, ramp1Start, ramp2Start :: GLint +rampSize = 16 +ramp1Start = 32 +ramp2Start = 48 + +-- Initialize antialiasing for color index mode, including loading a green color +-- ramp starting at ramp1Start, and a blue color ramp starting at ramp2Start. +-- The ramps must be a multiple of 16. +myInit :: IO () +myInit = do + flip mapM_ [ 0 .. rampSize - 1 ] $ \i -> do + let shade = fromIntegral i / fromIntegral rampSize + colorMapEntry (Index1 (ramp1Start + i)) $= Color3 0 shade 0 + colorMapEntry (Index1 (ramp2Start + i)) $= Color3 0 0 shade + + lineSmooth $= Enabled + hint LineSmooth $= DontCare + lineWidth $= 1.5 + + clearIndex $= Index1 (fromIntegral ramp1Start) + +-- Draw 2 diagonal lines to form an X +display :: State -> DisplayCallback +display state = do + r <- get (rotAngle state) + clear [ ColorBuffer ] + + -- resolve overloading, not needed in "real" programs + let vertex2f = vertex :: Vertex2 GLfloat -> IO () + + index (Index1 ramp1Start) + preservingMatrix $ do + rotate (-(fromIntegral r :: GLfloat)) (Vector3 0 0 0.1) + renderPrimitive Lines $ do + vertex2f (Vertex2 (-0.5) 0.5) + vertex2f (Vertex2 0.5 (-0.5)) + + index (Index1 ramp2Start) + preservingMatrix $ do + rotate (fromIntegral r :: GLfloat) (Vector3 0 0 0.1) + renderPrimitive Lines $ do + vertex2f (Vertex2 0.5 0.5) + vertex2f (Vertex2 (-0.5) (-0.5)) + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D (-1) 1 (-1*hf/wf) (1*hf/wf) + else ortho2D (-1*wf/hf) (1*wf/hf) (-1) 1 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'r' -> do rotAngle state $~ ((`mod` 360) . (+ 30)); postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +-- Main Loop +-- Open window with initial window size, title bar, +-- color index display mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, IndexMode ] + initialWindowSize $= Size 200 200 + _ <- createWindow progName + state <- makeState + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state + mainLoop diff --git a/examples/RedBook4/AARGB.hs b/examples/RedBook4/AARGB.hs --- a/examples/RedBook4/AARGB.hs +++ b/examples/RedBook4/AARGB.hs @@ -1,104 +1,104 @@ -{- - AARGB.hs (adapted from aargb.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws shows how to draw anti-aliased lines. It draws two - diagonal lines to form an X; when 'r' is typed in the window, the lines are - rotated in opposite directions. --} - -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { rotAngle :: IORef Int } - -makeState :: IO State -makeState = do - r <- newIORef 0 - return $ State { rotAngle = r } - --- Initialize antialiasing for RGBA mode, including alpha blending, hint, and --- line width. Print out implementation specific info on line width granularity --- and width. -myInit :: IO () -myInit = do - g <- get smoothLineWidthGranularity - putStrLn ("smoothLineWidthGranularity is " ++ show g) - - r <- get smoothLineWidthRange - putStrLn ("smoothLineWidthRange is " ++ show r) - - lineSmooth $= Enabled - - blend $= Enabled - blendFunc $= (SrcAlpha, OneMinusSrcAlpha) - hint LineSmooth $= DontCare - lineWidth $= 1.5 - - clearColor $= Color4 0 0 0 0 - --- Draw 2 diagonal lines to form an X -display :: State -> DisplayCallback -display state = do - r <- get (rotAngle state) - clear [ ColorBuffer ] - - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - vertex2f = vertex :: Vertex2 GLfloat -> IO () - - color3f (Color3 0 1 0) - preservingMatrix $ do - rotate (-(fromIntegral r :: GLfloat)) (Vector3 0 0 0.1) - renderPrimitive Lines $ do - vertex2f (Vertex2 (-0.5) 0.5) - vertex2f (Vertex2 0.5 (-0.5)) - - color3f (Color3 0 0 1) - preservingMatrix $ do - rotate (fromIntegral r :: GLfloat) (Vector3 0 0 0.1) - renderPrimitive Lines $ do - vertex2f (Vertex2 0.5 0.5) - vertex2f (Vertex2 (-0.5) (-0.5)) - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho2D (-1) 1 (-1*hf/wf) (1*hf/wf) - else ortho2D (-1*wf/hf) (1*wf/hf) (-1) 1 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case toLower c of - 'r' -> do rotAngle state $~ ((`mod` 360) . (+ 30)); postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ = return () - --- Main Loop --- Open window with initial window size, title bar, --- RGBA display mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 200 200 - _ <- createWindow progName - state <- makeState - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - displayCallback $= display state - mainLoop +{- + AARGB.hs (adapted from aargb.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws shows how to draw anti-aliased lines. It draws two + diagonal lines to form an X; when 'r' is typed in the window, the lines are + rotated in opposite directions. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { rotAngle :: IORef Int } + +makeState :: IO State +makeState = do + r <- newIORef 0 + return $ State { rotAngle = r } + +-- Initialize antialiasing for RGBA mode, including alpha blending, hint, and +-- line width. Print out implementation specific info on line width granularity +-- and width. +myInit :: IO () +myInit = do + g <- get smoothLineWidthGranularity + putStrLn ("smoothLineWidthGranularity is " ++ show g) + + r <- get smoothLineWidthRange + putStrLn ("smoothLineWidthRange is " ++ show r) + + lineSmooth $= Enabled + + blend $= Enabled + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + hint LineSmooth $= DontCare + lineWidth $= 1.5 + + clearColor $= Color4 0 0 0 0 + +-- Draw 2 diagonal lines to form an X +display :: State -> DisplayCallback +display state = do + r <- get (rotAngle state) + clear [ ColorBuffer ] + + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + vertex2f = vertex :: Vertex2 GLfloat -> IO () + + color3f (Color3 0 1 0) + preservingMatrix $ do + rotate (-(fromIntegral r :: GLfloat)) (Vector3 0 0 0.1) + renderPrimitive Lines $ do + vertex2f (Vertex2 (-0.5) 0.5) + vertex2f (Vertex2 0.5 (-0.5)) + + color3f (Color3 0 0 1) + preservingMatrix $ do + rotate (fromIntegral r :: GLfloat) (Vector3 0 0 0.1) + renderPrimitive Lines $ do + vertex2f (Vertex2 0.5 0.5) + vertex2f (Vertex2 (-0.5) (-0.5)) + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D (-1) 1 (-1*hf/wf) (1*hf/wf) + else ortho2D (-1*wf/hf) (1*wf/hf) (-1) 1 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'r' -> do rotAngle state $~ ((`mod` 360) . (+ 30)); postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +-- Main Loop +-- Open window with initial window size, title bar, +-- RGBA display mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 200 200 + _ <- createWindow progName + state <- makeState + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state + mainLoop diff --git a/examples/RedBook4/AccAnti.hs b/examples/RedBook4/AccAnti.hs --- a/examples/RedBook4/AccAnti.hs +++ b/examples/RedBook4/AccAnti.hs @@ -1,132 +1,132 @@ -{- - AccAnti.hs (adapted from accanti.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Use the accumulation buffer to do full-scene antialiasing on a scene with - orthographic parallel projection. --} - -import Data.List ( genericLength ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a --- gaussian distribution around the origin. Use these to do model jittering for --- scene anti-aliasing and view volume jittering for depth of field effects. Use --- in conjunction with the accwindow routine. -j8 :: [Vector2 GLdouble] -j8 = [ - Vector2 (-0.334818) 0.435331 , - Vector2 0.286438 (-0.393495), - Vector2 0.459462 0.141540 , - Vector2 (-0.414498) (-0.192829), - Vector2 (-0.183790) 0.082102 , - Vector2 (-0.079263) (-0.317383), - Vector2 0.102254 0.299133 , - Vector2 0.164216 (-0.054399) ] - --- Initialize lighting and other values. -myInit :: IO () -myInit = do - materialAmbient Front $= Color4 1 1 1 1 - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 50 - position (Light 0) $= Vertex4 0 0 10 1 - lightModelAmbient $= Color4 0.2 0.2 0.2 1 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - shadeModel $= Flat - - clearColor $= Color4 0 0 0 0 - clearAccum $= Color4 0 0 0 0 - -displayObjects :: IO () -displayObjects = do - -- resolve overloading, not needed in "real" programs - let translatef = translate :: Vector3 GLfloat -> IO () - rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () - - preservingMatrix $ do - rotatef 30 (Vector3 1 0 0) - - preservingMatrix $ do - translatef (Vector3 (-0.80) 0.35 0) - rotatef 100 (Vector3 1 0 0) - materialDiffuse Front $= Color4 0.7 0.7 0 1 - renderObject Solid (Torus 0.275 0.85 16 16) - - preservingMatrix $ do - translatef (Vector3 (-0.75) (-0.50) 0) - rotatef 45 (Vector3 0 0 1) - rotatef 45 (Vector3 1 0 0) - materialDiffuse Front $= Color4 0 0.7 0.7 1 - renderObject Solid (Cube 1.5) - - preservingMatrix $ do - translatef (Vector3 0.75 0.60 0) - rotatef 30 (Vector3 1 0 0) - materialDiffuse Front $= Color4 0.7 0 0.7 1 - renderObject Solid (Sphere' 1 16 16) - - preservingMatrix $ do - translatef (Vector3 0.70 (-0.90) 0.25) - materialDiffuse Front $= Color4 0.7 0.4 0.4 1 - renderObject Solid Octahedron - --- display draws 5 teapots into the accumulation buffer several times; each time --- with a jittered perspective. The focal point is at z = 5.0, so the gold --- teapot will stay in focus. The amount of jitter is adjusted by the magnitude --- of the accPerspective jitter; in this example, 0.33. In this example, the --- teapots are drawn 8 times. -display :: DisplayCallback -display = do - (_, Size w h) <- get viewport - clear [ AccumBuffer ] - - flip mapM_ j8 $ \(Vector2 x y) -> do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - -- Note that 4.5 is the distance in world space between left and right - -- and bottom and top. This formula converts fractional pixel movement - -- to world coordinates. - translate (Vector3 (x*4.5/fromIntegral w) (y*4.5/fromIntegral h) 0) - displayObjects - accum Accum (recip (genericLength j8)) - - accum Return 1 - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-2.25) 2.25 (-2.25*hf/wf) (2.25*hf/wf) (-10) 10 - else ortho (-2.25*wf/hf) (2.25*wf/hf) (-2.25) 2.25 (-10) 10 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Be certain to request an accumulation buffer. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop +{- + AccAnti.hs (adapted from accanti.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Use the accumulation buffer to do full-scene antialiasing on a scene with + orthographic parallel projection. +-} + +import Data.List ( genericLength ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a +-- gaussian distribution around the origin. Use these to do model jittering for +-- scene anti-aliasing and view volume jittering for depth of field effects. Use +-- in conjunction with the accwindow routine. +j8 :: [Vector2 GLdouble] +j8 = [ + Vector2 (-0.334818) 0.435331 , + Vector2 0.286438 (-0.393495), + Vector2 0.459462 0.141540 , + Vector2 (-0.414498) (-0.192829), + Vector2 (-0.183790) 0.082102 , + Vector2 (-0.079263) (-0.317383), + Vector2 0.102254 0.299133 , + Vector2 0.164216 (-0.054399) ] + +-- Initialize lighting and other values. +myInit :: IO () +myInit = do + materialAmbient Front $= Color4 1 1 1 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 50 + position (Light 0) $= Vertex4 0 0 10 1 + lightModelAmbient $= Color4 0.2 0.2 0.2 1 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + shadeModel $= Flat + + clearColor $= Color4 0 0 0 0 + clearAccum $= Color4 0 0 0 0 + +displayObjects :: IO () +displayObjects = do + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + + preservingMatrix $ do + rotatef 30 (Vector3 1 0 0) + + preservingMatrix $ do + translatef (Vector3 (-0.80) 0.35 0) + rotatef 100 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0.7 0.7 0 1 + renderObject Solid (Torus 0.275 0.85 16 16) + + preservingMatrix $ do + translatef (Vector3 (-0.75) (-0.50) 0) + rotatef 45 (Vector3 0 0 1) + rotatef 45 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0 0.7 0.7 1 + renderObject Solid (Cube 1.5) + + preservingMatrix $ do + translatef (Vector3 0.75 0.60 0) + rotatef 30 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0.7 0 0.7 1 + renderObject Solid (Sphere' 1 16 16) + + preservingMatrix $ do + translatef (Vector3 0.70 (-0.90) 0.25) + materialDiffuse Front $= Color4 0.7 0.4 0.4 1 + renderObject Solid Octahedron + +-- display draws 5 teapots into the accumulation buffer several times; each time +-- with a jittered perspective. The focal point is at z = 5.0, so the gold +-- teapot will stay in focus. The amount of jitter is adjusted by the magnitude +-- of the accPerspective jitter; in this example, 0.33. In this example, the +-- teapots are drawn 8 times. +display :: DisplayCallback +display = do + (_, Size w h) <- get viewport + clear [ AccumBuffer ] + + flip mapM_ j8 $ \(Vector2 x y) -> do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + -- Note that 4.5 is the distance in world space between left and right + -- and bottom and top. This formula converts fractional pixel movement + -- to world coordinates. + translate (Vector3 (x*4.5/fromIntegral w) (y*4.5/fromIntegral h) 0) + displayObjects + accum Accum (recip (genericLength j8)) + + accum Return 1 + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-2.25) 2.25 (-2.25*hf/wf) (2.25*hf/wf) (-10) 10 + else ortho (-2.25*wf/hf) (2.25*wf/hf) (-2.25) 2.25 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Be certain to request an accumulation buffer. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/AccPersp.hs b/examples/RedBook4/AccPersp.hs --- a/examples/RedBook4/AccPersp.hs +++ b/examples/RedBook4/AccPersp.hs @@ -1,166 +1,166 @@ -{- - AccPersp.hs (adapted from accpersp.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Use the accumulation buffer to do full-scene antialiasing on a scene with - perspective projection, using the special routines accFrustum and - accPerspective. --} - -import Data.List ( genericLength ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a --- gaussian distribution around the origin. Use these to do model jittering for --- scene anti-aliasing and view volume jittering for depth of field effects. Use --- in conjunction with the accwindow routine. -j8 :: [Vector2 GLdouble] -j8 = [ - Vector2 (-0.334818) 0.435331 , - Vector2 0.286438 (-0.393495), - Vector2 0.459462 0.141540 , - Vector2 (-0.414498) (-0.192829), - Vector2 (-0.183790) 0.082102 , - Vector2 (-0.079263) (-0.317383), - Vector2 0.102254 0.299133 , - Vector2 0.164216 (-0.054399) ] - --- The first 6 arguments are identical to the frustum call. pixD is anti-alias --- jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD is --- depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field --- effects. focus is distance from eye to plane in focus. focus must be greater --- than, but not equal to 0. Note that accFrustum calls translate. You will --- probably want to insure that your ModelView matrix has been initialized to --- identity before calling accFrustum. -accFrustum :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble - -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () -accFrustum left right bottom top zNear zFar - (Vector2 pixDx pixDy) (Vector2 eyeDx eyeDy) focus = do - (_, Size w h) <- get viewport - - let xWSize = right - left; - yWSize = top - bottom; - - dx = -(pixDx * xWSize / fromIntegral w + eyeDx * zNear / focus) - dy = -(pixDy * yWSize / fromIntegral h + eyeDy * zNear / focus) - - matrixMode $= Projection - loadIdentity - frustum (left + dx) (right + dx) (bottom + dy) (top + dy) zNear zFar - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 (-eyeDx) (-eyeDy) 0) - --- The first 4 arguments are identical to the perspective call. pixD is --- anti-alias jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD --- is depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field --- effects. focus is distance from eye to plane in focus. focus must be greater --- than, but not equal to 0. Note that accPerspective calls accFrustum. -accPerspective :: GLdouble -> GLdouble -> GLdouble -> GLdouble - -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () -accPerspective fovY aspect zNear zFar pixD eyeD focus = do - let fov2 = ((fovY * pi) / 180) / 2 - - top = zNear / (cos fov2 / sin fov2) - bottom = -top - - right = top * aspect - left = -right - - accFrustum left right bottom top zNear zFar pixD eyeD focus - --- Initialize lighting and other values. -myInit :: IO () -myInit = do - materialAmbient Front $= Color4 1 1 1 1 - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 50 - position (Light 0) $= Vertex4 0 0 10 1 - lightModelAmbient $= Color4 0.2 0.2 0.2 1 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - shadeModel $= Flat - - clearColor $= Color4 0 0 0 0 - clearAccum $= Color4 0 0 0 0 - -displayObjects :: IO () -displayObjects = do - -- resolve overloading, not needed in "real" programs - let translatef = translate :: Vector3 GLfloat -> IO () - rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () - - preservingMatrix $ do - translatef (Vector3 0 0 (-5)) - rotatef 30 (Vector3 1 0 0) - - preservingMatrix $ do - translatef (Vector3 (-0.80) 0.35 0) - rotatef 100 (Vector3 1 0 0) - materialDiffuse Front $= Color4 0.7 0.7 0 1 - renderObject Solid (Torus 0.275 0.85 16 16) - - preservingMatrix $ do - translatef (Vector3 (-0.75) (-0.50) 0) - rotatef 45 (Vector3 0 0 1) - rotatef 45 (Vector3 1 0 0) - materialDiffuse Front $= Color4 0 0.7 0.7 1 - renderObject Solid (Cube 1.5) - - preservingMatrix $ do - translatef (Vector3 0.75 0.60 0) - rotatef 30 (Vector3 1 0 0) - materialDiffuse Front $= Color4 0.7 0 0.7 1 - renderObject Solid (Sphere' 1 16 16) - - preservingMatrix $ do - translatef (Vector3 0.70 (-0.90) 0.25) - materialDiffuse Front $= Color4 0.7 0.4 0.4 1 - renderObject Solid Octahedron - --- display draws 5 teapots into the accumulation buffer several times; each time --- with a jittered perspective. The focal point is at z = 5.0, so the gold --- teapot will stay in focus. The amount of jitter is adjusted by the magnitude --- of the accPerspective jitter; in this example, 0.33. In this example, the --- teapots are drawn 8 times. -display :: DisplayCallback -display = do - (_, Size w h) <- get viewport - clear [ AccumBuffer ] - - flip mapM_ j8 $ \(Vector2 x y) -> do - clear [ ColorBuffer, DepthBuffer ] - accPerspective 50 (fromIntegral w / fromIntegral h) 1 15 - (Vector2 x y) (Vector2 0 0) 1 - displayObjects - accum Accum (recip (genericLength j8)) - - accum Return 1 - flush - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Be certain you request an accumulation buffer. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop +{- + AccPersp.hs (adapted from accpersp.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Use the accumulation buffer to do full-scene antialiasing on a scene with + perspective projection, using the special routines accFrustum and + accPerspective. +-} + +import Data.List ( genericLength ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a +-- gaussian distribution around the origin. Use these to do model jittering for +-- scene anti-aliasing and view volume jittering for depth of field effects. Use +-- in conjunction with the accwindow routine. +j8 :: [Vector2 GLdouble] +j8 = [ + Vector2 (-0.334818) 0.435331 , + Vector2 0.286438 (-0.393495), + Vector2 0.459462 0.141540 , + Vector2 (-0.414498) (-0.192829), + Vector2 (-0.183790) 0.082102 , + Vector2 (-0.079263) (-0.317383), + Vector2 0.102254 0.299133 , + Vector2 0.164216 (-0.054399) ] + +-- The first 6 arguments are identical to the frustum call. pixD is anti-alias +-- jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD is +-- depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field +-- effects. focus is distance from eye to plane in focus. focus must be greater +-- than, but not equal to 0. Note that accFrustum calls translate. You will +-- probably want to insure that your ModelView matrix has been initialized to +-- identity before calling accFrustum. +accFrustum :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble + -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () +accFrustum left right bottom top zNear zFar + (Vector2 pixDx pixDy) (Vector2 eyeDx eyeDy) focus = do + (_, Size w h) <- get viewport + + let xWSize = right - left; + yWSize = top - bottom; + + dx = -(pixDx * xWSize / fromIntegral w + eyeDx * zNear / focus) + dy = -(pixDy * yWSize / fromIntegral h + eyeDy * zNear / focus) + + matrixMode $= Projection + loadIdentity + frustum (left + dx) (right + dx) (bottom + dy) (top + dy) zNear zFar + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 (-eyeDx) (-eyeDy) 0) + +-- The first 4 arguments are identical to the perspective call. pixD is +-- anti-alias jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD +-- is depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field +-- effects. focus is distance from eye to plane in focus. focus must be greater +-- than, but not equal to 0. Note that accPerspective calls accFrustum. +accPerspective :: GLdouble -> GLdouble -> GLdouble -> GLdouble + -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () +accPerspective fovY aspect zNear zFar pixD eyeD focus = do + let fov2 = ((fovY * pi) / 180) / 2 + + top = zNear / (cos fov2 / sin fov2) + bottom = -top + + right = top * aspect + left = -right + + accFrustum left right bottom top zNear zFar pixD eyeD focus + +-- Initialize lighting and other values. +myInit :: IO () +myInit = do + materialAmbient Front $= Color4 1 1 1 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 50 + position (Light 0) $= Vertex4 0 0 10 1 + lightModelAmbient $= Color4 0.2 0.2 0.2 1 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + shadeModel $= Flat + + clearColor $= Color4 0 0 0 0 + clearAccum $= Color4 0 0 0 0 + +displayObjects :: IO () +displayObjects = do + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + + preservingMatrix $ do + translatef (Vector3 0 0 (-5)) + rotatef 30 (Vector3 1 0 0) + + preservingMatrix $ do + translatef (Vector3 (-0.80) 0.35 0) + rotatef 100 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0.7 0.7 0 1 + renderObject Solid (Torus 0.275 0.85 16 16) + + preservingMatrix $ do + translatef (Vector3 (-0.75) (-0.50) 0) + rotatef 45 (Vector3 0 0 1) + rotatef 45 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0 0.7 0.7 1 + renderObject Solid (Cube 1.5) + + preservingMatrix $ do + translatef (Vector3 0.75 0.60 0) + rotatef 30 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0.7 0 0.7 1 + renderObject Solid (Sphere' 1 16 16) + + preservingMatrix $ do + translatef (Vector3 0.70 (-0.90) 0.25) + materialDiffuse Front $= Color4 0.7 0.4 0.4 1 + renderObject Solid Octahedron + +-- display draws 5 teapots into the accumulation buffer several times; each time +-- with a jittered perspective. The focal point is at z = 5.0, so the gold +-- teapot will stay in focus. The amount of jitter is adjusted by the magnitude +-- of the accPerspective jitter; in this example, 0.33. In this example, the +-- teapots are drawn 8 times. +display :: DisplayCallback +display = do + (_, Size w h) <- get viewport + clear [ AccumBuffer ] + + flip mapM_ j8 $ \(Vector2 x y) -> do + clear [ ColorBuffer, DepthBuffer ] + accPerspective 50 (fromIntegral w / fromIntegral h) 1 15 + (Vector2 x y) (Vector2 0 0) 1 + displayObjects + accum Accum (recip (genericLength j8)) + + accum Return 1 + flush + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Be certain you request an accumulation buffer. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Alpha.hs b/examples/RedBook4/Alpha.hs --- a/examples/RedBook4/Alpha.hs +++ b/examples/RedBook4/Alpha.hs @@ -1,91 +1,91 @@ -{- - Alpha.hs (adapted from alpha.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws several overlapping filled polygons to demonstrate the - effect order has on alpha blending results. Use the 't' key to toggle the - order of drawing polygons. --} - -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { leftFirst :: IORef Bool } - -makeState :: IO State -makeState = do - l <- newIORef True - return $ State { leftFirst = l } - --- Initialize alpha blending function. -myInit :: IO () -myInit = do - blend $= Enabled - blendFunc $= (SrcAlpha, OneMinusSrcAlpha) - shadeModel $= Flat - clearColor $= Color4 0 0 0 0 - -drawLeftTriangle :: IO () -drawLeftTriangle = - -- draw yellow triangle on LHS of screen - renderPrimitive Triangles $ do - color (Color4 1 1 0 (0.75 :: GLfloat)) - vertex (Vertex3 0.1 0.9 (0 :: GLfloat)) - vertex (Vertex3 0.1 0.1 (0 :: GLfloat)) - vertex (Vertex3 0.7 0.5 (0 :: GLfloat)) - -drawRightTriangle :: IO () -drawRightTriangle = - -- draw cyan triangle on RHS of screen - renderPrimitive Triangles $ do - color (Color4 0 1 1 (0.75 :: GLfloat)) - vertex (Vertex3 0.9 0.9 (0 :: GLfloat)) - vertex (Vertex3 0.3 0.5 (0 :: GLfloat)) - vertex (Vertex3 0.9 0.1 (0 :: GLfloat)) - -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer ] - l <- get (leftFirst state) - if l - then do drawLeftTriangle; drawRightTriangle - else do drawRightTriangle; drawLeftTriangle - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho2D 0 1 0 (hf/wf) - else ortho2D 0 (wf/hf) 0 1 - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case toLower c of - 't' -> do leftFirst state $~ not; postRedisplay Nothing - '\27' -> exitWith ExitSuccess -- Escape key - _ -> return () -keyboard _ _ _ _ _ = return () - --- Main Loop --- Open window with initial window size, title bar, RGBA display mode, and --- handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 200 200 - _ <- createWindow progName - state <- makeState - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - displayCallback $= display state - mainLoop +{- + Alpha.hs (adapted from alpha.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws several overlapping filled polygons to demonstrate the + effect order has on alpha blending results. Use the 't' key to toggle the + order of drawing polygons. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { leftFirst :: IORef Bool } + +makeState :: IO State +makeState = do + l <- newIORef True + return $ State { leftFirst = l } + +-- Initialize alpha blending function. +myInit :: IO () +myInit = do + blend $= Enabled + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + shadeModel $= Flat + clearColor $= Color4 0 0 0 0 + +drawLeftTriangle :: IO () +drawLeftTriangle = + -- draw yellow triangle on LHS of screen + renderPrimitive Triangles $ do + color (Color4 1 1 0 (0.75 :: GLfloat)) + vertex (Vertex3 0.1 0.9 (0 :: GLfloat)) + vertex (Vertex3 0.1 0.1 (0 :: GLfloat)) + vertex (Vertex3 0.7 0.5 (0 :: GLfloat)) + +drawRightTriangle :: IO () +drawRightTriangle = + -- draw cyan triangle on RHS of screen + renderPrimitive Triangles $ do + color (Color4 0 1 1 (0.75 :: GLfloat)) + vertex (Vertex3 0.9 0.9 (0 :: GLfloat)) + vertex (Vertex3 0.3 0.5 (0 :: GLfloat)) + vertex (Vertex3 0.9 0.1 (0 :: GLfloat)) + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + l <- get (leftFirst state) + if l + then do drawLeftTriangle; drawRightTriangle + else do drawRightTriangle; drawLeftTriangle + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D 0 1 0 (hf/wf) + else ortho2D 0 (wf/hf) 0 1 + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 't' -> do leftFirst state $~ not; postRedisplay Nothing + '\27' -> exitWith ExitSuccess -- Escape key + _ -> return () +keyboard _ _ _ _ _ = return () + +-- Main Loop +-- Open window with initial window size, title bar, RGBA display mode, and +-- handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 200 200 + _ <- createWindow progName + state <- makeState + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state + mainLoop diff --git a/examples/RedBook4/Alpha3D.hs b/examples/RedBook4/Alpha3D.hs --- a/examples/RedBook4/Alpha3D.hs +++ b/examples/RedBook4/Alpha3D.hs @@ -1,124 +1,124 @@ -{- - Alpha3D.hs (adapted from alpha3D.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates how to intermix opaque and alpha blended polygons - in the same scene, by using depthMask. Press the 'a' key to animate moving - the transparent object through the opaque object. Press the 'r' key to reset - the scene. --} - -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -maxZ, minZ, zInc :: GLfloat -maxZ = 8 -minZ = -8 -zInc = 0.4 - --- We don't animate via the idle callback, because this is way too fast on --- modern computers. A timer with the delay below is used instead for redraw. -delay :: Timeout -delay = 100 - -data State = State { solidZ, transparentZ :: IORef GLfloat } - -makeState :: IO State -makeState = do - s <- newIORef maxZ - t <- newIORef minZ - return $ State { solidZ = s, transparentZ = t } - -data DisplayLists = DisplayLists { sphereList, cubeList :: DisplayList } - -myInit :: IO DisplayLists -myInit = do - materialSpecular Front $= Color4 1 1 1 0.15 - materialShininess Front $= 100 - position (Light 0) $= Vertex4 0.5 0.5 1 0 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - - s <- defineNewList Compile $ renderObject Solid (Sphere' 0.4 16 16) - c <- defineNewList Compile $ renderObject Solid (Cube 0.6) - return $ DisplayLists { sphereList = s, cubeList = c } - -display :: State -> DisplayLists -> DisplayCallback -display state displayLists = do - clear [ ColorBuffer, DepthBuffer ] - - preservingMatrix $ do - s <- get (solidZ state) - translate (Vector3 (-0.15) (-0.15) s) - materialEmission Front $= Color4 0 0 0 1 - materialDiffuse Front $= Color4 0.75 0.75 0 1 - callList (sphereList displayLists) - - preservingMatrix $ do - t <- get (transparentZ state) - translate (Vector3 (0.15) (0.15) t) - rotate (15 :: GLfloat) (Vector3 1 1 0) - rotate (30 :: GLfloat) (Vector3 0 1 0) - materialEmission Front $= Color4 0 0.3 0.3 0.6 - materialDiffuse Front $= Color4 0 0.8 0.8 0.6 - blend $= Enabled - depthMask $= Disabled - blendFunc $= (SrcAlpha, One) - callList (cubeList displayLists) - depthMask $= Enabled - blend $= Disabled - - swapBuffers - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-1.5) 1.5 (-1.5*hf/wf) (1.5*hf/wf) (-10) 10 - else ortho (-1.5*wf/hf) (1.5*wf/hf) (-1.5) 1.5 (-10) 10 - matrixMode $= Modelview 0 - loadIdentity - -animate :: State -> TimerCallback -animate state = do - s <- get (solidZ state) - t <- get (transparentZ state) - if (s <= minZ || t >= maxZ) - then idleCallback $= Nothing - else do - solidZ state $~ (+ (- zInc)) - transparentZ state $~ (+ zInc) - addTimerCallback delay (animate state) - postRedisplay Nothing - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case toLower c of - 'a' -> do solidZ state $= maxZ; transparentZ state $= minZ; addTimerCallback delay (animate state) - 'r' -> do solidZ state $= maxZ; transparentZ state $= minZ; postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - -- The original C example uses single buffering, which flickers a lot. - initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - _ <- createWindow progName - state <- makeState - displayLists <- myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - displayCallback $= display state displayLists - mainLoop +{- + Alpha3D.hs (adapted from alpha3D.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates how to intermix opaque and alpha blended polygons + in the same scene, by using depthMask. Press the 'a' key to animate moving + the transparent object through the opaque object. Press the 'r' key to reset + the scene. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +maxZ, minZ, zInc :: GLfloat +maxZ = 8 +minZ = -8 +zInc = 0.4 + +-- We don't animate via the idle callback, because this is way too fast on +-- modern computers. A timer with the delay below is used instead for redraw. +delay :: Timeout +delay = 100 + +data State = State { solidZ, transparentZ :: IORef GLfloat } + +makeState :: IO State +makeState = do + s <- newIORef maxZ + t <- newIORef minZ + return $ State { solidZ = s, transparentZ = t } + +data DisplayLists = DisplayLists { sphereList, cubeList :: DisplayList } + +myInit :: IO DisplayLists +myInit = do + materialSpecular Front $= Color4 1 1 1 0.15 + materialShininess Front $= 100 + position (Light 0) $= Vertex4 0.5 0.5 1 0 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + + s <- defineNewList Compile $ renderObject Solid (Sphere' 0.4 16 16) + c <- defineNewList Compile $ renderObject Solid (Cube 0.6) + return $ DisplayLists { sphereList = s, cubeList = c } + +display :: State -> DisplayLists -> DisplayCallback +display state displayLists = do + clear [ ColorBuffer, DepthBuffer ] + + preservingMatrix $ do + s <- get (solidZ state) + translate (Vector3 (-0.15) (-0.15) s) + materialEmission Front $= Color4 0 0 0 1 + materialDiffuse Front $= Color4 0.75 0.75 0 1 + callList (sphereList displayLists) + + preservingMatrix $ do + t <- get (transparentZ state) + translate (Vector3 (0.15) (0.15) t) + rotate (15 :: GLfloat) (Vector3 1 1 0) + rotate (30 :: GLfloat) (Vector3 0 1 0) + materialEmission Front $= Color4 0 0.3 0.3 0.6 + materialDiffuse Front $= Color4 0 0.8 0.8 0.6 + blend $= Enabled + depthMask $= Disabled + blendFunc $= (SrcAlpha, One) + callList (cubeList displayLists) + depthMask $= Enabled + blend $= Disabled + + swapBuffers + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-1.5) 1.5 (-1.5*hf/wf) (1.5*hf/wf) (-10) 10 + else ortho (-1.5*wf/hf) (1.5*wf/hf) (-1.5) 1.5 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +animate :: State -> TimerCallback +animate state = do + s <- get (solidZ state) + t <- get (transparentZ state) + if (s <= minZ || t >= maxZ) + then idleCallback $= Nothing + else do + solidZ state $~ (+ (- zInc)) + transparentZ state $~ (+ zInc) + addTimerCallback delay (animate state) + postRedisplay Nothing + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'a' -> do solidZ state $= maxZ; transparentZ state $= minZ; addTimerCallback delay (animate state) + 'r' -> do solidZ state $= maxZ; transparentZ state $= minZ; postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + -- The original C example uses single buffering, which flickers a lot. + initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + _ <- createWindow progName + state <- makeState + displayLists <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state displayLists + mainLoop diff --git a/examples/RedBook4/BezCurve.hs b/examples/RedBook4/BezCurve.hs --- a/examples/RedBook4/BezCurve.hs +++ b/examples/RedBook4/BezCurve.hs @@ -1,67 +1,67 @@ -{- - BezCurve.hs (adapted from bezcurve.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program uses evaluators to draw a Bezier curve. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -ctrlPoints :: [Vertex3 GLfloat] -ctrlPoints = [ Vertex3 (-4)(-4) 0, Vertex3 (-2) 4 0, - Vertex3 2 (-4) 0, Vertex3 4 4 0 ] - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - m <- newMap1 (0, 1) ctrlPoints - map1 $= Just (m :: GLmap1 Vertex3 GLfloat) - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - color3f (Color3 1 1 1) - renderPrimitive LineStrip $ - mapM_ evalCoord1 [ i/30.0 :: GLfloat | i <- [0..30] ] - -- The following code displays the control points as dots. - pointSize $= 5 - color3f (Color3 1 1 0) - renderPrimitive Points $ - mapM_ vertex ctrlPoints - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-5.0) 5.0 (-5.0*hf/wf) (5.0*hf/wf) (-5.0) 5.0 - else ortho (-5.0*wf/hf) (5.0*wf/hf) (-5.0) 5.0 (-5.0) 5.0 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + BezCurve.hs (adapted from bezcurve.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program uses evaluators to draw a Bezier curve. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +ctrlPoints :: [Vertex3 GLfloat] +ctrlPoints = [ Vertex3 (-4)(-4) 0, Vertex3 (-2) 4 0, + Vertex3 2 (-4) 0, Vertex3 4 4 0 ] + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + m <- newMap1 (0, 1) ctrlPoints + map1 $= Just (m :: GLmap1 Vertex3 GLfloat) + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 1 1 1) + renderPrimitive LineStrip $ + mapM_ evalCoord1 [ i/30.0 :: GLfloat | i <- [0..30] ] + -- The following code displays the control points as dots. + pointSize $= 5 + color3f (Color3 1 1 0) + renderPrimitive Points $ + mapM_ vertex ctrlPoints + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-5.0) 5.0 (-5.0*hf/wf) (5.0*hf/wf) (-5.0) 5.0 + else ortho (-5.0*wf/hf) (5.0*wf/hf) (-5.0) 5.0 (-5.0) 5.0 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/BezMesh.hs b/examples/RedBook4/BezMesh.hs --- a/examples/RedBook4/BezMesh.hs +++ b/examples/RedBook4/BezMesh.hs @@ -1,84 +1,84 @@ -{- - BezMesh.hs (adapted from bezmesh.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program renders a lighted, filled Bezier surface, using two-dimensional - evaluators. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Data.List ( transpose ) -import Graphics.UI.GLUT - -ctrlPoints :: [[Vertex3 GLfloat]] -ctrlPoints = [ - [ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0, - Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ], - [ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0, - Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ], - [ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0, - Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ], - [ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0), - Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]] - -initlights :: IO () -initlights = do - lighting $= Enabled - light (Light 0) $= Enabled - - ambient (Light 0) $= Color4 0.2 0.2 0.2 1.0 - position (Light 0) $= Vertex4 0 0 2 1 - - materialDiffuse Front $= Color4 0.6 0.6 0.6 1.0 - materialSpecular Front $= Color4 1.0 1.0 1.0 1.0 - materialShininess Front $= 50 - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - rotate (85 :: GLfloat) (Vector3 1 1 1) - evalMesh2 Fill (0, 20) (0, 20) - flush - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - depthFunc $= Just Less - m <- newMap2 (0, 1) (0, 1) (transpose ctrlPoints) - map2 $= Just (m :: GLmap2 Vertex3 GLfloat) - autoNormal $= Enabled - mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat))) - initlights -- for lighted version only - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0 - else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop +{- + BezMesh.hs (adapted from bezmesh.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program renders a lighted, filled Bezier surface, using two-dimensional + evaluators. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Data.List ( transpose ) +import Graphics.UI.GLUT + +ctrlPoints :: [[Vertex3 GLfloat]] +ctrlPoints = [ + [ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0, + Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ], + [ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0, + Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ], + [ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0, + Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ], + [ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0), + Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]] + +initlights :: IO () +initlights = do + lighting $= Enabled + light (Light 0) $= Enabled + + ambient (Light 0) $= Color4 0.2 0.2 0.2 1.0 + position (Light 0) $= Vertex4 0 0 2 1 + + materialDiffuse Front $= Color4 0.6 0.6 0.6 1.0 + materialSpecular Front $= Color4 1.0 1.0 1.0 1.0 + materialShininess Front $= 50 + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + rotate (85 :: GLfloat) (Vector3 1 1 1) + evalMesh2 Fill (0, 20) (0, 20) + flush + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + depthFunc $= Just Less + m <- newMap2 (0, 1) (0, 1) (transpose ctrlPoints) + map2 $= Just (m :: GLmap2 Vertex3 GLfloat) + autoNormal $= Enabled + mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat))) + initlights -- for lighted version only + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0 + else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/BezSurf.hs b/examples/RedBook4/BezSurf.hs --- a/examples/RedBook4/BezSurf.hs +++ b/examples/RedBook4/BezSurf.hs @@ -1,79 +1,79 @@ -{- - BezSurf.hs (adapted from bezsurf.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program renders a wireframe Bezier surface, using two-dimensional - evaluators. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -ctrlPoints :: [[Vertex3 GLfloat]] -ctrlPoints = [ - [ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0, - Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ], - [ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0, - Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ], - [ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0, - Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ], - [ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0), - Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]] - --- Hey mom, look, it's C! ;-) -for :: GLfloat -> GLfloat -> (GLfloat -> IO ()) -> IO () -for s e f = mapM_ f [ i | i <- [ s, if s <= e then s + 1 else s - 1 .. e ] ] - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - color (Color3 1 1 1 :: Color3 GLfloat) - preservingMatrix $ do - rotate (85 :: GLfloat) (Vector3 1 1 1) - for 0 8 $ \j -> do - renderPrimitive LineStrip $ do - for 0 30 $ \i -> evalCoord2 (i/30, j/ 8) - renderPrimitive LineStrip $ do - for 0 30 $ \i -> evalCoord2 (j/ 8, i/30) - flush - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - m <- newMap2 (0, 1) (0, 1) ctrlPoints - map2 $= Just (m :: GLmap2 Vertex3 GLfloat) - mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat))) - depthFunc $= Just Less - shadeModel $= Flat - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0 - else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + BezSurf.hs (adapted from bezsurf.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program renders a wireframe Bezier surface, using two-dimensional + evaluators. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +ctrlPoints :: [[Vertex3 GLfloat]] +ctrlPoints = [ + [ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0, + Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ], + [ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0, + Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ], + [ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0, + Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ], + [ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0), + Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]] + +-- Hey mom, look, it's C! ;-) +for :: GLfloat -> GLfloat -> (GLfloat -> IO ()) -> IO () +for s e f = mapM_ f [ i | i <- [ s, if s <= e then s + 1 else s - 1 .. e ] ] + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + color (Color3 1 1 1 :: Color3 GLfloat) + preservingMatrix $ do + rotate (85 :: GLfloat) (Vector3 1 1 1) + for 0 8 $ \j -> do + renderPrimitive LineStrip $ do + for 0 30 $ \i -> evalCoord2 (i/30, j/ 8) + renderPrimitive LineStrip $ do + for 0 30 $ \i -> evalCoord2 (j/ 8, i/30) + flush + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + m <- newMap2 (0, 1) (0, 1) ctrlPoints + map2 $= Just (m :: GLmap2 Vertex3 GLfloat) + mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat))) + depthFunc $= Just Less + shadeModel $= Flat + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0 + else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/BlendEqn.hs b/examples/RedBook4/BlendEqn.hs --- a/examples/RedBook4/BlendEqn.hs +++ b/examples/RedBook4/BlendEqn.hs @@ -1,95 +1,95 @@ -{- - BlendEqn.hs (adapted from blendeqn.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Demonstrate the different blending functions available with the OpenGL - imaging subset. This program demonstrates use of blendEquation. - - The following keys change the selected blend equation function: - - 'a' -> FuncAdd - 's' -> FuncSubtract - 'r' -> FuncReverseSubtract - 'm' -> Min - 'x' -> Max --} - -import Data.Char ( toLower ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - clearColor $= Color4 1 1 0 0 - blendFunc $= (One, One) - blend $= Enabled - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - - color (Color3 0 0 (1 :: GLfloat)) - rect (Vertex2 (-0.5) (-0.5)) (Vertex2 0.5 (0.5 :: GLfloat)) - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - let aspect = fromIntegral w / fromIntegral h - - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - if aspect < 1 - then let aspect' = recip aspect - in ortho (-aspect') aspect' (-1) 1 (-1) 1 - else ortho (-1) 1 (-aspect) aspect (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char c) Down _ _ = case toLower c of - -- Colors are added as: (0, 0, 1) + (1, 1, 0) = (1, 1, 1) - -- which will produce a white square on a yellow background. - 'a' -> setBlendEquation FuncAdd - - -- Colors are subtracted as: (0, 0, 1) - (1, 1, 0) = (-1, -1, 1) - -- which is clamped to (0, 0, 1), producing a blue square on a - -- yellow background - 's' -> setBlendEquation FuncSubtract - - -- Colors are subtracted as: (1, 1, 0) - (0, 0, 1) = (1, 1, -1) - -- which is clamed to (1, 1, 0). This produces yellow for both - -- the square and the background. - 'r' -> setBlendEquation FuncReverseSubtract - - -- The minimum of each component is computed, as - -- [min(0, 1), min(0, 1), min(1, 0)] which equates to (0, 0, 0). - -- This will produce a black square on the yellow background. - 'm' -> setBlendEquation Min - - -- The minimum of each component is computed, as - -- [max(0, 1), max(0, 1), max(1, 0)] which equates to (1, 1, 1) - -- This will produce a white square on the yellow background. - 'x' -> setBlendEquation Max - - '\27' -> exitWith ExitSuccess - _ -> return () - where setBlendEquation e = do - blendEquation $= e - postRedisplay Nothing -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 512 512 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display - mainLoop +{- + BlendEqn.hs (adapted from blendeqn.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Demonstrate the different blending functions available with the OpenGL + imaging subset. This program demonstrates use of blendEquation. + + The following keys change the selected blend equation function: + + 'a' -> FuncAdd + 's' -> FuncSubtract + 'r' -> FuncReverseSubtract + 'm' -> Min + 'x' -> Max +-} + +import Data.Char ( toLower ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 1 1 0 0 + blendFunc $= (One, One) + blend $= Enabled + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + + color (Color3 0 0 (1 :: GLfloat)) + rect (Vertex2 (-0.5) (-0.5)) (Vertex2 0.5 (0.5 :: GLfloat)) + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + let aspect = fromIntegral w / fromIntegral h + + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + if aspect < 1 + then let aspect' = recip aspect + in ortho (-aspect') aspect' (-1) 1 (-1) 1 + else ortho (-1) 1 (-aspect) aspect (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char c) Down _ _ = case toLower c of + -- Colors are added as: (0, 0, 1) + (1, 1, 0) = (1, 1, 1) + -- which will produce a white square on a yellow background. + 'a' -> setBlendEquation FuncAdd + + -- Colors are subtracted as: (0, 0, 1) - (1, 1, 0) = (-1, -1, 1) + -- which is clamped to (0, 0, 1), producing a blue square on a + -- yellow background + 's' -> setBlendEquation FuncSubtract + + -- Colors are subtracted as: (1, 1, 0) - (0, 0, 1) = (1, 1, -1) + -- which is clamed to (1, 1, 0). This produces yellow for both + -- the square and the background. + 'r' -> setBlendEquation FuncReverseSubtract + + -- The minimum of each component is computed, as + -- [min(0, 1), min(0, 1), min(1, 0)] which equates to (0, 0, 0). + -- This will produce a black square on the yellow background. + 'm' -> setBlendEquation Min + + -- The minimum of each component is computed, as + -- [max(0, 1), max(0, 1), max(1, 0)] which equates to (1, 1, 1) + -- This will produce a white square on the yellow background. + 'x' -> setBlendEquation Max + + '\27' -> exitWith ExitSuccess + _ -> return () + where setBlendEquation e = do + blendEquation $= e + postRedisplay Nothing +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 512 512 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display + mainLoop diff --git a/examples/RedBook4/Checker.hs b/examples/RedBook4/Checker.hs --- a/examples/RedBook4/Checker.hs +++ b/examples/RedBook4/Checker.hs @@ -1,101 +1,101 @@ -{- - Checker.hs (adapted from checker.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program texture maps a checkerboard image onto two rectangles. - - Texture objects are only used when GL_EXT_texture_object is supported. --} - -import Control.Monad ( when ) -import Data.Maybe ( isJust ) -import Data.Bits ( (.&.) ) -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Create checkerboard image -checkImageSize :: TextureSize2D -checkImageSize = TextureSize2D 64 64 - -withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) - -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () -withCheckImage (TextureSize2D w h) n f act = - withArray [ f c | - i <- [ 0 .. w - 1 ], - j <- [ 0 .. h - 1 ], - let c | (i .&. n) == (j .&. n) = 0 - | otherwise = 255 ] $ - act. PixelData RGBA UnsignedByte - -myInit :: IO (Maybe TextureObject) -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - depthFunc $= Just Less - rowAlignment Unpack $= 1 - - exts <- get glExtensions - mbTexName <- if "GL_EXT_texture_object" `elem` exts - then fmap Just genObjectName - else return Nothing - when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName - - textureWrapMode Texture2D S $= (Repeated, Repeat) - textureWrapMode Texture2D T $= (Repeated, Repeat) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - withCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) $ - texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 - return mbTexName - -display :: Maybe TextureObject -> DisplayCallback -display mbTexName = do - clear [ ColorBuffer, DepthBuffer ] - texture Texture2D $= Enabled - textureFunction $= Decal - when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName - - -- resolve overloading, not needed in "real" programs - let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - renderPrimitive Quads $ do - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) - texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) - texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 ) - texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) - - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) - texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 ) - texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) - texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) - flush - texture Texture2D $= Disabled - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 60 (fromIntegral w / fromIntegral h) 1 30 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-3.6 :: GLfloat)) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - mbTexName <- myInit - displayCallback $= display mbTexName - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Checker.hs (adapted from checker.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program texture maps a checkerboard image onto two rectangles. + + Texture objects are only used when GL_EXT_texture_object is supported. +-} + +import Control.Monad ( when ) +import Data.Maybe ( isJust ) +import Data.Bits ( (.&.) ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Create checkerboard image +checkImageSize :: TextureSize2D +checkImageSize = TextureSize2D 64 64 + +withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) + -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () +withCheckImage (TextureSize2D w h) n f act = + withArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] $ + act. PixelData RGBA UnsignedByte + +myInit :: IO (Maybe TextureObject) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + rowAlignment Unpack $= 1 + + exts <- get glExtensions + mbTexName <- if "GL_EXT_texture_object" `elem` exts + then fmap Just genObjectName + else return Nothing + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + withCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) $ + texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 + return mbTexName + +display :: Maybe TextureObject -> DisplayCallback +display mbTexName = do + clear [ ColorBuffer, DepthBuffer ] + texture Texture2D $= Enabled + textureFunction $= Decal + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + + -- resolve overloading, not needed in "real" programs + let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) + + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) + flush + texture Texture2D $= Disabled + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-3.6 :: GLfloat)) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + mbTexName <- myInit + displayCallback $= display mbTexName + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Clip.hs b/examples/RedBook4/Clip.hs --- a/examples/RedBook4/Clip.hs +++ b/examples/RedBook4/Clip.hs @@ -1,63 +1,63 @@ -{- - Clip.hs (adapted from clip.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates arbitrary clipping planes. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - translatef = translate :: Vector3 GLfloat -> IO () - rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () - color3f (Color3 1 1 1) - - preservingMatrix $ do - translatef (Vector3 0 0 (-5)) - - -- clip lower half -- y < 0 - clipPlane (ClipPlaneName 0) $= Just (Plane 0 1 0 0) - -- clip left half -- x < 0 - clipPlane (ClipPlaneName 1) $= Just (Plane 1 0 0 0) - - rotatef 90 (Vector3 1 0 0) - renderObject Wireframe (Sphere' 1 20 16) - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 60 (fromIntegral w / fromIntegral h) 1 20 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Clip.hs (adapted from clip.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates arbitrary clipping planes. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + color3f (Color3 1 1 1) + + preservingMatrix $ do + translatef (Vector3 0 0 (-5)) + + -- clip lower half -- y < 0 + clipPlane (ClipPlaneName 0) $= Just (Plane 0 1 0 0) + -- clip left half -- x < 0 + clipPlane (ClipPlaneName 1) $= Just (Plane 1 0 0 0) + + rotatef 90 (Vector3 1 0 0) + renderObject Wireframe (Sphere' 1 20 16) + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 20 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/ColorMat.hs b/examples/RedBook4/ColorMat.hs --- a/examples/RedBook4/ColorMat.hs +++ b/examples/RedBook4/ColorMat.hs @@ -1,94 +1,94 @@ -{- - Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - After initialization, the program will be in ColorMaterial mode. - Interaction: pressing the mouse buttons will change the diffuse - reflection values. --} - -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { r, g, b :: IORef GLfloat } - -diffuseMaterial :: State -> IO (Color4 GLfloat) -diffuseMaterial state = do - r' <- get (r state) - g' <- get (g state) - b' <- get (b state) - return $ Color4 r' g' b' 1 - -makeState :: IO State -makeState = do - r' <- newIORef 0.5 - g' <- newIORef 0.5 - b' <- newIORef 0.5 - return $ State { r = r', g = g', b = b' } - --- Initialize material property, light source, lighting model, --- and depth buffer. -myInit :: State -> IO () -myInit state = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Smooth - depthFunc $= Just Less - dm <- diffuseMaterial state - materialDiffuse Front $= dm - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 25 - position (Light 0) $= Vertex4 1 1 1 0 - lighting $= Enabled - light (Light 0) $= Enabled - colorMaterial $= Just (Front, Diffuse) - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - renderObject Solid (Sphere' 1 20 16) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-1.5) 1.5 (-1.5 * hf/wf) (1.5 * hf/wf) (-10) 10 - else ortho (-1.5 * wf/hf) (1.5 * wf/hf) (-1.5) 1.5 (-10) 10 - matrixMode $= Modelview 0 - loadIdentity - -keyboardMouse :: State -> KeyboardMouseCallback -keyboardMouse state (MouseButton button) Down _ _ = case button of - LeftButton -> update r - MiddleButton -> update g - RightButton -> update b - _ -> return () - where update component = do - component state $~ inc - dm <- diffuseMaterial state - color dm - postRedisplay Nothing - inc x = let s = x + 0.1 in if s > 1 then 0 else s -keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess -keyboardMouse _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - state <- makeState - myInit state - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboardMouse state) - mainLoop +{- + Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + After initialization, the program will be in ColorMaterial mode. + Interaction: pressing the mouse buttons will change the diffuse + reflection values. +-} + +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { r, g, b :: IORef GLfloat } + +diffuseMaterial :: State -> IO (Color4 GLfloat) +diffuseMaterial state = do + r' <- get (r state) + g' <- get (g state) + b' <- get (b state) + return $ Color4 r' g' b' 1 + +makeState :: IO State +makeState = do + r' <- newIORef 0.5 + g' <- newIORef 0.5 + b' <- newIORef 0.5 + return $ State { r = r', g = g', b = b' } + +-- Initialize material property, light source, lighting model, +-- and depth buffer. +myInit :: State -> IO () +myInit state = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + depthFunc $= Just Less + dm <- diffuseMaterial state + materialDiffuse Front $= dm + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 25 + position (Light 0) $= Vertex4 1 1 1 0 + lighting $= Enabled + light (Light 0) $= Enabled + colorMaterial $= Just (Front, Diffuse) + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + renderObject Solid (Sphere' 1 20 16) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-1.5) 1.5 (-1.5 * hf/wf) (1.5 * hf/wf) (-10) 10 + else ortho (-1.5 * wf/hf) (1.5 * wf/hf) (-1.5) 1.5 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +keyboardMouse :: State -> KeyboardMouseCallback +keyboardMouse state (MouseButton button) Down _ _ = case button of + LeftButton -> update r + MiddleButton -> update g + RightButton -> update b + _ -> return () + where update component = do + component state $~ inc + dm <- diffuseMaterial state + color dm + postRedisplay Nothing + inc x = let s = x + 0.1 in if s > 1 then 0 else s +keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboardMouse _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + myInit state + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboardMouse state) + mainLoop diff --git a/examples/RedBook4/ColorMatrix.hs b/examples/RedBook4/ColorMatrix.hs --- a/examples/RedBook4/ColorMatrix.hs +++ b/examples/RedBook4/ColorMatrix.hs @@ -1,65 +1,65 @@ -{- - ColorMatrix.hs (adapted from colormatrix.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program uses the color matrix to exchange the color channels of an image. - - Red -> Green - Green -> Blue - Blue -> Red --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT -import ReadImage - -myInit :: IO () -myInit = do - m <- newMatrix ColumnMajor [ 0, 1, 0, 0, - 0, 0, 1, 0, - 1, 0, 0, 0, - 0, 0, 0, 1 ] - rowAlignment Unpack $= 1 - clearColor $= Color4 0 0 0 0 - matrixMode $= Color - matrix Nothing $= (m :: GLmatrix GLfloat) - matrixMode $= Modelview 0 - -display :: Size -> PixelData a -> DisplayCallback -display size pixels = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - rasterPos2i (Vertex2 1 1) - drawPixels size pixels - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, args) <- getArgsAndInitialize - (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= size - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display size pixels - mainLoop +{- + ColorMatrix.hs (adapted from colormatrix.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program uses the color matrix to exchange the color channels of an image. + + Red -> Green + Green -> Blue + Blue -> Red +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT +import ReadImage + +myInit :: IO () +myInit = do + m <- newMatrix ColumnMajor [ 0, 1, 0, 0, + 0, 0, 1, 0, + 1, 0, 0, 0, + 0, 0, 0, 1 ] + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + matrixMode $= Color + matrix Nothing $= (m :: GLmatrix GLfloat) + matrixMode $= Modelview 0 + +display :: Size -> PixelData a -> DisplayCallback +display size pixels = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 1 1) + drawPixels size pixels + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, args) <- getArgsAndInitialize + (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= size + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display size pixels + mainLoop diff --git a/examples/RedBook4/ColorTable.hs b/examples/RedBook4/ColorTable.hs --- a/examples/RedBook4/ColorTable.hs +++ b/examples/RedBook4/ColorTable.hs @@ -1,62 +1,62 @@ -{- - ColorTable.hs (adapted from colortable.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Invert a passed block of pixels. This program illustrates the use of the - colorTable function. --} - -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT -import ReadImage - -myInit :: IO () -myInit = do - rowAlignment Unpack $= 1 - clearColor $= Color4 0 0 0 0 - -- Set up an inverse color table - let tableSize = 256 - t = fromIntegral (tableSize - 1) :: GLubyte - withArray [ Color3 i i i | i <- [ t, t - 1 .. 0 ] ] $ \buf -> - colorTable NoProxy ColorTable RGB' tableSize (PixelData RGB UnsignedByte buf) - colorTableStage ColorTableStage $= Enabled - -display :: Size -> PixelData a -> DisplayCallback -display size pixels = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - rasterPos2i (Vertex2 1 1) - drawPixels size pixels - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, args) <- getArgsAndInitialize - (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= size - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display size pixels - mainLoop +{- + ColorTable.hs (adapted from colortable.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Invert a passed block of pixels. This program illustrates the use of the + colorTable function. +-} + +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT +import ReadImage + +myInit :: IO () +myInit = do + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + -- Set up an inverse color table + let tableSize = 256 + t = fromIntegral (tableSize - 1) :: GLubyte + withArray [ Color3 i i i | i <- [ t, t - 1 .. 0 ] ] $ \buf -> + colorTable NoProxy ColorTable RGB' tableSize (PixelData RGB UnsignedByte buf) + colorTableStage ColorTableStage $= Enabled + +display :: Size -> PixelData a -> DisplayCallback +display size pixels = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 1 1) + drawPixels size pixels + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, args) <- getArgsAndInitialize + (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= size + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display size pixels + mainLoop diff --git a/examples/RedBook4/Combiner.hs b/examples/RedBook4/Combiner.hs --- a/examples/RedBook4/Combiner.hs +++ b/examples/RedBook4/Combiner.hs @@ -1,236 +1,236 @@ -{- - Combiner.hs (adapted from combiner.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program renders a variety of quads showing different effects of - texture combiner functions. - - The first row renders an untextured polygon (so you can compare the - fragment colors) and then the 2 textures. - - The second row shows several different combiner functions on a single - texture: replace, modulate, add, add-signed, and subtract. - - The third row shows the interpolate combiner function on a single texture - with a constant color/alpha value, varying the amount of interpolation. - - The fourth row uses multitexturing with two textures and different - combiner functions. - - The fifth row are some combiner experiments: using the scaling factor and - reversing the order of subtraction for a combination function. --} - -import Data.Bits ( (.&.) ) -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Create checkerboard image -imageSize :: TextureSize2D -imageSize = TextureSize2D 8 8 - -makeImage :: TextureSize2D -> (GLsizei -> GLsizei -> Color4 GLubyte) - -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () -makeImage (TextureSize2D w h) f act = - withArray [ f i j | - i <- [ 0 .. w - 1 ], - j <- [ 0 .. h - 1 ] ] $ - act . PixelData RGBA UnsignedByte - -myInit :: IO (TextureObject, TextureObject, DisplayList) -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Smooth - - rowAlignment Unpack $= 1 - - [texName0, texName1] <- genObjectNames 2 - - textureBinding Texture2D $= Just texName0 - textureWrapMode Texture2D S $= (Repeated, Repeat) - textureWrapMode Texture2D T $= (Repeated, Repeat) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - -- horiz b & w stripes - makeImage imageSize (\i _ -> let c = if i .&. 2 == 0 then 255 else 0 in Color4 c c c 255) $ - texImage2D Texture2D NoProxy 0 RGBA' imageSize 0 - - textureBinding Texture2D $= Just texName1 - textureWrapMode Texture2D S $= (Repeated, Repeat) - textureWrapMode Texture2D T $= (Repeated, Repeat) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - textureFunction $= Decal - -- wider vertical 50% cyan and black stripes - makeImage imageSize (\_ j -> let c = if j .&. 4 /= 0 then 128 else 0 in Color4 0 c c 255) $ - texImage2D Texture2D NoProxy 0 RGBA' imageSize 0 - - -- smooth-shaded polygon with multiple texture coordinates - let vert :: TexCoord2 GLfloat -> Color3 GLfloat -> Vertex3 GLfloat -> IO () - vert t c v = do - multiTexCoord (TextureUnit 0) t - multiTexCoord (TextureUnit 1) t - color c - vertex v - - dl <- defineNewList Compile $ - renderPrimitive Quads $ do - vert (TexCoord2 0 0) (Color3 0.5 1 0.25) (Vertex3 0 0 0) - vert (TexCoord2 0 2) (Color3 1 1 1 ) (Vertex3 0 1 0) - vert (TexCoord2 2 2) (Color3 1 1 1 ) (Vertex3 1 1 0) - vert (TexCoord2 2 0) (Color3 1 0.5 0.25) (Vertex3 1 0 0) - - return (texName0, texName1, dl) - -display :: (TextureObject, TextureObject, DisplayList) -> DisplayCallback -display (texName0, texName1, dl) = do - clear [ ColorBuffer ] - - let drawAt :: GLfloat -> GLfloat -> IO () - drawAt x y = preservingMatrix $ do - translate (Vector3 x y 0) - callList dl - - -- untextured polygon -- see the "fragment" colors - texture Texture2D $= Disabled - drawAt 0 5 - - texture Texture2D $= Enabled - -- draw ordinary textured polys; 1 texture unit; combine mode disabled - textureFunction $= Modulate - textureBinding Texture2D $= Just texName0 - drawAt 1 5 - - textureBinding Texture2D $= Just texName1 - drawAt 2 5 - - -- different combine modes enabled; 1 texture unit - -- defaults are: - -- argRGB Arg0 $= Arg SrcColor CurrentUnit - -- argRGB Arg1 $= Arg SrcColor Previous - - textureBinding Texture2D $= Just texName0 - textureFunction $= Combine - combineRGB $= Replace' - argRGB Arg0 $= Arg SrcColor CurrentUnit - drawAt 1 4 - - combineRGB $= Modulate' - argRGB Arg1 $= Arg SrcColor Previous - drawAt 2 4 - - combineRGB $= AddUnsigned' - drawAt 3 4 - - combineRGB $= AddSigned - drawAt 4 4 - - combineRGB $= Subtract - drawAt 5 4 - - -- interpolate combine with constant color; 1 texture unit - -- use different alpha values for constant color - -- defaults are: - -- argRGB Arg0 $= Arg SrcColor CurrentUnit - -- argRGB Arg1 $= Arg SrcColor Previous - -- argRGB Arg2 $= Arg SrcAlpha Constant - - constantColor $= Color4 0 0 0 0.2 - textureBinding Texture2D $= Just texName0 - textureFunction $= Combine - combineRGB $= Interpolate - argRGB Arg0 $= Arg SrcColor CurrentUnit - argRGB Arg1 $= Arg SrcColor Previous - argRGB Arg2 $= Arg SrcAlpha Constant - drawAt 1 3 - - constantColor $= Color4 0 0 0 0.4 - drawAt 2 3 - - constantColor $= Color4 0 0 0 0.6 - drawAt 3 3 - - constantColor $= Color4 0 0 0 0.8 - drawAt 4 3 - - -- combine textures 0 & 1 - -- defaults are: - -- argRGB Arg0 $= Arg SrcColor CurrentUnit - -- argRGB Arg1 $= Arg SrcColor Previous - - activeTexture $= TextureUnit 0 - texture Texture2D $= Enabled - textureBinding Texture2D $= Just texName0 - textureFunction $= Modulate - - activeTexture $= TextureUnit 1 - texture Texture2D $= Enabled - textureBinding Texture2D $= Just texName1 - textureFunction $= Combine - combineRGB $= Replace' - drawAt 1 2 - - -- try different combiner modes of texture unit 1 - combineRGB $= Modulate' - drawAt 2 2 - - combineRGB $= AddUnsigned' - drawAt 3 2 - - combineRGB $= AddSigned - drawAt 4 2 - - combineRGB $= Subtract - drawAt 5 2 - - -- some experiments - - -- see the effect of rgbScale - rgbScale $= 2 - combineRGB $= Replace' - drawAt 1 1 - - combineRGB $= Modulate' - drawAt 2 1 - rgbScale $= 1 - - -- reverse the order of subtraction Arg1-Arg0 - - textureFunction $= Combine - combineRGB $= Subtract - argRGB Arg0 $= Arg SrcColor Previous - argRGB Arg1 $= Arg SrcColor CurrentUnit - drawAt 5 1 - - activeTexture $= TextureUnit 1 -- deactivate multitexturing - texture Texture2D $= Disabled - activeTexture $= TextureUnit 0 -- activate single texture unit - - flush - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 7 0 7 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 400 400 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - texNamesAndDL <- myInit - displayCallback $= display texNamesAndDL - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Combiner.hs (adapted from combiner.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program renders a variety of quads showing different effects of + texture combiner functions. + + The first row renders an untextured polygon (so you can compare the + fragment colors) and then the 2 textures. + + The second row shows several different combiner functions on a single + texture: replace, modulate, add, add-signed, and subtract. + + The third row shows the interpolate combiner function on a single texture + with a constant color/alpha value, varying the amount of interpolation. + + The fourth row uses multitexturing with two textures and different + combiner functions. + + The fifth row are some combiner experiments: using the scaling factor and + reversing the order of subtraction for a combination function. +-} + +import Data.Bits ( (.&.) ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Create checkerboard image +imageSize :: TextureSize2D +imageSize = TextureSize2D 8 8 + +makeImage :: TextureSize2D -> (GLsizei -> GLsizei -> Color4 GLubyte) + -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () +makeImage (TextureSize2D w h) f act = + withArray [ f i j | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ] ] $ + act . PixelData RGBA UnsignedByte + +myInit :: IO (TextureObject, TextureObject, DisplayList) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + + rowAlignment Unpack $= 1 + + [texName0, texName1] <- genObjectNames 2 + + textureBinding Texture2D $= Just texName0 + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + -- horiz b & w stripes + makeImage imageSize (\i _ -> let c = if i .&. 2 == 0 then 255 else 0 in Color4 c c c 255) $ + texImage2D Texture2D NoProxy 0 RGBA' imageSize 0 + + textureBinding Texture2D $= Just texName1 + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + textureFunction $= Decal + -- wider vertical 50% cyan and black stripes + makeImage imageSize (\_ j -> let c = if j .&. 4 /= 0 then 128 else 0 in Color4 0 c c 255) $ + texImage2D Texture2D NoProxy 0 RGBA' imageSize 0 + + -- smooth-shaded polygon with multiple texture coordinates + let vert :: TexCoord2 GLfloat -> Color3 GLfloat -> Vertex3 GLfloat -> IO () + vert t c v = do + multiTexCoord (TextureUnit 0) t + multiTexCoord (TextureUnit 1) t + color c + vertex v + + dl <- defineNewList Compile $ + renderPrimitive Quads $ do + vert (TexCoord2 0 0) (Color3 0.5 1 0.25) (Vertex3 0 0 0) + vert (TexCoord2 0 2) (Color3 1 1 1 ) (Vertex3 0 1 0) + vert (TexCoord2 2 2) (Color3 1 1 1 ) (Vertex3 1 1 0) + vert (TexCoord2 2 0) (Color3 1 0.5 0.25) (Vertex3 1 0 0) + + return (texName0, texName1, dl) + +display :: (TextureObject, TextureObject, DisplayList) -> DisplayCallback +display (texName0, texName1, dl) = do + clear [ ColorBuffer ] + + let drawAt :: GLfloat -> GLfloat -> IO () + drawAt x y = preservingMatrix $ do + translate (Vector3 x y 0) + callList dl + + -- untextured polygon -- see the "fragment" colors + texture Texture2D $= Disabled + drawAt 0 5 + + texture Texture2D $= Enabled + -- draw ordinary textured polys; 1 texture unit; combine mode disabled + textureFunction $= Modulate + textureBinding Texture2D $= Just texName0 + drawAt 1 5 + + textureBinding Texture2D $= Just texName1 + drawAt 2 5 + + -- different combine modes enabled; 1 texture unit + -- defaults are: + -- argRGB Arg0 $= Arg SrcColor CurrentUnit + -- argRGB Arg1 $= Arg SrcColor Previous + + textureBinding Texture2D $= Just texName0 + textureFunction $= Combine + combineRGB $= Replace' + argRGB Arg0 $= Arg SrcColor CurrentUnit + drawAt 1 4 + + combineRGB $= Modulate' + argRGB Arg1 $= Arg SrcColor Previous + drawAt 2 4 + + combineRGB $= AddUnsigned' + drawAt 3 4 + + combineRGB $= AddSigned + drawAt 4 4 + + combineRGB $= Subtract + drawAt 5 4 + + -- interpolate combine with constant color; 1 texture unit + -- use different alpha values for constant color + -- defaults are: + -- argRGB Arg0 $= Arg SrcColor CurrentUnit + -- argRGB Arg1 $= Arg SrcColor Previous + -- argRGB Arg2 $= Arg SrcAlpha Constant + + constantColor $= Color4 0 0 0 0.2 + textureBinding Texture2D $= Just texName0 + textureFunction $= Combine + combineRGB $= Interpolate + argRGB Arg0 $= Arg SrcColor CurrentUnit + argRGB Arg1 $= Arg SrcColor Previous + argRGB Arg2 $= Arg SrcAlpha Constant + drawAt 1 3 + + constantColor $= Color4 0 0 0 0.4 + drawAt 2 3 + + constantColor $= Color4 0 0 0 0.6 + drawAt 3 3 + + constantColor $= Color4 0 0 0 0.8 + drawAt 4 3 + + -- combine textures 0 & 1 + -- defaults are: + -- argRGB Arg0 $= Arg SrcColor CurrentUnit + -- argRGB Arg1 $= Arg SrcColor Previous + + activeTexture $= TextureUnit 0 + texture Texture2D $= Enabled + textureBinding Texture2D $= Just texName0 + textureFunction $= Modulate + + activeTexture $= TextureUnit 1 + texture Texture2D $= Enabled + textureBinding Texture2D $= Just texName1 + textureFunction $= Combine + combineRGB $= Replace' + drawAt 1 2 + + -- try different combiner modes of texture unit 1 + combineRGB $= Modulate' + drawAt 2 2 + + combineRGB $= AddUnsigned' + drawAt 3 2 + + combineRGB $= AddSigned + drawAt 4 2 + + combineRGB $= Subtract + drawAt 5 2 + + -- some experiments + + -- see the effect of rgbScale + rgbScale $= 2 + combineRGB $= Replace' + drawAt 1 1 + + combineRGB $= Modulate' + drawAt 2 1 + rgbScale $= 1 + + -- reverse the order of subtraction Arg1-Arg0 + + textureFunction $= Combine + combineRGB $= Subtract + argRGB Arg0 $= Arg SrcColor Previous + argRGB Arg1 $= Arg SrcColor CurrentUnit + drawAt 5 1 + + activeTexture $= TextureUnit 1 -- deactivate multitexturing + texture Texture2D $= Disabled + activeTexture $= TextureUnit 0 -- activate single texture unit + + flush + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 7 0 7 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 400 400 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + texNamesAndDL <- myInit + displayCallback $= display texNamesAndDL + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Convolution.hs b/examples/RedBook4/Convolution.hs --- a/examples/RedBook4/Convolution.hs +++ b/examples/RedBook4/Convolution.hs @@ -1,83 +1,83 @@ -{- - Convolution.hs (adapted from convolution.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Use various 2D convolutions filters to find edges in an image. --} - -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT -import ReadImage - -data Filter = Filter String [GLfloat] - -filterTable :: [(Key,Filter)] -filterTable = [ - (Char 'h', Filter "horizontal" [ 0, -1, 0, - 0, 1, 0, - 0, 0, 0 ]), - - (Char 'v', Filter "vertical" [ 0, 0, 0, - -1, 1, 0, - 0, 0, 0 ]), - - (Char 'l', Filter "laplacian" [ -0.125, -0.125, -0.125, - -0.125, 1.0 , -0.125, - -0.125, -0.125, -0.125 ])] - -setFilter :: Filter -> IO () -setFilter (Filter filterName filterData) = do - putStrLn ("Using the " ++ filterName ++ " filter") - withArray filterData $ \buf -> - convolutionFilter2D Luminance' (Size 3 3) (PixelData Luminance Float buf) - -myInit :: IO () -myInit = do - rowAlignment Unpack $= 1 - clearColor $= Color4 0 0 0 0 - setFilter (snd (head filterTable)) - convolution Convolution2D $= Enabled - -display :: Size -> PixelData a -> DisplayCallback -display size pixels = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - rasterPos2i (Vertex2 1 1) - drawPixels size pixels - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard key Down _ _ = - maybe (return ()) - (\f -> do setFilter f; postRedisplay Nothing) - (lookup key filterTable) -keyboard _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, args) <- getArgsAndInitialize - (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) - initialDisplayMode $= [ SingleBuffered, RGBAMode ] - initialWindowSize $= size - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display size pixels - mainLoop +{- + Convolution.hs (adapted from convolution.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Use various 2D convolutions filters to find edges in an image. +-} + +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT +import ReadImage + +data Filter = Filter String [GLfloat] + +filterTable :: [(Key,Filter)] +filterTable = [ + (Char 'h', Filter "horizontal" [ 0, -1, 0, + 0, 1, 0, + 0, 0, 0 ]), + + (Char 'v', Filter "vertical" [ 0, 0, 0, + -1, 1, 0, + 0, 0, 0 ]), + + (Char 'l', Filter "laplacian" [ -0.125, -0.125, -0.125, + -0.125, 1.0 , -0.125, + -0.125, -0.125, -0.125 ])] + +setFilter :: Filter -> IO () +setFilter (Filter filterName filterData) = do + putStrLn ("Using the " ++ filterName ++ " filter") + withArray filterData $ \buf -> + convolutionFilter2D Luminance' (Size 3 3) (PixelData Luminance Float buf) + +myInit :: IO () +myInit = do + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + setFilter (snd (head filterTable)) + convolution Convolution2D $= Enabled + +display :: Size -> PixelData a -> DisplayCallback +display size pixels = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 1 1) + drawPixels size pixels + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard key Down _ _ = + maybe (return ()) + (\f -> do setFilter f; postRedisplay Nothing) + (lookup key filterTable) +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, args) <- getArgsAndInitialize + (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) + initialDisplayMode $= [ SingleBuffered, RGBAMode ] + initialWindowSize $= size + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display size pixels + mainLoop diff --git a/examples/RedBook4/Cube.hs b/examples/RedBook4/Cube.hs --- a/examples/RedBook4/Cube.hs +++ b/examples/RedBook4/Cube.hs @@ -1,56 +1,56 @@ -{- - Cube.hs (adapted from cube.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates a single modeling transformation, scale and a - single viewing transformation, lookAt. A wireframe cube is rendered. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () - color3f (Color3 1 1 1) - loadIdentity -- clear the matrix - -- viewing transformation - lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) - scalef 1 2 1 -- modeling transformation - renderObject Wireframe (Cube 1) - flush - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - frustum (-1) 1 (-1) 1 1.5 20 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Cube.hs (adapted from cube.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates a single modeling transformation, scale and a + single viewing transformation, lookAt. A wireframe cube is rendered. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () + color3f (Color3 1 1 1) + loadIdentity -- clear the matrix + -- viewing transformation + lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) + scalef 1 2 1 -- modeling transformation + renderObject Wireframe (Cube 1) + flush + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + frustum (-1) 1 (-1) 1 1.5 20 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/CubeMap.hs b/examples/RedBook4/CubeMap.hs --- a/examples/RedBook4/CubeMap.hs +++ b/examples/RedBook4/CubeMap.hs @@ -1,118 +1,118 @@ -{- - CubeMap.hs (adapted from CubeMap.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates cube map textures. Six different colored checker - board textures are created and applied to a lit sphere. - - Pressing the 'f' and 'b' keys translate the viewer forward and backward. --} - -import Data.Bits ( (.&.) ) -import Data.IORef ( IORef, newIORef ) -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { zTrans :: IORef GLfloat } - -makeState :: IO State -makeState = do - z <- newIORef 0 - return $ State { zTrans = z } - -imageSize :: TextureSize2D -imageSize = TextureSize2D 4 4 - -withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) - -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () -withCheckImage (TextureSize2D w h) n f act = - withArray [ f c | - i <- [ 0 .. w - 1 ], - j <- [ 0 .. h - 1 ], - let c | (i .&. n) == (j .&. n) = 0 - | otherwise = 255 ] $ - act. PixelData RGBA UnsignedByte - -makeImage :: TextureTargetCubeMapFace -> (GLubyte -> (Color4 GLubyte)) -> IO () -makeImage target f = - withCheckImage imageSize 0x1 f $ - texImage2D target NoProxy 0 RGBA' imageSize 0 - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - depthFunc $= Just Less - shadeModel $= Smooth - - rowAlignment Unpack $= 1 - textureWrapMode TextureCubeMap S $= (Repeated, Repeat) - textureWrapMode TextureCubeMap T $= (Repeated, Repeat) - textureWrapMode TextureCubeMap R $= (Repeated, Repeat) - textureFilter TextureCubeMap $= ((Nearest, Nothing), Nearest) - - makeImage TextureCubeMapPositiveX (\c -> Color4 c c c 255) - makeImage TextureCubeMapNegativeX (\c -> Color4 0 c c 255) - makeImage TextureCubeMapPositiveY (\c -> Color4 c c 0 255) - makeImage TextureCubeMapNegativeY (\c -> Color4 255 c c 255) - makeImage TextureCubeMapPositiveZ (\c -> Color4 c 0 c 255) - makeImage TextureCubeMapNegativeZ (\c -> Color4 c c 255 255) - - textureGenMode S $= Just NormalMap - textureGenMode T $= Just NormalMap - textureGenMode R $= Just NormalMap - - textureFunction $= Modulate - - texture TextureCubeMap $= Enabled - lighting $= Enabled - light (Light 0) $= Enabled - autoNormal $= Enabled - normalize $= Enabled - materialDiffuse Front $= Color4 1 1 1 1 - -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - z <- get (zTrans state) - translate (Vector3 0 0 z) - renderObject Solid (Sphere' 5 20 10) - swapBuffers - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 40 (fromIntegral w / fromIntegral h) 1 300 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-20 :: GLfloat)) - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char 'f') Down _ _ = move state (-0.2) -keyboard state (Char 'b') Down _ _ = move state 0.2 -keyboard _ (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ _ = return () - -move :: State -> GLfloat -> IO () -move state inc = do - zTrans state $~ (+ inc) - postRedisplay Nothing - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 400 400 - initialWindowPosition $= Position 50 50 - _ <- createWindow progName - state <- makeState - myInit - displayCallback $= display state - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - mainLoop +{- + CubeMap.hs (adapted from CubeMap.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates cube map textures. Six different colored checker + board textures are created and applied to a lit sphere. + + Pressing the 'f' and 'b' keys translate the viewer forward and backward. +-} + +import Data.Bits ( (.&.) ) +import Data.IORef ( IORef, newIORef ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { zTrans :: IORef GLfloat } + +makeState :: IO State +makeState = do + z <- newIORef 0 + return $ State { zTrans = z } + +imageSize :: TextureSize2D +imageSize = TextureSize2D 4 4 + +withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) + -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () +withCheckImage (TextureSize2D w h) n f act = + withArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] $ + act. PixelData RGBA UnsignedByte + +makeImage :: TextureTargetCubeMapFace -> (GLubyte -> (Color4 GLubyte)) -> IO () +makeImage target f = + withCheckImage imageSize 0x1 f $ + texImage2D target NoProxy 0 RGBA' imageSize 0 + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + depthFunc $= Just Less + shadeModel $= Smooth + + rowAlignment Unpack $= 1 + textureWrapMode TextureCubeMap S $= (Repeated, Repeat) + textureWrapMode TextureCubeMap T $= (Repeated, Repeat) + textureWrapMode TextureCubeMap R $= (Repeated, Repeat) + textureFilter TextureCubeMap $= ((Nearest, Nothing), Nearest) + + makeImage TextureCubeMapPositiveX (\c -> Color4 c c c 255) + makeImage TextureCubeMapNegativeX (\c -> Color4 0 c c 255) + makeImage TextureCubeMapPositiveY (\c -> Color4 c c 0 255) + makeImage TextureCubeMapNegativeY (\c -> Color4 255 c c 255) + makeImage TextureCubeMapPositiveZ (\c -> Color4 c 0 c 255) + makeImage TextureCubeMapNegativeZ (\c -> Color4 c c 255 255) + + textureGenMode S $= Just NormalMap + textureGenMode T $= Just NormalMap + textureGenMode R $= Just NormalMap + + textureFunction $= Modulate + + texture TextureCubeMap $= Enabled + lighting $= Enabled + light (Light 0) $= Enabled + autoNormal $= Enabled + normalize $= Enabled + materialDiffuse Front $= Color4 1 1 1 1 + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + z <- get (zTrans state) + translate (Vector3 0 0 z) + renderObject Solid (Sphere' 5 20 10) + swapBuffers + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 40 (fromIntegral w / fromIntegral h) 1 300 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-20 :: GLfloat)) + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char 'f') Down _ _ = move state (-0.2) +keyboard state (Char 'b') Down _ _ = move state 0.2 +keyboard _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ _ = return () + +move :: State -> GLfloat -> IO () +move state inc = do + zTrans state $~ (+ inc) + postRedisplay Nothing + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 400 400 + initialWindowPosition $= Position 50 50 + _ <- createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + mainLoop diff --git a/examples/RedBook4/DList.hs b/examples/RedBook4/DList.hs --- a/examples/RedBook4/DList.hs +++ b/examples/RedBook4/DList.hs @@ -1,85 +1,85 @@ -{- - DList.hs (adapted from list.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates how to make and execute a - display list. Note that attributes, such as current - color and matrix, are changed. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO DisplayList -myInit = do - listName <- genObjectName - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - vertex2f = vertex :: Vertex2 GLfloat -> IO () - translatef = translate :: Vector3 GLfloat -> IO () - defineList listName Compile $ do - color3f (Color3 1 0 0) -- current color red - renderPrimitive Triangles $ do - vertex2f (Vertex2 0 0) - vertex2f (Vertex2 1 0) - vertex2f (Vertex2 0 1) - translatef (Vector3 1.5 0.0 0.0) -- move position - shadeModel $= Flat - return listName - -drawLine :: IO () -drawLine = do - -- resolve overloading, not needed in "real" programs - let vertex2f = vertex :: Vertex2 GLfloat -> IO () - renderPrimitive Lines $ do - vertex2f (Vertex2 0.0 0.5) - vertex2f (Vertex2 15.0 0.5) - -display :: DisplayList -> DisplayCallback -display listName = do - -- NOTE: The following 'loadIdentity' is missing in the original - -- example, but without it the translatef calls accumulate and - -- the graphics wander out of the window after a few redraws... - loadIdentity - - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - color3f (Color3 0 1 0) -- current color green - sequence_ (replicate 10 (callList listName)) -- draw 10 triangles - drawLine -- is this line green? NO! - -- where is the line drawn? - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho2D 0.0 2.0 (-0.5*hf/wf) (1.5*hf/wf) - else ortho2D 0.0 (2.0*wf/hf) (-0.5) 1.5 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Open window with initial window size, title bar, --- RGBA display mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 650 50 - _ <- createWindow progName - listName <- myInit - reshapeCallback $= Just reshape - displayCallback $= display listName - keyboardMouseCallback $= Just keyboard - mainLoop +{- + DList.hs (adapted from list.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates how to make and execute a + display list. Note that attributes, such as current + color and matrix, are changed. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO DisplayList +myInit = do + listName <- genObjectName + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + vertex2f = vertex :: Vertex2 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + defineList listName Compile $ do + color3f (Color3 1 0 0) -- current color red + renderPrimitive Triangles $ do + vertex2f (Vertex2 0 0) + vertex2f (Vertex2 1 0) + vertex2f (Vertex2 0 1) + translatef (Vector3 1.5 0.0 0.0) -- move position + shadeModel $= Flat + return listName + +drawLine :: IO () +drawLine = do + -- resolve overloading, not needed in "real" programs + let vertex2f = vertex :: Vertex2 GLfloat -> IO () + renderPrimitive Lines $ do + vertex2f (Vertex2 0.0 0.5) + vertex2f (Vertex2 15.0 0.5) + +display :: DisplayList -> DisplayCallback +display listName = do + -- NOTE: The following 'loadIdentity' is missing in the original + -- example, but without it the translatef calls accumulate and + -- the graphics wander out of the window after a few redraws... + loadIdentity + + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 0 1 0) -- current color green + sequence_ (replicate 10 (callList listName)) -- draw 10 triangles + drawLine -- is this line green? NO! + -- where is the line drawn? + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D 0.0 2.0 (-0.5*hf/wf) (1.5*hf/wf) + else ortho2D 0.0 (2.0*wf/hf) (-0.5) 1.5 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Open window with initial window size, title bar, +-- RGBA display mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 650 50 + _ <- createWindow progName + listName <- myInit + reshapeCallback $= Just reshape + displayCallback $= display listName + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/DOF.hs b/examples/RedBook4/DOF.hs --- a/examples/RedBook4/DOF.hs +++ b/examples/RedBook4/DOF.hs @@ -1,182 +1,182 @@ -{- - DOF.hs (adapted from dof.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates use of the accumulation buffer to create an - out-of-focus depth-of-field effect. The teapots are drawn several times into - the accumulation buffer. The viewing volume is jittered, except at the focal - point, where the viewing volume is at the same position, each time. In this - case, the gold teapot remains in focus. --} - -import Data.List ( genericLength ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a --- gaussian distribution around the origin. Use these to do model jittering for --- scene anti-aliasing and view volume jittering for depth of field effects. Use --- in conjunction with the accwindow routine. -j8 :: [Vector2 GLdouble] -j8 = [ - Vector2 (-0.334818) 0.435331 , - Vector2 0.286438 (-0.393495), - Vector2 0.459462 0.141540 , - Vector2 (-0.414498) (-0.192829), - Vector2 (-0.183790) 0.082102 , - Vector2 (-0.079263) (-0.317383), - Vector2 0.102254 0.299133 , - Vector2 0.164216 (-0.054399) ] - --- The first 6 arguments are identical to the frustum call. pixD is anti-alias --- jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD is --- depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field --- effects. focus is distance from eye to plane in focus. focus must be greater --- than, but not equal to 0. Note that accFrustum calls translate. You will --- probably want to insure that your ModelView matrix has been initialized to --- identity before calling accFrustum. -accFrustum :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble - -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () -accFrustum left right bottom top zNear zFar - (Vector2 pixDx pixDy) (Vector2 eyeDx eyeDy) focus = do - (_, Size w h) <- get viewport - - let xWSize = right - left; - yWSize = top - bottom; - - dx = -(pixDx * xWSize / fromIntegral w + eyeDx * zNear / focus) - dy = -(pixDy * yWSize / fromIntegral h + eyeDy * zNear / focus) - - matrixMode $= Projection - loadIdentity - frustum (left + dx) (right + dx) (bottom + dy) (top + dy) zNear zFar - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 (-eyeDx) (-eyeDy) 0) - --- The first 4 arguments are identical to the perspective call. pixD is --- anti-alias jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD --- is depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field --- effects. focus is distance from eye to plane in focus. focus must be greater --- than, but not equal to 0. Note that accPerspective calls accFrustum. -accPerspective :: GLdouble -> GLdouble -> GLdouble -> GLdouble - -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () -accPerspective fovY aspect zNear zFar pixD eyeD focus = do - let fov2 = ((fovY * pi) / 180) / 2 - - top = zNear / (cos fov2 / sin fov2) - bottom = -top - - right = top * aspect - left = -right - - accFrustum left right bottom top zNear zFar pixD eyeD focus - -myInit :: IO DisplayList -myInit = do - ambient (Light 0) $= Color4 0 0 0 1 - diffuse (Light 0) $= Color4 1 1 1 1 - position (Light 0) $= Vertex4 0 3 3 0 - - lightModelAmbient $= Color4 0.2 0.2 0.2 1 - lightModelLocalViewer $= Disabled - - frontFace $= CW - lighting $= Enabled - light (Light 0) $= Enabled - autoNormal $= Enabled - normalize $= Enabled - depthFunc $= Just Less - - clearColor $= Color4 0 0 0 0 - clearAccum $= Color4 0 0 0 0 - -- make teapot display list - defineNewList Compile $ - renderObject Solid (Teapot 0.5) - --- Move object into position, specify the material properties, draw a teapot. -renderTeapot :: DisplayList -> Vector3 GLfloat -> Color4 GLfloat - -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> IO () -renderTeapot teapotList pos amb dif spec shine = - preservingMatrix $ do - translate pos - materialAmbient Front $= amb - materialDiffuse Front $= dif - materialSpecular Front $= spec - materialShininess Front $= shine * 128 - callList teapotList - --- display draws 5 teapots into the accumulation buffer several times; each time --- with a jittered perspective. The focal point is at z = 5.0, so the gold --- teapot will stay in focus. The amount of jitter is adjusted by the magnitude --- of the accPerspective jitter; in this example, 0.33. In this example, the --- teapots are drawn 8 times. -display :: DisplayList -> DisplayCallback -display teapotList = do - (_, Size w h) <- get viewport - clear [ AccumBuffer ] - - flip mapM_ j8 $ \(Vector2 x y) -> do - clear [ ColorBuffer, DepthBuffer ] - accPerspective 45 (fromIntegral w / fromIntegral h) 1 15 - (Vector2 0 0) (Vector2 (0.33 * x) (0.33 * y)) 5 - - -- ruby, gold, silver, emerald, and cyan teapots - renderTeapot teapotList - (Vector3 (-1.1) (-0.5) (-4.5)) - (Color4 0.1745 0.01175 0.01175 1) - (Color4 0.61424 0.04136 0.04136 1) - (Color4 0.727811 0.626959 0.626959 1) - 0.6 - renderTeapot teapotList - (Vector3 (-0.5) (-0.5) (-5.0)) - (Color4 0.24725 0.1995 0.0745 1) - (Color4 0.75164 0.60648 0.22648 1) - (Color4 0.628281 0.555802 0.366065 1) - 0.4 - renderTeapot teapotList - (Vector3 0.2 (-0.5) (-5.5)) - (Color4 0.19225 0.19225 0.19225 1) - (Color4 0.50754 0.50754 0.50754 1) - (Color4 0.508273 0.508273 0.508273 1) - 0.4 - renderTeapot teapotList - (Vector3 1.0 (-0.5) (-6.0)) - (Color4 0.0215 0.1745 0.0215 1) - (Color4 0.07568 0.61424 0.07568 1) - (Color4 0.633 0.727811 0.633 1) - 0.6 - renderTeapot teapotList - (Vector3 1.8 (-0.5) (-6.5)) - (Color4 0.0 0.1 0.06 1) - (Color4 0.0 0.50980392 0.50980392 1) - (Color4 0.50196078 0.50196078 0.50196078 1) - 0.25 - accum Accum (recip (genericLength j8)) - - accum Return 1 - flush - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Be certain you request an accumulation buffer. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ] - initialWindowSize $= Size 400 400 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - teapotList <- myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display teapotList - mainLoop +{- + DOF.hs (adapted from dof.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates use of the accumulation buffer to create an + out-of-focus depth-of-field effect. The teapots are drawn several times into + the accumulation buffer. The viewing volume is jittered, except at the focal + point, where the viewing volume is at the same position, each time. In this + case, the gold teapot remains in focus. +-} + +import Data.List ( genericLength ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a +-- gaussian distribution around the origin. Use these to do model jittering for +-- scene anti-aliasing and view volume jittering for depth of field effects. Use +-- in conjunction with the accwindow routine. +j8 :: [Vector2 GLdouble] +j8 = [ + Vector2 (-0.334818) 0.435331 , + Vector2 0.286438 (-0.393495), + Vector2 0.459462 0.141540 , + Vector2 (-0.414498) (-0.192829), + Vector2 (-0.183790) 0.082102 , + Vector2 (-0.079263) (-0.317383), + Vector2 0.102254 0.299133 , + Vector2 0.164216 (-0.054399) ] + +-- The first 6 arguments are identical to the frustum call. pixD is anti-alias +-- jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD is +-- depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field +-- effects. focus is distance from eye to plane in focus. focus must be greater +-- than, but not equal to 0. Note that accFrustum calls translate. You will +-- probably want to insure that your ModelView matrix has been initialized to +-- identity before calling accFrustum. +accFrustum :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble + -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () +accFrustum left right bottom top zNear zFar + (Vector2 pixDx pixDy) (Vector2 eyeDx eyeDy) focus = do + (_, Size w h) <- get viewport + + let xWSize = right - left; + yWSize = top - bottom; + + dx = -(pixDx * xWSize / fromIntegral w + eyeDx * zNear / focus) + dy = -(pixDy * yWSize / fromIntegral h + eyeDy * zNear / focus) + + matrixMode $= Projection + loadIdentity + frustum (left + dx) (right + dx) (bottom + dy) (top + dy) zNear zFar + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 (-eyeDx) (-eyeDy) 0) + +-- The first 4 arguments are identical to the perspective call. pixD is +-- anti-alias jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD +-- is depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field +-- effects. focus is distance from eye to plane in focus. focus must be greater +-- than, but not equal to 0. Note that accPerspective calls accFrustum. +accPerspective :: GLdouble -> GLdouble -> GLdouble -> GLdouble + -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () +accPerspective fovY aspect zNear zFar pixD eyeD focus = do + let fov2 = ((fovY * pi) / 180) / 2 + + top = zNear / (cos fov2 / sin fov2) + bottom = -top + + right = top * aspect + left = -right + + accFrustum left right bottom top zNear zFar pixD eyeD focus + +myInit :: IO DisplayList +myInit = do + ambient (Light 0) $= Color4 0 0 0 1 + diffuse (Light 0) $= Color4 1 1 1 1 + position (Light 0) $= Vertex4 0 3 3 0 + + lightModelAmbient $= Color4 0.2 0.2 0.2 1 + lightModelLocalViewer $= Disabled + + frontFace $= CW + lighting $= Enabled + light (Light 0) $= Enabled + autoNormal $= Enabled + normalize $= Enabled + depthFunc $= Just Less + + clearColor $= Color4 0 0 0 0 + clearAccum $= Color4 0 0 0 0 + -- make teapot display list + defineNewList Compile $ + renderObject Solid (Teapot 0.5) + +-- Move object into position, specify the material properties, draw a teapot. +renderTeapot :: DisplayList -> Vector3 GLfloat -> Color4 GLfloat + -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> IO () +renderTeapot teapotList pos amb dif spec shine = + preservingMatrix $ do + translate pos + materialAmbient Front $= amb + materialDiffuse Front $= dif + materialSpecular Front $= spec + materialShininess Front $= shine * 128 + callList teapotList + +-- display draws 5 teapots into the accumulation buffer several times; each time +-- with a jittered perspective. The focal point is at z = 5.0, so the gold +-- teapot will stay in focus. The amount of jitter is adjusted by the magnitude +-- of the accPerspective jitter; in this example, 0.33. In this example, the +-- teapots are drawn 8 times. +display :: DisplayList -> DisplayCallback +display teapotList = do + (_, Size w h) <- get viewport + clear [ AccumBuffer ] + + flip mapM_ j8 $ \(Vector2 x y) -> do + clear [ ColorBuffer, DepthBuffer ] + accPerspective 45 (fromIntegral w / fromIntegral h) 1 15 + (Vector2 0 0) (Vector2 (0.33 * x) (0.33 * y)) 5 + + -- ruby, gold, silver, emerald, and cyan teapots + renderTeapot teapotList + (Vector3 (-1.1) (-0.5) (-4.5)) + (Color4 0.1745 0.01175 0.01175 1) + (Color4 0.61424 0.04136 0.04136 1) + (Color4 0.727811 0.626959 0.626959 1) + 0.6 + renderTeapot teapotList + (Vector3 (-0.5) (-0.5) (-5.0)) + (Color4 0.24725 0.1995 0.0745 1) + (Color4 0.75164 0.60648 0.22648 1) + (Color4 0.628281 0.555802 0.366065 1) + 0.4 + renderTeapot teapotList + (Vector3 0.2 (-0.5) (-5.5)) + (Color4 0.19225 0.19225 0.19225 1) + (Color4 0.50754 0.50754 0.50754 1) + (Color4 0.508273 0.508273 0.508273 1) + 0.4 + renderTeapot teapotList + (Vector3 1.0 (-0.5) (-6.0)) + (Color4 0.0215 0.1745 0.0215 1) + (Color4 0.07568 0.61424 0.07568 1) + (Color4 0.633 0.727811 0.633 1) + 0.6 + renderTeapot teapotList + (Vector3 1.8 (-0.5) (-6.5)) + (Color4 0.0 0.1 0.06 1) + (Color4 0.0 0.50980392 0.50980392 1) + (Color4 0.50196078 0.50196078 0.50196078 1) + 0.25 + accum Accum (recip (genericLength j8)) + + accum Return 1 + flush + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Be certain you request an accumulation buffer. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ] + initialWindowSize $= Size 400 400 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + teapotList <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display teapotList + mainLoop diff --git a/examples/RedBook4/Double.hs b/examples/RedBook4/Double.hs --- a/examples/RedBook4/Double.hs +++ b/examples/RedBook4/Double.hs @@ -1,76 +1,76 @@ -{- - Double.hs (adapted from double.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This is a simple double buffered program. - Pressing the left mouse button rotates the rectangle. - Pressing the middle mouse button stops the rotation. --} - -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { spin :: IORef GLfloat } - -makeState :: IO State -makeState = do - s <- newIORef 0 - return $ State { spin = s } - -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer ] - preservingMatrix $ do - s <- get (spin state) - rotate s (Vector3 0 0 1) - color (Color3 1 1 1 :: Color3 GLfloat) - rect (Vertex2 (-25) (-25)) (Vertex2 25 25 :: Vertex2 GLfloat) - swapBuffers - -spinDisplay :: State -> IdleCallback -spinDisplay state = do - let wrap n s = if s > n then s - n else s - spin state $~ (wrap 360 . (+ 2)) - postRedisplay Nothing - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho (-50) 50 (-50) 50 (-1) 1 - matrixMode $= Modelview 0 - loadIdentity - -keyboardMouse :: State -> KeyboardMouseCallback -keyboardMouse state (MouseButton b) Down _ _ = - idleCallback $= case b of - LeftButton -> Just (spinDisplay state) - _ -> Nothing --- ESC not handled in the original example, but useful nevertheless -keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess -keyboardMouse _ _ _ _ _ = return () - --- Request double buffer display mode. --- Register mouse input callback functions -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ DoubleBuffered, RGBMode ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - state <- makeState - myInit - displayCallback $= display state - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboardMouse state) - mainLoop +{- + Double.hs (adapted from double.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This is a simple double buffered program. + Pressing the left mouse button rotates the rectangle. + Pressing the middle mouse button stops the rotation. +-} + +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { spin :: IORef GLfloat } + +makeState :: IO State +makeState = do + s <- newIORef 0 + return $ State { spin = s } + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + preservingMatrix $ do + s <- get (spin state) + rotate s (Vector3 0 0 1) + color (Color3 1 1 1 :: Color3 GLfloat) + rect (Vertex2 (-25) (-25)) (Vertex2 25 25 :: Vertex2 GLfloat) + swapBuffers + +spinDisplay :: State -> IdleCallback +spinDisplay state = do + let wrap n s = if s > n then s - n else s + spin state $~ (wrap 360 . (+ 2)) + postRedisplay Nothing + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho (-50) 50 (-50) 50 (-1) 1 + matrixMode $= Modelview 0 + loadIdentity + +keyboardMouse :: State -> KeyboardMouseCallback +keyboardMouse state (MouseButton b) Down _ _ = + idleCallback $= case b of + LeftButton -> Just (spinDisplay state) + _ -> Nothing +-- ESC not handled in the original example, but useful nevertheless +keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboardMouse _ _ _ _ _ = return () + +-- Request double buffer display mode. +-- Register mouse input callback functions +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboardMouse state) + mainLoop diff --git a/examples/RedBook4/DrawF.hs b/examples/RedBook4/DrawF.hs --- a/examples/RedBook4/DrawF.hs +++ b/examples/RedBook4/DrawF.hs @@ -1,62 +1,62 @@ -{- - DrawF.hs (adapted from drawf.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Draws the bitmapped letter F on the screen (several times). - This demonstrates use of the bitmap call. --} - -import Foreign ( Ptr, newArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO (Ptr GLubyte) -myInit = do - rowAlignment Unpack $= 1 - clearColor $= Color4 0 0 0 0 - newArray [ - 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, - 0xff, 0x00, 0xff, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, - 0xff, 0xc0, 0xff, 0xc0 ] - -display :: Ptr GLubyte -> DisplayCallback -display rasters = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - color3f (Color3 1 1 1) - rasterPos2i (Vertex2 20 20) - sequence_ $ replicate 3 $ - bitmap (Size 10 12) (Vertex2 0 0) (Vector2 11 0) rasters - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop --- Open window with initial window size, title bar, --- RGBA display mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 100 100 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - rasters <- myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display rasters - mainLoop +{- + DrawF.hs (adapted from drawf.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Draws the bitmapped letter F on the screen (several times). + This demonstrates use of the bitmap call. +-} + +import Foreign ( Ptr, newArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO (Ptr GLubyte) +myInit = do + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + newArray [ + 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, + 0xff, 0x00, 0xff, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, + 0xff, 0xc0, 0xff, 0xc0 ] + +display :: Ptr GLubyte -> DisplayCallback +display rasters = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + color3f (Color3 1 1 1) + rasterPos2i (Vertex2 20 20) + sequence_ $ replicate 3 $ + bitmap (Size 10 12) (Vertex2 0 0) (Vector2 11 0) rasters + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop +-- Open window with initial window size, title bar, +-- RGBA display mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 100 100 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + rasters <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display rasters + mainLoop diff --git a/examples/RedBook4/Feedback.hs b/examples/RedBook4/Feedback.hs --- a/examples/RedBook4/Feedback.hs +++ b/examples/RedBook4/Feedback.hs @@ -1,77 +1,77 @@ -{- - Feedback.hs (adapted from feedback.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates use of OpenGL feedback. First, a lighting - environment is set up and a few lines are drawn. Then feedback mode is - entered, and the same lines are drawn. The results in the feedback buffer are - printed. --} - -import Control.Monad ( when ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Initialize lighting. -myInit :: IO () -myInit = do - lighting $= Enabled - light (Light 0) $= Enabled - --- Draw a few lines and two points, one of which will be clipped. If in feedback --- mode, a passthrough token is issued between each primitive -drawGeometry :: IO () -drawGeometry = do - mode <- get renderMode - -- resolve overloading, not needed in "real" programs - let normal3f = normal :: Normal3 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - renderPrimitive LineStrip $ do - normal3f (Normal3 0 0 1) - vertex3f (Vertex3 30 30 0) - vertex3f (Vertex3 50 60 0) - vertex3f (Vertex3 70 40 0) - when (mode == Feedback) $ - passThrough (PassThroughValue 1) - renderPrimitive Points $ - vertex3f (Vertex3 (-100) (-100) (-100)) -- will be clipped - when (mode == Feedback) $ - passThrough (PassThroughValue 2) - renderPrimitive Points $ do - normal3f (Normal3 0 0 1) - vertex3f (Vertex3 50 50 0) - flush -- not in original example - -printBuffer :: Maybe [FeedbackToken] -> IO () -printBuffer = maybe (putStrLn "feedback buffer overflow") (mapM_ print) - -display :: DisplayCallback -display = do - matrixMode $= Projection - loadIdentity - ortho 0 100 0 100 0 1 - - clearColor $= Color4 0 0 0 0 - clear [ ColorBuffer ] - drawGeometry - - (_, tokens) <- getFeedbackTokens 1024 ThreeDColor drawGeometry - printBuffer tokens - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 100 100 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Feedback.hs (adapted from feedback.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates use of OpenGL feedback. First, a lighting + environment is set up and a few lines are drawn. Then feedback mode is + entered, and the same lines are drawn. The results in the feedback buffer are + printed. +-} + +import Control.Monad ( when ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Initialize lighting. +myInit :: IO () +myInit = do + lighting $= Enabled + light (Light 0) $= Enabled + +-- Draw a few lines and two points, one of which will be clipped. If in feedback +-- mode, a passthrough token is issued between each primitive +drawGeometry :: IO () +drawGeometry = do + mode <- get renderMode + -- resolve overloading, not needed in "real" programs + let normal3f = normal :: Normal3 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive LineStrip $ do + normal3f (Normal3 0 0 1) + vertex3f (Vertex3 30 30 0) + vertex3f (Vertex3 50 60 0) + vertex3f (Vertex3 70 40 0) + when (mode == Feedback) $ + passThrough (PassThroughValue 1) + renderPrimitive Points $ + vertex3f (Vertex3 (-100) (-100) (-100)) -- will be clipped + when (mode == Feedback) $ + passThrough (PassThroughValue 2) + renderPrimitive Points $ do + normal3f (Normal3 0 0 1) + vertex3f (Vertex3 50 50 0) + flush -- not in original example + +printBuffer :: Maybe [FeedbackToken] -> IO () +printBuffer = maybe (putStrLn "feedback buffer overflow") (mapM_ print) + +display :: DisplayCallback +display = do + matrixMode $= Projection + loadIdentity + ortho 0 100 0 100 0 1 + + clearColor $= Color4 0 0 0 0 + clear [ ColorBuffer ] + drawGeometry + + (_, tokens) <- getFeedbackTokens 1024 ThreeDColor drawGeometry + printBuffer tokens + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 100 100 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Fog.hs b/examples/RedBook4/Fog.hs --- a/examples/RedBook4/Fog.hs +++ b/examples/RedBook4/Fog.hs @@ -1,90 +1,90 @@ -{- - Fog.hs (adapted from fog.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws 5 red spheres, each at a different z distance from the - eye, in different types of fog. Pressing the f key chooses between 3 types - of fog: exponential, exponential squared, and linear. In this program, there - is a fixed density value, as well as fixed start and end values for the - linear fog. --} - -import Data.Char ( toLower ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - depthFunc $= Just Less - - position (Light 0) $= Vertex4 0.5 0.5 3.0 0.0 - lighting $= Enabled - light (Light 0) $= Enabled - - -- NOTE: The alpha values are missing from fog.c! - materialAmbient Front $= Color4 0.1745 0.01175 0.01175 1.0 - materialDiffuse Front $= Color4 0.61424 0.04136 0.04136 1.0 - materialSpecular Front $= Color4 0.727811 0.626959 0.626959 1.0 - materialShininess Front $= 0.6 * 128 - - fog $= Enabled - let c = Color4 0.5 0.5 0.5 1.0 - fogMode $= Exp 0.35 - fogColor $= c - hint Fog $= DontCare - clearColor $= c - -renderSpehere :: Vector3 GLfloat -> IO () -renderSpehere xyz = - preservingMatrix $ do - translate xyz - renderObject Solid (Sphere' 0.4 16 16) - --- display draws 5 spheres at different z positions. -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - mapM_ renderSpehere [ Vector3 x (-0.5) (-3 - x) | x <- [-2 .. 2] ] - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10.0) 10.0 - else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10.0) 10.0 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char c) Down _ _ = case toLower c of - 'f' -> do - mode <- get fogMode - case mode of - Linear _ _ -> do fogMode $= Exp 0.35; putStrLn "Fog mode is Exp" - Exp _ -> do fogMode $= Exp2 0.35; putStrLn "Fog mode is Exp2" - Exp2 _ -> do fogMode $= Linear 1 5; putStrLn "Fog mode is Linear" - postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, depth buffer, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - _ <- createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display - mainLoop +{- + Fog.hs (adapted from fog.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws 5 red spheres, each at a different z distance from the + eye, in different types of fog. Pressing the f key chooses between 3 types + of fog: exponential, exponential squared, and linear. In this program, there + is a fixed density value, as well as fixed start and end values for the + linear fog. +-} + +import Data.Char ( toLower ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + depthFunc $= Just Less + + position (Light 0) $= Vertex4 0.5 0.5 3.0 0.0 + lighting $= Enabled + light (Light 0) $= Enabled + + -- NOTE: The alpha values are missing from fog.c! + materialAmbient Front $= Color4 0.1745 0.01175 0.01175 1.0 + materialDiffuse Front $= Color4 0.61424 0.04136 0.04136 1.0 + materialSpecular Front $= Color4 0.727811 0.626959 0.626959 1.0 + materialShininess Front $= 0.6 * 128 + + fog $= Enabled + let c = Color4 0.5 0.5 0.5 1.0 + fogMode $= Exp 0.35 + fogColor $= c + hint Fog $= DontCare + clearColor $= c + +renderSpehere :: Vector3 GLfloat -> IO () +renderSpehere xyz = + preservingMatrix $ do + translate xyz + renderObject Solid (Sphere' 0.4 16 16) + +-- display draws 5 spheres at different z positions. +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + mapM_ renderSpehere [ Vector3 x (-0.5) (-3 - x) | x <- [-2 .. 2] ] + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10.0) 10.0 + else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10.0) 10.0 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char c) Down _ _ = case toLower c of + 'f' -> do + mode <- get fogMode + case mode of + Linear _ _ -> do fogMode $= Exp 0.35; putStrLn "Fog mode is Exp" + Exp _ -> do fogMode $= Exp2 0.35; putStrLn "Fog mode is Exp2" + Exp2 _ -> do fogMode $= Linear 1 5; putStrLn "Fog mode is Linear" + postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, depth buffer, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display + mainLoop diff --git a/examples/RedBook4/FogCoord.hs b/examples/RedBook4/FogCoord.hs --- a/examples/RedBook4/FogCoord.hs +++ b/examples/RedBook4/FogCoord.hs @@ -1,122 +1,122 @@ -{- - FogCoord.hs (adapted from fogcoord.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates the use of explicit fog coordinates. You can press - the keyboard and change the fog coordinate value at any vertex. You can also - switch between using explicit fog coordinates and the default fog generation - mode. - - Pressing the 'f' and 'b' keys move the viewer forward and backwards. Pressing - 'c' initiates the default fog generation. Pressing capital 'C' restores - explicit fog coordinates. Pressing '1', '2', '3', '8', '9', and '0' add or - subtract from the fog coordinate values at one of the three vertices of the - triangle. --} - -import Control.Monad ( when ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { f1, f2, f3 :: IORef (FogCoord1 GLfloat) } - -makeState :: IO State -makeState = do - f1' <- newIORef (FogCoord1 1) - f2' <- newIORef (FogCoord1 5) - f3' <- newIORef (FogCoord1 10) - return $ State { f1 = f1', f2 = f2', f3 = f3' } - --- Initialize fog -myInit :: IO () -myInit = do - let theFogColor = Color4 0 0.25 0.25 1 - fog $= Enabled - fogMode $= Exp 0.25 - fogColor $= theFogColor - hint Fog $= DontCare - fogCoordSrc $= FogCoord - clearColor $= theFogColor - -drawTriangle :: State -> (State -> IORef (FogCoord1 GLfloat)) -> Vertex3 GLfloat -> IO () -drawTriangle state f v = do - fc <- get (f state) - fogCoord fc - vertex v - --- display draws a triangle at an angle. -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer ] - - color (Color3 1 0.75 (0 :: GLfloat)) - renderPrimitive Triangles $ do - drawTriangle state f1 (Vertex3 2 (-2) 0 ) - drawTriangle state f2 (Vertex3 (-2) 0 (-5)) - drawTriangle state f3 (Vertex3 0 2 (-10)) - - swapBuffers - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 45 1 0.25 25 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-5 :: GLfloat)) - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case c of - 'c' -> setSrc FragmentDepth - 'C' -> setSrc FogCoord - '1' -> inc f1 0.25 - '2' -> inc f2 0.25 - '3' -> inc f3 0.25 - '8' -> inc f1 (-0.25) - '9' -> inc f2 (-0.25) - '0' -> inc f3 (-0.25) - 'b' -> trans (-0.25) - 'f' -> trans 0.25 - '\27' -> exitWith ExitSuccess - _ -> return () - where setSrc :: FogCoordSrc -> IO () - setSrc s = do - fogCoordSrc $= s - postRedisplay Nothing - - inc :: (State -> IORef (FogCoord1 GLfloat)) -> GLfloat -> IO () - inc f x = do - FogCoord1 oldValue <- get (f state) - let newValue = oldValue + x - when (newValue > 0) $ do - f state $= FogCoord1 newValue - postRedisplay Nothing - - trans :: GLfloat -> IO () - trans x = do - matrixMode $= Modelview 0 - translate (Vector3 0 0 x) - postRedisplay Nothing -keyboard _ _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ DoubleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - _ <- createWindow progName - state <- makeState - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - displayCallback $= display state - mainLoop - - +{- + FogCoord.hs (adapted from fogcoord.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the use of explicit fog coordinates. You can press + the keyboard and change the fog coordinate value at any vertex. You can also + switch between using explicit fog coordinates and the default fog generation + mode. + + Pressing the 'f' and 'b' keys move the viewer forward and backwards. Pressing + 'c' initiates the default fog generation. Pressing capital 'C' restores + explicit fog coordinates. Pressing '1', '2', '3', '8', '9', and '0' add or + subtract from the fog coordinate values at one of the three vertices of the + triangle. +-} + +import Control.Monad ( when ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { f1, f2, f3 :: IORef (FogCoord1 GLfloat) } + +makeState :: IO State +makeState = do + f1' <- newIORef (FogCoord1 1) + f2' <- newIORef (FogCoord1 5) + f3' <- newIORef (FogCoord1 10) + return $ State { f1 = f1', f2 = f2', f3 = f3' } + +-- Initialize fog +myInit :: IO () +myInit = do + let theFogColor = Color4 0 0.25 0.25 1 + fog $= Enabled + fogMode $= Exp 0.25 + fogColor $= theFogColor + hint Fog $= DontCare + fogCoordSrc $= FogCoord + clearColor $= theFogColor + +drawTriangle :: State -> (State -> IORef (FogCoord1 GLfloat)) -> Vertex3 GLfloat -> IO () +drawTriangle state f v = do + fc <- get (f state) + fogCoord fc + vertex v + +-- display draws a triangle at an angle. +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + + color (Color3 1 0.75 (0 :: GLfloat)) + renderPrimitive Triangles $ do + drawTriangle state f1 (Vertex3 2 (-2) 0 ) + drawTriangle state f2 (Vertex3 (-2) 0 (-5)) + drawTriangle state f3 (Vertex3 0 2 (-10)) + + swapBuffers + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 45 1 0.25 25 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-5 :: GLfloat)) + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case c of + 'c' -> setSrc FragmentDepth + 'C' -> setSrc FogCoord + '1' -> inc f1 0.25 + '2' -> inc f2 0.25 + '3' -> inc f3 0.25 + '8' -> inc f1 (-0.25) + '9' -> inc f2 (-0.25) + '0' -> inc f3 (-0.25) + 'b' -> trans (-0.25) + 'f' -> trans 0.25 + '\27' -> exitWith ExitSuccess + _ -> return () + where setSrc :: FogCoordSrc -> IO () + setSrc s = do + fogCoordSrc $= s + postRedisplay Nothing + + inc :: (State -> IORef (FogCoord1 GLfloat)) -> GLfloat -> IO () + inc f x = do + FogCoord1 oldValue <- get (f state) + let newValue = oldValue + x + when (newValue > 0) $ do + f state $= FogCoord1 newValue + postRedisplay Nothing + + trans :: GLfloat -> IO () + trans x = do + matrixMode $= Modelview 0 + translate (Vector3 0 0 x) + postRedisplay Nothing +keyboard _ _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + _ <- createWindow progName + state <- makeState + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state + mainLoop + + diff --git a/examples/RedBook4/FogIndex.hs b/examples/RedBook4/FogIndex.hs --- a/examples/RedBook4/FogIndex.hs +++ b/examples/RedBook4/FogIndex.hs @@ -1,76 +1,76 @@ -{- - FogIndex.hs (adapted from fogindex.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws 5 wireframe spheres, each at a different z distance from - the eye, in linear fog. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Initialize color map and fog. Set screen clear color to end of color ramp. -numColors, rampStart :: GLint -numColors = 32 -rampStart = 16 - -myInit :: IO () -myInit = do - depthFunc $= Just Less - - flip mapM_ [ 0 .. numColors - 1 ] $ \i -> do - let shade = fromIntegral (numColors - i) / fromIntegral numColors - colorMapEntry (Index1 (rampStart + i)) $= Color3 shade shade shade - fog $= Enabled - - fogMode $= Linear 1 6 - fogIndex $= Index1 numColors - hint Fog $= Nicest - clearIndex $= Index1 (fromIntegral (numColors + rampStart - 1)) - -renderSpehere :: Vector3 GLfloat -> IO () -renderSpehere xyz = - preservingMatrix $ do - translate xyz - renderObject Wireframe (Sphere' 0.4 16 16) - --- display draws 5 spheres at different z positions. -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - index (Index1 rampStart) - mapM_ renderSpehere [ Vector3 x (-0.5) (-3 - x) | x <- [-2 .. 2] ] - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10.0) 10.0 - else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10.0) 10.0 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, color index --- display mode, depth buffer, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, IndexMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - _ <- createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display - mainLoop +{- + FogIndex.hs (adapted from fogindex.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws 5 wireframe spheres, each at a different z distance from + the eye, in linear fog. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Initialize color map and fog. Set screen clear color to end of color ramp. +numColors, rampStart :: GLint +numColors = 32 +rampStart = 16 + +myInit :: IO () +myInit = do + depthFunc $= Just Less + + flip mapM_ [ 0 .. numColors - 1 ] $ \i -> do + let shade = fromIntegral (numColors - i) / fromIntegral numColors + colorMapEntry (Index1 (rampStart + i)) $= Color3 shade shade shade + fog $= Enabled + + fogMode $= Linear 1 6 + fogIndex $= Index1 numColors + hint Fog $= Nicest + clearIndex $= Index1 (fromIntegral (numColors + rampStart - 1)) + +renderSpehere :: Vector3 GLfloat -> IO () +renderSpehere xyz = + preservingMatrix $ do + translate xyz + renderObject Wireframe (Sphere' 0.4 16 16) + +-- display draws 5 spheres at different z positions. +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + index (Index1 rampStart) + mapM_ renderSpehere [ Vector3 x (-0.5) (-3 - x) | x <- [-2 .. 2] ] + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10.0) 10.0 + else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10.0) 10.0 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, color index +-- display mode, depth buffer, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, IndexMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display + mainLoop diff --git a/examples/RedBook4/Font.hs b/examples/RedBook4/Font.hs --- a/examples/RedBook4/Font.hs +++ b/examples/RedBook4/Font.hs @@ -1,127 +1,127 @@ -{- - Font.hs (adapted from font.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Draws some text in a bitmapped font. Uses bitmap and other pixel routines. - Also demonstrates use of display lists. --} - -import Control.Monad ( zipWithM_ ) -import Data.List ( genericDrop, genericLength ) -import Foreign.C.String ( castCharToCChar ) -import Foreign.Marshal.Array ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -space :: [GLubyte] -space = [ - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 ] - -letters :: [[GLubyte]] -letters = [ - [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xff, 0xc3, 0xc3, 0xc3, 0x66, 0x3c, 0x18 ], - [ 0x00, 0x00, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ], - [ 0x00, 0x00, 0x7e, 0xe7, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xe7, 0x7e ], - [ 0x00, 0x00, 0xfc, 0xce, 0xc7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc7, 0xce, 0xfc ], - [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0xc0, 0xc0, 0xfc, 0xc0, 0xc0, 0xc0, 0xc0, 0xff ], - [ 0x00, 0x00, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xfc, 0xc0, 0xc0, 0xc0, 0xff ], - [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xcf, 0xc0, 0xc0, 0xc0, 0xc0, 0xe7, 0x7e ], - [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xff, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], - [ 0x00, 0x00, 0x7e, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x7e ], - [ 0x00, 0x00, 0x7c, 0xee, 0xc6, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06 ], - [ 0x00, 0x00, 0xc3, 0xc6, 0xcc, 0xd8, 0xf0, 0xe0, 0xf0, 0xd8, 0xcc, 0xc6, 0xc3 ], - [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0 ], - [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xdb, 0xff, 0xff, 0xe7, 0xc3 ], - [ 0x00, 0x00, 0xc7, 0xc7, 0xcf, 0xcf, 0xdf, 0xdb, 0xfb, 0xf3, 0xf3, 0xe3, 0xe3 ], - [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xe7, 0x7e ], - [ 0x00, 0x00, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ], - [ 0x00, 0x00, 0x3f, 0x6e, 0xdf, 0xdb, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0x66, 0x3c ], - [ 0x00, 0x00, 0xc3, 0xc6, 0xcc, 0xd8, 0xf0, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ], - [ 0x00, 0x00, 0x7e, 0xe7, 0x03, 0x03, 0x07, 0x7e, 0xe0, 0xc0, 0xc0, 0xe7, 0x7e ], - [ 0x00, 0x00, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0xff ], - [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], - [ 0x00, 0x00, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], - [ 0x00, 0x00, 0xc3, 0xe7, 0xff, 0xff, 0xdb, 0xdb, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], - [ 0x00, 0x00, 0xc3, 0x66, 0x66, 0x3c, 0x3c, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3 ], - [ 0x00, 0x00, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3 ], - [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0x60, 0x30, 0x7e, 0x0c, 0x06, 0x03, 0x03, 0xff ]] - -charToGLubyte :: Char -> GLubyte -charToGLubyte = fromIntegral . castCharToCChar - -makeRasterFont :: IO DisplayList -makeRasterFont = do - rowAlignment Unpack $= 1 - - fontDisplayLists@(fontOffset:_) <- genObjectNames 128 - let listsStartingWith ch = genericDrop (charToGLubyte ch) fontDisplayLists - makeLetter dl letter = - defineList dl Compile $ - withArray letter $ - bitmap (Size 8 13) (Vertex2 0 2) (Vector2 10 0) - - zipWithM_ makeLetter (listsStartingWith 'A') letters - makeLetter (head (listsStartingWith ' ')) space - return fontOffset - -myInit :: IO DisplayList -myInit = do - shadeModel $= Flat - makeRasterFont - -printString :: DisplayList -> String -> IO () -printString fontOffset s = - preservingAttrib [ ListAttributes ] $ do - listBase $= fontOffset - withArray (map charToGLubyte s) $ - callLists (genericLength s) UnsignedByte - --- Everything above this line could be in a library --- that defines a font. To make it work, you've got --- to call makeRasterFont before you start making --- calls to printString. -display :: DisplayList -> DisplayCallback -display fontOffset = do - let white = Color3 1 1 1 - - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - color3f white - - rasterPos2i (Vertex2 20 60) - printString fontOffset "THE QUICK BROWN FOX JUMPS" - rasterPos2i (Vertex2 20 40) - printString fontOffset "OVER A LAZY DOG" - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop --- Open window with initial window size, title bar, --- RGBA display mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 300 100 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - fontOffset <- myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display fontOffset - mainLoop +{- + Font.hs (adapted from font.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Draws some text in a bitmapped font. Uses bitmap and other pixel routines. + Also demonstrates use of display lists. +-} + +import Control.Monad ( zipWithM_ ) +import Data.List ( genericDrop, genericLength ) +import Foreign.C.String ( castCharToCChar ) +import Foreign.Marshal.Array ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +space :: [GLubyte] +space = [ + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 ] + +letters :: [[GLubyte]] +letters = [ + [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xff, 0xc3, 0xc3, 0xc3, 0x66, 0x3c, 0x18 ], + [ 0x00, 0x00, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ], + [ 0x00, 0x00, 0x7e, 0xe7, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xe7, 0x7e ], + [ 0x00, 0x00, 0xfc, 0xce, 0xc7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc7, 0xce, 0xfc ], + [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0xc0, 0xc0, 0xfc, 0xc0, 0xc0, 0xc0, 0xc0, 0xff ], + [ 0x00, 0x00, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xfc, 0xc0, 0xc0, 0xc0, 0xff ], + [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xcf, 0xc0, 0xc0, 0xc0, 0xc0, 0xe7, 0x7e ], + [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xff, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], + [ 0x00, 0x00, 0x7e, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x7e ], + [ 0x00, 0x00, 0x7c, 0xee, 0xc6, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06 ], + [ 0x00, 0x00, 0xc3, 0xc6, 0xcc, 0xd8, 0xf0, 0xe0, 0xf0, 0xd8, 0xcc, 0xc6, 0xc3 ], + [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0 ], + [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xdb, 0xff, 0xff, 0xe7, 0xc3 ], + [ 0x00, 0x00, 0xc7, 0xc7, 0xcf, 0xcf, 0xdf, 0xdb, 0xfb, 0xf3, 0xf3, 0xe3, 0xe3 ], + [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xe7, 0x7e ], + [ 0x00, 0x00, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ], + [ 0x00, 0x00, 0x3f, 0x6e, 0xdf, 0xdb, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0x66, 0x3c ], + [ 0x00, 0x00, 0xc3, 0xc6, 0xcc, 0xd8, 0xf0, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ], + [ 0x00, 0x00, 0x7e, 0xe7, 0x03, 0x03, 0x07, 0x7e, 0xe0, 0xc0, 0xc0, 0xe7, 0x7e ], + [ 0x00, 0x00, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0xff ], + [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], + [ 0x00, 0x00, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], + [ 0x00, 0x00, 0xc3, 0xe7, 0xff, 0xff, 0xdb, 0xdb, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], + [ 0x00, 0x00, 0xc3, 0x66, 0x66, 0x3c, 0x3c, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3 ], + [ 0x00, 0x00, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3 ], + [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0x60, 0x30, 0x7e, 0x0c, 0x06, 0x03, 0x03, 0xff ]] + +charToGLubyte :: Char -> GLubyte +charToGLubyte = fromIntegral . castCharToCChar + +makeRasterFont :: IO DisplayList +makeRasterFont = do + rowAlignment Unpack $= 1 + + fontDisplayLists@(fontOffset:_) <- genObjectNames 128 + let listsStartingWith ch = genericDrop (charToGLubyte ch) fontDisplayLists + makeLetter dl letter = + defineList dl Compile $ + withArray letter $ + bitmap (Size 8 13) (Vertex2 0 2) (Vector2 10 0) + + zipWithM_ makeLetter (listsStartingWith 'A') letters + makeLetter (head (listsStartingWith ' ')) space + return fontOffset + +myInit :: IO DisplayList +myInit = do + shadeModel $= Flat + makeRasterFont + +printString :: DisplayList -> String -> IO () +printString fontOffset s = + preservingAttrib [ ListAttributes ] $ do + listBase $= fontOffset + withArray (map charToGLubyte s) $ + callLists (genericLength s) UnsignedByte + +-- Everything above this line could be in a library +-- that defines a font. To make it work, you've got +-- to call makeRasterFont before you start making +-- calls to printString. +display :: DisplayList -> DisplayCallback +display fontOffset = do + let white = Color3 1 1 1 + + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + color3f white + + rasterPos2i (Vertex2 20 60) + printString fontOffset "THE QUICK BROWN FOX JUMPS" + rasterPos2i (Vertex2 20 40) + printString fontOffset "OVER A LAZY DOG" + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop +-- Open window with initial window size, title bar, +-- RGBA display mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 300 100 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + fontOffset <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display fontOffset + mainLoop diff --git a/examples/RedBook4/Hello.hs b/examples/RedBook4/Hello.hs --- a/examples/RedBook4/Hello.hs +++ b/examples/RedBook4/Hello.hs @@ -1,55 +1,55 @@ -{- - Hello.hs (adapted from hello.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This is a simple, introductory OpenGL program. --} - -import Graphics.UI.GLUT - -display :: DisplayCallback -display = do - -- clear all pixels - clear [ ColorBuffer ] - - -- draw white polygon (rectangle) with corners at - -- (0.25, 0.25, 0.0) and (0.75, 0.75, 0.0) - color (Color3 1.0 1.0 (1.0 :: GLfloat)) - -- resolve overloading, not needed in "real" programs - let vertex3f = vertex :: Vertex3 GLfloat -> IO () - renderPrimitive Polygon $ mapM_ vertex3f [ - Vertex3 0.25 0.25 0.0, - Vertex3 0.75 0.25 0.0, - Vertex3 0.75 0.75 0.0, - Vertex3 0.25 0.75 0.0] - - -- don't wait! - -- start processing buffered OpenGL routines - flush - -myInit :: IO () -myInit = do - -- select clearing color - clearColor $= Color4 0 0 0 0 - - -- initialize viewing values - matrixMode $= Projection - loadIdentity - ortho 0 1 0 1 (-1) 1 - --- Declare initial window size, position, and display mode (single buffer and --- RGBA). Open window with "hello" in its title bar. Call initialization --- routines. Register callback function to display graphics. Enter main loop and --- process events. -main :: IO () -main = do - _ <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - _ <- createWindow "hello" - myInit - displayCallback $= display - mainLoop +{- + Hello.hs (adapted from hello.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This is a simple, introductory OpenGL program. +-} + +import Graphics.UI.GLUT + +display :: DisplayCallback +display = do + -- clear all pixels + clear [ ColorBuffer ] + + -- draw white polygon (rectangle) with corners at + -- (0.25, 0.25, 0.0) and (0.75, 0.75, 0.0) + color (Color3 1.0 1.0 (1.0 :: GLfloat)) + -- resolve overloading, not needed in "real" programs + let vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Polygon $ mapM_ vertex3f [ + Vertex3 0.25 0.25 0.0, + Vertex3 0.75 0.25 0.0, + Vertex3 0.75 0.75 0.0, + Vertex3 0.25 0.75 0.0] + + -- don't wait! + -- start processing buffered OpenGL routines + flush + +myInit :: IO () +myInit = do + -- select clearing color + clearColor $= Color4 0 0 0 0 + + -- initialize viewing values + matrixMode $= Projection + loadIdentity + ortho 0 1 0 1 (-1) 1 + +-- Declare initial window size, position, and display mode (single buffer and +-- RGBA). Open window with "hello" in its title bar. Call initialization +-- routines. Register callback function to display graphics. Enter main loop and +-- process events. +main :: IO () +main = do + _ <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow "hello" + myInit + displayCallback $= display + mainLoop diff --git a/examples/RedBook4/Histogram.hs b/examples/RedBook4/Histogram.hs --- a/examples/RedBook4/Histogram.hs +++ b/examples/RedBook4/Histogram.hs @@ -1,85 +1,85 @@ -{- - Histogram.hs (adapted from histogram.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Compute the histogram of the image. This program illustrates the use of - the histogram function. --} - -import Control.Monad ( zipWithM_ ) -import Foreign ( allocaArray, peekArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT -import ReadImage - -histogramSize :: Int -histogramSize = 256 -- Must be a power of 2 - -myInit :: IO () -myInit = do - rowAlignment Unpack $= 1 - clearColor $= Color4 0 0 0 0 - - histogram NoProxy $= Just (fromIntegral histogramSize, RGB', PassThrough) - -display :: Size -> PixelData a -> DisplayCallback -display size pixels = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - rasterPos2i (Vertex2 1 1) - drawPixels size pixels - - values <- allocaArray histogramSize $ \buf -> do - -- Note: The example in the Red Book uses GL_UNSIGNED_SHORT here, - -- but we are more honest by using Short... - getHistogram Reset (PixelData RGB Short buf) - peekArray histogramSize buf - - -- Plot histogram - zipWithM_ (plotHistogram values) - [ Color3 1 0 0, Color3 0 1 0, Color3 0 0 1 ] - [\(Color3 r _ _) -> r, \(Color3 _ g _) -> g, \(Color3 _ _ b) -> b ] - flush - -plotHistogram :: - [Color3 GLshort] -> Color3 GLfloat -> (Color3 GLshort -> GLshort) -> IO () -plotHistogram values c selectComponent = - renderPrimitive LineStrip $ do - color c - zipWithM_ (\i h -> vertex (Vertex2 i (selectComponent h))) [ 0 .. ] values - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho 0 (fromIntegral histogramSize) 0 10000 (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char 's') Down _ _ = do - Just (width, format, sink) <- get (histogram NoProxy) - let newSink = if sink == Sink then PassThrough else Sink - histogram NoProxy $= Just (width, format, newSink) - postRedisplay Nothing -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, args) <- getArgsAndInitialize - (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= size - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display size pixels - mainLoop +{- + Histogram.hs (adapted from histogram.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Compute the histogram of the image. This program illustrates the use of + the histogram function. +-} + +import Control.Monad ( zipWithM_ ) +import Foreign ( allocaArray, peekArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT +import ReadImage + +histogramSize :: Int +histogramSize = 256 -- Must be a power of 2 + +myInit :: IO () +myInit = do + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + + histogram NoProxy $= Just (fromIntegral histogramSize, RGB', PassThrough) + +display :: Size -> PixelData a -> DisplayCallback +display size pixels = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 1 1) + drawPixels size pixels + + values <- allocaArray histogramSize $ \buf -> do + -- Note: The example in the Red Book uses GL_UNSIGNED_SHORT here, + -- but we are more honest by using Short... + getHistogram Reset (PixelData RGB Short buf) + peekArray histogramSize buf + + -- Plot histogram + zipWithM_ (plotHistogram values) + [ Color3 1 0 0, Color3 0 1 0, Color3 0 0 1 ] + [\(Color3 r _ _) -> r, \(Color3 _ g _) -> g, \(Color3 _ _ b) -> b ] + flush + +plotHistogram :: + [Color3 GLshort] -> Color3 GLfloat -> (Color3 GLshort -> GLshort) -> IO () +plotHistogram values c selectComponent = + renderPrimitive LineStrip $ do + color c + zipWithM_ (\i h -> vertex (Vertex2 i (selectComponent h))) [ 0 .. ] values + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral histogramSize) 0 10000 (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char 's') Down _ _ = do + Just (width, format, sink) <- get (histogram NoProxy) + let newSink = if sink == Sink then PassThrough else Sink + histogram NoProxy $= Just (width, format, newSink) + postRedisplay Nothing +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, args) <- getArgsAndInitialize + (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= size + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display size pixels + mainLoop diff --git a/examples/RedBook4/Image.hs b/examples/RedBook4/Image.hs --- a/examples/RedBook4/Image.hs +++ b/examples/RedBook4/Image.hs @@ -1,116 +1,116 @@ -{- - Image.hs (adapted from image.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates drawing pixels and shows the effect of - drawPixels, copyPixels, and pixelZoom. - - Interaction: moving the mouse while pressing the mouse button will copy - the image in the lower-left corner of the window to the mouse position, - using the current pixel zoom factors. There is no attempt to prevent you - from drawing over the original image. If you press the 'r' key, the - original image and zoom factors are reset. If you press the 'z' or 'Z' - keys, you change the zoom factors. --} - -import Data.Bits ( (.&.) ) -import Data.IORef ( IORef, newIORef ) -import Foreign ( newArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { zoomFactor :: IORef GLfloat } - -makeState :: IO State -makeState = do - z <- newIORef 1 - return $ State { zoomFactor = z } - --- Create checkerboard image -checkImageSize :: Size -checkImageSize = Size 64 64 - -type Image = PixelData (Color3 GLubyte) - -makeCheckImage :: Size -> GLsizei -> (GLubyte -> (Color3 GLubyte)) -> IO Image -makeCheckImage (Size w h) n f = - fmap (PixelData RGB UnsignedByte) $ - newArray [ f c | - i <- [ 0 .. w - 1 ], - j <- [ 0 .. h - 1 ], - let c | (i .&. n) == (j .&. n) = 0 - | otherwise = 255 ] - -myInit :: IO Image -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - rowAlignment Unpack $= 1 - makeCheckImage checkImageSize 0x8 (\c -> Color3 c c c) - -display :: Image -> DisplayCallback -display pixelData = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - rasterPos2i (Vertex2 0 0) - drawPixels checkImageSize pixelData - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 (fromIntegral w) 0 (fromIntegral h) - matrixMode $= Modelview 0 - loadIdentity - -motion :: State -> MotionCallback -motion state (Position x y) = do - Size _ height <- get windowSize - let screenY = fromIntegral height - y - -- resolve overloading, not needed in "real" programs - let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - rasterPos2i (Vertex2 x screenY) - z <- get (zoomFactor state) - pixelZoom $= (z, z) - copyPixels (Position 0 0) checkImageSize CopyColor - pixelZoom $= (1, 1) - flush - -resetZoomFactor :: State -> IO () -resetZoomFactor state = do - zoomFactor state $= 1.0 - postRedisplay Nothing - putStrLn "zoomFactor reset to 1.0" - -incZoomFactor :: State -> GLfloat -> IO () -incZoomFactor state inc = do - zoomFactor state $~! (max 0.5 . min 3.0 . (+ inc)) - get (zoomFactor state) >>= putStrLn . ("zoomFactor is now " ++) . show - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char 'r') Down _ _ = resetZoomFactor state -keyboard state (Char 'R') Down _ _ = resetZoomFactor state -keyboard state (Char 'z') Down _ _ = incZoomFactor state 0.5 -keyboard state (Char 'Z') Down _ _ = incZoomFactor state (-0.5) -keyboard _ (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - state <- makeState - checkImage <- myInit - displayCallback $= display checkImage - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - motionCallback $= Just (motion state) - mainLoop +{- + Image.hs (adapted from image.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates drawing pixels and shows the effect of + drawPixels, copyPixels, and pixelZoom. + + Interaction: moving the mouse while pressing the mouse button will copy + the image in the lower-left corner of the window to the mouse position, + using the current pixel zoom factors. There is no attempt to prevent you + from drawing over the original image. If you press the 'r' key, the + original image and zoom factors are reset. If you press the 'z' or 'Z' + keys, you change the zoom factors. +-} + +import Data.Bits ( (.&.) ) +import Data.IORef ( IORef, newIORef ) +import Foreign ( newArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { zoomFactor :: IORef GLfloat } + +makeState :: IO State +makeState = do + z <- newIORef 1 + return $ State { zoomFactor = z } + +-- Create checkerboard image +checkImageSize :: Size +checkImageSize = Size 64 64 + +type Image = PixelData (Color3 GLubyte) + +makeCheckImage :: Size -> GLsizei -> (GLubyte -> (Color3 GLubyte)) -> IO Image +makeCheckImage (Size w h) n f = + fmap (PixelData RGB UnsignedByte) $ + newArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] + +myInit :: IO Image +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + rowAlignment Unpack $= 1 + makeCheckImage checkImageSize 0x8 (\c -> Color3 c c c) + +display :: Image -> DisplayCallback +display pixelData = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 0 0) + drawPixels checkImageSize pixelData + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + matrixMode $= Modelview 0 + loadIdentity + +motion :: State -> MotionCallback +motion state (Position x y) = do + Size _ height <- get windowSize + let screenY = fromIntegral height - y + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 x screenY) + z <- get (zoomFactor state) + pixelZoom $= (z, z) + copyPixels (Position 0 0) checkImageSize CopyColor + pixelZoom $= (1, 1) + flush + +resetZoomFactor :: State -> IO () +resetZoomFactor state = do + zoomFactor state $= 1.0 + postRedisplay Nothing + putStrLn "zoomFactor reset to 1.0" + +incZoomFactor :: State -> GLfloat -> IO () +incZoomFactor state inc = do + zoomFactor state $~! (max 0.5 . min 3.0 . (+ inc)) + get (zoomFactor state) >>= putStrLn . ("zoomFactor is now " ++) . show + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char 'r') Down _ _ = resetZoomFactor state +keyboard state (Char 'R') Down _ _ = resetZoomFactor state +keyboard state (Char 'z') Down _ _ = incZoomFactor state 0.5 +keyboard state (Char 'Z') Down _ _ = incZoomFactor state (-0.5) +keyboard _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + checkImage <- myInit + displayCallback $= display checkImage + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + motionCallback $= Just (motion state) + mainLoop diff --git a/examples/RedBook4/Light.hs b/examples/RedBook4/Light.hs --- a/examples/RedBook4/Light.hs +++ b/examples/RedBook4/Light.hs @@ -1,62 +1,62 @@ -{- - Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates the use of the OpenGL lighting model. A sphere - is drawn using a grey material characteristic. A single light source - illuminates the object. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Smooth - - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 50 - position (Light 0) $= Vertex4 1 1 1 0 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - renderObject Solid (Sphere' 1 20 16) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-1.5) 1.5 (-1.5 * hf/wf) (1.5 * hf/wf) (-10) 10 - else ortho (-1.5 * wf/hf) (1.5 * wf/hf) (-1.5) 1.5 (-10) 10 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the use of the OpenGL lighting model. A sphere + is drawn using a grey material characteristic. A single light source + illuminates the object. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 50 + position (Light 0) $= Vertex4 1 1 1 0 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + renderObject Solid (Sphere' 1 20 16) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-1.5) 1.5 (-1.5 * hf/wf) (1.5 * hf/wf) (-10) 10 + else ortho (-1.5 * wf/hf) (1.5 * wf/hf) (-1.5) 1.5 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Lines.hs b/examples/RedBook4/Lines.hs --- a/examples/RedBook4/Lines.hs +++ b/examples/RedBook4/Lines.hs @@ -1,88 +1,88 @@ -{- - Lines.hs (adapted from lines.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates geometric primitives and their attributes. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -drawOneLine :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO () -drawOneLine p1 p2 = renderPrimitive Lines $ do vertex p1; vertex p2 - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - -- select white for all lines - color (Color3 1.0 1.0 1.0 :: Color3 GLfloat) - - -- in 1st row, 3 lines, each with a different stipple - lineStipple $= Just (1, 0x0101) -- dotted - drawOneLine (Vertex2 50 125) (Vertex2 150 125) - lineStipple $= Just (1, 0x00FF) -- dashed - drawOneLine (Vertex2 150 125) (Vertex2 250 125) - lineStipple $= Just (1, 0x1C47) -- dash/dot/dash - drawOneLine (Vertex2 250 125) (Vertex2 350 125) - - -- in 2nd row, 3 wide lines, each with different stipple - lineWidth $= 5.0 - lineStipple $= Just (1, 0x0101) -- dotted - drawOneLine (Vertex2 50 100) (Vertex2 150 100) - lineStipple $= Just (1, 0x00FF) -- dashed - drawOneLine (Vertex2 150 100) (Vertex2 250 100) - lineStipple $= Just (1, 0x1C47) -- dash/dot/dash - drawOneLine (Vertex2 250 100) (Vertex2 350 100) - lineWidth $= 1.0 - - -- in 3rd row, 6 lines, with dash/dot/dash stipple - -- as part of a single connected line strip - lineStipple $= Just (1, 0x1C47) -- dash/dot/dash - renderPrimitive LineStrip $ mapM_ vertex [ Vertex2 (50+(i*50)) (75 :: GLint) | i <- [0..6] ] - - -- in 4th row, 6 independent lines with same stipple - sequence_ [ drawOneLine (Vertex2 (50+( i *50)) 50) - (Vertex2 (50+((i+1)*50)) 50) | i <- [0..5] ] - - -- in 5th row, 1 line, with dash/dot/dash stipple - -- and a stipple repeat factor of 5 - lineStipple $= Just (5, 0x1C47) -- dash/dot/dash - drawOneLine (Vertex2 50 25) (Vertex2 350 25) - - lineStipple $= Nothing - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 (fromIntegral w) 0 (fromIntegral h) - -- the following line is not in the original example, but it's good style... - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Request double buffer display mode. --- Register mouse input callback functions -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 400 150 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Lines.hs (adapted from lines.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates geometric primitives and their attributes. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +drawOneLine :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO () +drawOneLine p1 p2 = renderPrimitive Lines $ do vertex p1; vertex p2 + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + -- select white for all lines + color (Color3 1.0 1.0 1.0 :: Color3 GLfloat) + + -- in 1st row, 3 lines, each with a different stipple + lineStipple $= Just (1, 0x0101) -- dotted + drawOneLine (Vertex2 50 125) (Vertex2 150 125) + lineStipple $= Just (1, 0x00FF) -- dashed + drawOneLine (Vertex2 150 125) (Vertex2 250 125) + lineStipple $= Just (1, 0x1C47) -- dash/dot/dash + drawOneLine (Vertex2 250 125) (Vertex2 350 125) + + -- in 2nd row, 3 wide lines, each with different stipple + lineWidth $= 5.0 + lineStipple $= Just (1, 0x0101) -- dotted + drawOneLine (Vertex2 50 100) (Vertex2 150 100) + lineStipple $= Just (1, 0x00FF) -- dashed + drawOneLine (Vertex2 150 100) (Vertex2 250 100) + lineStipple $= Just (1, 0x1C47) -- dash/dot/dash + drawOneLine (Vertex2 250 100) (Vertex2 350 100) + lineWidth $= 1.0 + + -- in 3rd row, 6 lines, with dash/dot/dash stipple + -- as part of a single connected line strip + lineStipple $= Just (1, 0x1C47) -- dash/dot/dash + renderPrimitive LineStrip $ mapM_ vertex [ Vertex2 (50+(i*50)) (75 :: GLint) | i <- [0..6] ] + + -- in 4th row, 6 independent lines with same stipple + sequence_ [ drawOneLine (Vertex2 (50+( i *50)) 50) + (Vertex2 (50+((i+1)*50)) 50) | i <- [0..5] ] + + -- in 5th row, 1 line, with dash/dot/dash stipple + -- and a stipple repeat factor of 5 + lineStipple $= Just (5, 0x1C47) -- dash/dot/dash + drawOneLine (Vertex2 50 25) (Vertex2 350 25) + + lineStipple $= Nothing + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + -- the following line is not in the original example, but it's good style... + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Request double buffer display mode. +-- Register mouse input callback functions +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 400 150 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/MVArray.hs b/examples/RedBook4/MVArray.hs --- a/examples/RedBook4/MVArray.hs +++ b/examples/RedBook4/MVArray.hs @@ -1,87 +1,87 @@ -{- - MVArray.hs (adapted from mvarray.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates multiple vertex arrays, specifically the OpenGL - routine multiDrawElements. --} - -import Control.Monad ( unless ) -import Data.List ( genericLength ) -import Foreign ( Storable, Ptr, newArray ) -import System.Exit ( exitFailure, exitWith, ExitCode(..) ) -import Graphics.UI.GLUT - -data MultiDrawInfo a = MultiDrawInfo (Ptr GLsizei) (Ptr (Ptr a)) GLsizei - -makeMultiDrawInfo :: Storable a => [[a]] -> IO (MultiDrawInfo a) -makeMultiDrawInfo indicesLists = do - count <- newArray $ map genericLength indicesLists - indices <- newArray =<< mapM newArray indicesLists - return $ MultiDrawInfo count indices (genericLength indicesLists) - -setupPointer :: IO () -setupPointer = do - clientState VertexArray $= Enabled - vertices <- newArray ([ - Vertex2 25 25, - Vertex2 75 75, - Vertex2 100 125, - Vertex2 150 75, - Vertex2 200 175, - Vertex2 250 150, - Vertex2 300 125, - Vertex2 100 200, - Vertex2 150 250, - Vertex2 200 225, - Vertex2 250 300, - Vertex2 300 250 ] :: [Vertex2 GLint]) - arrayPointer VertexArray $= VertexArrayDescriptor 2 Int 0 vertices - -myInit :: IO (MultiDrawInfo GLubyte) -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Smooth - setupPointer - makeMultiDrawInfo [ [ 0, 1, 2, 3, 4, 5, 6 ], - [ 1, 7, 8, 9, 10, 11 ] ] - -display :: MultiDrawInfo GLubyte -> DisplayCallback -display (MultiDrawInfo count indices primCount) = do - clear [ ColorBuffer ] - color (Color3 1 1 1 :: Color3 GLfloat) - multiDrawElements LineStrip count UnsignedByte indices primCount - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 (fromIntegral w) 0 (fromIntegral h) - -- the following line is not in the original example, but it's good style... - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 350 350 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - -- we have to do this *after* createWindow, otherwise we have no OpenGL context - exts <- get glExtensions - unless ("GL_EXT_multi_draw_arrays" `elem` exts) $ do - putStrLn "Sorry, this demo requires the GL_EXT_multi_draw_arrays extension." - exitFailure - multiDrawInfo <- myInit - displayCallback $= display multiDrawInfo - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + MVArray.hs (adapted from mvarray.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates multiple vertex arrays, specifically the OpenGL + routine multiDrawElements. +-} + +import Control.Monad ( unless ) +import Data.List ( genericLength ) +import Foreign ( Storable, Ptr, newArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(..) ) +import Graphics.UI.GLUT + +data MultiDrawInfo a = MultiDrawInfo (Ptr GLsizei) (Ptr (Ptr a)) GLsizei + +makeMultiDrawInfo :: Storable a => [[a]] -> IO (MultiDrawInfo a) +makeMultiDrawInfo indicesLists = do + count <- newArray $ map genericLength indicesLists + indices <- newArray =<< mapM newArray indicesLists + return $ MultiDrawInfo count indices (genericLength indicesLists) + +setupPointer :: IO () +setupPointer = do + clientState VertexArray $= Enabled + vertices <- newArray ([ + Vertex2 25 25, + Vertex2 75 75, + Vertex2 100 125, + Vertex2 150 75, + Vertex2 200 175, + Vertex2 250 150, + Vertex2 300 125, + Vertex2 100 200, + Vertex2 150 250, + Vertex2 200 225, + Vertex2 250 300, + Vertex2 300 250 ] :: [Vertex2 GLint]) + arrayPointer VertexArray $= VertexArrayDescriptor 2 Int 0 vertices + +myInit :: IO (MultiDrawInfo GLubyte) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + setupPointer + makeMultiDrawInfo [ [ 0, 1, 2, 3, 4, 5, 6 ], + [ 1, 7, 8, 9, 10, 11 ] ] + +display :: MultiDrawInfo GLubyte -> DisplayCallback +display (MultiDrawInfo count indices primCount) = do + clear [ ColorBuffer ] + color (Color3 1 1 1 :: Color3 GLfloat) + multiDrawElements LineStrip count UnsignedByte indices primCount + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + -- the following line is not in the original example, but it's good style... + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 350 350 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + exts <- get glExtensions + unless ("GL_EXT_multi_draw_arrays" `elem` exts) $ do + putStrLn "Sorry, this demo requires the GL_EXT_multi_draw_arrays extension." + exitFailure + multiDrawInfo <- myInit + displayCallback $= display multiDrawInfo + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Makefile b/examples/RedBook4/Makefile --- a/examples/RedBook4/Makefile +++ b/examples/RedBook4/Makefile @@ -1,4 +1,4 @@ -EXCLUDED_SOURCES := ReadImage.hs -include ../examples.mk - -ColorMatrix ColorTable Convolution Histogram Minmax: ReadImage.o +EXCLUDED_SOURCES := ReadImage.hs +include ../examples.mk + +ColorMatrix ColorTable Convolution Histogram Minmax: ReadImage.o diff --git a/examples/RedBook4/Material.hs b/examples/RedBook4/Material.hs --- a/examples/RedBook4/Material.hs +++ b/examples/RedBook4/Material.hs @@ -1,149 +1,149 @@ -{- - Material.hs (adapted from material.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates the use of the GL lighting model. Several - objects are drawn using different material characteristics. A single - light source illuminates the objects. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Initialize z-buffer, projection matrix, light source, and lighting model. --- Do not specify a material property here. - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0.1 0.1 0 - depthFunc $= Just Less - shadeModel $= Smooth - - ambient (Light 0) $= Color4 0 0 0 1 - diffuse (Light 0) $= Color4 1 1 1 1 - position (Light 0) $= Vertex4 0 3 2 0 - lightModelAmbient $= Color4 0.4 0.4 0.4 1 - lightModelLocalViewer $= Disabled - - lighting $= Enabled - light (Light 0) $= Enabled - --- Draw twelve spheres in 3 rows with 4 columns. --- The spheres in the first row have materials with no ambient reflection. --- The second row has materials with significant ambient reflection. --- The third row has materials with colored ambient reflection. --- --- The first column has materials with blue, diffuse reflection only. --- The second column has blue diffuse reflection, as well as specular --- reflection with a low shininess exponent. --- The third column has blue diffuse reflection, as well as specular --- reflection with a high shininess exponent (a more concentrated highlight). --- The fourth column has materials which also include an emissive component. --- --- translate is used to move spheres to their appropriate locations. - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - - let draw :: GLfloat -> GLfloat -> Color4 GLfloat -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> Color4 GLfloat -> IO () - draw row column amb dif spc shi emi = - preservingMatrix $ do - translate (Vector3 (2.5 * (column - 2.5)) (3 * (2 - row)) 0) - materialAmbient Front $= amb - materialDiffuse Front $= dif - materialSpecular Front $= spc - materialShininess Front $= shi - materialEmission Front $= emi - renderObject Solid (Sphere' 1 16 16) - - noMat = Color4 0 0 0 1 - matAmbient = Color4 0.7 0.7 0.7 1 - matAmbientColor = Color4 0.8 0.8 0.2 1 - matDiffuse = Color4 0.1 0.5 0.8 1 - matSpecular = Color4 1 1 1 1 - noShininess = 0 - lowShininess = 5 - highShininess = 100 - matEmission = Color4 0.3 0.2 0.2 0 - - -- draw sphere in first row, first column - -- diffuse reflection only; no ambient or specular - draw 1 1 noMat matDiffuse noMat noShininess noMat - - -- draw sphere in first row, second column - -- diffuse and specular reflection; low shininess; no ambient - draw 1 2 noMat matDiffuse matSpecular lowShininess noMat - - -- draw sphere in first row, third column - -- diffuse and specular reflection; high shininess; no ambient - draw 1 3 noMat matDiffuse matSpecular highShininess noMat - - -- draw sphere in first row, fourth column - -- diffuse reflection; emission; no ambient or specular reflection - draw 1 4 noMat matDiffuse noMat noShininess matEmission - - -- draw sphere in second row, first column - -- ambient and diffuse reflection; no specular - draw 2 1 matAmbient matDiffuse noMat noShininess noMat - - -- draw sphere in second row, second column - -- ambient, diffuse and specular reflection; low shininess - draw 2 2 matAmbient matDiffuse matSpecular lowShininess noMat - - -- draw sphere in second row, third column - -- ambient, diffuse and specular reflection; high shininess - draw 2 3 matAmbient matDiffuse matSpecular highShininess noMat - - -- draw sphere in second row, fourth column - -- ambient and diffuse reflection; emission; no specular - draw 2 4 matAmbient matDiffuse noMat noShininess matEmission - - -- draw sphere in third row, first column - -- colored ambient and diffuse reflection; no specular - draw 3 1 matAmbientColor matDiffuse noMat noShininess noMat - - -- draw sphere in third row, second column - -- colored ambient, diffuse and specular reflection; low shininess - draw 3 2 matAmbientColor matDiffuse matSpecular lowShininess noMat - - -- draw sphere in third row, third column - -- colored ambient, diffuse and specular reflection; high shininess - draw 3 3 matAmbientColor matDiffuse matSpecular highShininess noMat - - -- draw sphere in third row, fourth column - -- colored ambient and diffuse reflection; emission; no specular - draw 3 4 matAmbientColor matDiffuse noMat noShininess matEmission - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h * 2 - then ortho (-6) 6 (-3 * (hf * 2) / wf) (3 * (hf * 2) / wf) (-10) 10 - else ortho (-6 * wf / (hf * 2)) (6 * wf / (hf * 2)) (-3) 3 (-10) 10 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 600 450 - _ <- createWindow progName - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Material.hs (adapted from material.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the use of the GL lighting model. Several + objects are drawn using different material characteristics. A single + light source illuminates the objects. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Initialize z-buffer, projection matrix, light source, and lighting model. +-- Do not specify a material property here. + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0.1 0.1 0 + depthFunc $= Just Less + shadeModel $= Smooth + + ambient (Light 0) $= Color4 0 0 0 1 + diffuse (Light 0) $= Color4 1 1 1 1 + position (Light 0) $= Vertex4 0 3 2 0 + lightModelAmbient $= Color4 0.4 0.4 0.4 1 + lightModelLocalViewer $= Disabled + + lighting $= Enabled + light (Light 0) $= Enabled + +-- Draw twelve spheres in 3 rows with 4 columns. +-- The spheres in the first row have materials with no ambient reflection. +-- The second row has materials with significant ambient reflection. +-- The third row has materials with colored ambient reflection. +-- +-- The first column has materials with blue, diffuse reflection only. +-- The second column has blue diffuse reflection, as well as specular +-- reflection with a low shininess exponent. +-- The third column has blue diffuse reflection, as well as specular +-- reflection with a high shininess exponent (a more concentrated highlight). +-- The fourth column has materials which also include an emissive component. +-- +-- translate is used to move spheres to their appropriate locations. + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + + let draw :: GLfloat -> GLfloat -> Color4 GLfloat -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> Color4 GLfloat -> IO () + draw row column amb dif spc shi emi = + preservingMatrix $ do + translate (Vector3 (2.5 * (column - 2.5)) (3 * (2 - row)) 0) + materialAmbient Front $= amb + materialDiffuse Front $= dif + materialSpecular Front $= spc + materialShininess Front $= shi + materialEmission Front $= emi + renderObject Solid (Sphere' 1 16 16) + + noMat = Color4 0 0 0 1 + matAmbient = Color4 0.7 0.7 0.7 1 + matAmbientColor = Color4 0.8 0.8 0.2 1 + matDiffuse = Color4 0.1 0.5 0.8 1 + matSpecular = Color4 1 1 1 1 + noShininess = 0 + lowShininess = 5 + highShininess = 100 + matEmission = Color4 0.3 0.2 0.2 0 + + -- draw sphere in first row, first column + -- diffuse reflection only; no ambient or specular + draw 1 1 noMat matDiffuse noMat noShininess noMat + + -- draw sphere in first row, second column + -- diffuse and specular reflection; low shininess; no ambient + draw 1 2 noMat matDiffuse matSpecular lowShininess noMat + + -- draw sphere in first row, third column + -- diffuse and specular reflection; high shininess; no ambient + draw 1 3 noMat matDiffuse matSpecular highShininess noMat + + -- draw sphere in first row, fourth column + -- diffuse reflection; emission; no ambient or specular reflection + draw 1 4 noMat matDiffuse noMat noShininess matEmission + + -- draw sphere in second row, first column + -- ambient and diffuse reflection; no specular + draw 2 1 matAmbient matDiffuse noMat noShininess noMat + + -- draw sphere in second row, second column + -- ambient, diffuse and specular reflection; low shininess + draw 2 2 matAmbient matDiffuse matSpecular lowShininess noMat + + -- draw sphere in second row, third column + -- ambient, diffuse and specular reflection; high shininess + draw 2 3 matAmbient matDiffuse matSpecular highShininess noMat + + -- draw sphere in second row, fourth column + -- ambient and diffuse reflection; emission; no specular + draw 2 4 matAmbient matDiffuse noMat noShininess matEmission + + -- draw sphere in third row, first column + -- colored ambient and diffuse reflection; no specular + draw 3 1 matAmbientColor matDiffuse noMat noShininess noMat + + -- draw sphere in third row, second column + -- colored ambient, diffuse and specular reflection; low shininess + draw 3 2 matAmbientColor matDiffuse matSpecular lowShininess noMat + + -- draw sphere in third row, third column + -- colored ambient, diffuse and specular reflection; high shininess + draw 3 3 matAmbientColor matDiffuse matSpecular highShininess noMat + + -- draw sphere in third row, fourth column + -- colored ambient and diffuse reflection; emission; no specular + draw 3 4 matAmbientColor matDiffuse noMat noShininess matEmission + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h * 2 + then ortho (-6) 6 (-3 * (hf * 2) / wf) (3 * (hf * 2) / wf) (-10) 10 + else ortho (-6 * wf / (hf * 2)) (6 * wf / (hf * 2)) (-3) 3 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 600 450 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Minmax.hs b/examples/RedBook4/Minmax.hs --- a/examples/RedBook4/Minmax.hs +++ b/examples/RedBook4/Minmax.hs @@ -1,64 +1,64 @@ -{- - Minmax.hs (adapted from minmax.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Determine the minimum and maximum values of a group of pixels. This - demonstrates use of the minmax function. --} - -import Foreign ( allocaArray, peekArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT -import ReadImage - -myInit :: IO () -myInit = do - rowAlignment Unpack $= 1 - clearColor $= Color4 0 0 0 0 - minmax $= Just (RGB', PassThrough) - -display :: Size -> PixelData a -> DisplayCallback -display size pixels = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - rasterPos2i (Vertex2 1 1) - drawPixels size pixels - flush - - [Color3 minR minG minB, Color3 maxR maxG maxB] <- allocaArray 2 $ \buf -> do - getMinmax Reset (PixelData RGB UnsignedByte buf) - peekArray 2 buf :: IO [Color3 GLubyte] - putStrLn (" Red : min = " ++ show minR ++ " max = " ++ show maxR) - putStrLn (" Green : min = " ++ show minG ++ " max = " ++ show maxG) - putStrLn (" Blue : min = " ++ show minB ++ " max = " ++ show maxB) - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, args) <- getArgsAndInitialize - (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= size - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display size pixels - mainLoop +{- + Minmax.hs (adapted from minmax.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Determine the minimum and maximum values of a group of pixels. This + demonstrates use of the minmax function. +-} + +import Foreign ( allocaArray, peekArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT +import ReadImage + +myInit :: IO () +myInit = do + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + minmax $= Just (RGB', PassThrough) + +display :: Size -> PixelData a -> DisplayCallback +display size pixels = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 1 1) + drawPixels size pixels + flush + + [Color3 minR minG minB, Color3 maxR maxG maxB] <- allocaArray 2 $ \buf -> do + getMinmax Reset (PixelData RGB UnsignedByte buf) + peekArray 2 buf :: IO [Color3 GLubyte] + putStrLn (" Red : min = " ++ show minR ++ " max = " ++ show maxR) + putStrLn (" Green : min = " ++ show minG ++ " max = " ++ show maxG) + putStrLn (" Blue : min = " ++ show minB ++ " max = " ++ show maxB) + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, args) <- getArgsAndInitialize + (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= size + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display size pixels + mainLoop diff --git a/examples/RedBook4/Mipmap.hs b/examples/RedBook4/Mipmap.hs --- a/examples/RedBook4/Mipmap.hs +++ b/examples/RedBook4/Mipmap.hs @@ -1,97 +1,97 @@ -{- - Mipmap.hs (adapted from mipmap.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates using mipmaps for texture maps. To overtly show - the effect of mipmaps, each mipmap reduction level has a solidly colored, - contrasting texture image. Thus, the quadrilateral which is drawn is drawn - with several different colors. --} - -import Control.Monad ( when ) -import Data.Maybe ( isJust ) -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -makeImage :: Level -> TextureSize2D -> Color4 GLubyte -> IO () -makeImage level size@(TextureSize2D w h) col = - withArray (replicate (fromIntegral (w * h)) col) $ - texImage2D Texture2D NoProxy level RGBA' size 0 . PixelData RGBA UnsignedByte - -makeImages :: [Color4 GLubyte] -> IO () -makeImages colors = sequence_ $ zipWith3 makeImage levels sizes colors - where numLevels = length colors - levels = [ 0 .. fromIntegral numLevels - 1 ] - sizes = reverse (take numLevels [ TextureSize2D s s | s <- iterate (* 2) 1 ]) - -myInit :: IO (Maybe TextureObject) -myInit = do - depthFunc $= Just Less - shadeModel $= Flat - - translate (Vector3 0 0 (-3.6 :: GLfloat)) - rowAlignment Unpack $= 1 - - exts <- get glExtensions - mbTexName <- if "GL_EXT_texture_object" `elem` exts - then fmap Just genObjectName - else return Nothing - when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName - - textureWrapMode Texture2D S $= (Repeated, Repeat) - textureWrapMode Texture2D T $= (Repeated, Repeat) - textureFilter Texture2D $= ((Nearest, Just Nearest), Nearest) - - makeImages [ Color4 255 255 0 255, - Color4 255 0 255 255, - Color4 255 0 0 255, - Color4 0 255 0 255, - Color4 0 0 255 255, - Color4 255 255 255 255 ] - - textureFunction $= Decal - texture Texture2D $= Enabled - return mbTexName - -display :: Maybe TextureObject -> DisplayCallback -display mbTexName = do - clear [ ColorBuffer, DepthBuffer ] - when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName - -- resolve overloading, not needed in "real" programs - let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - renderPrimitive Quads $ do - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 ( -2) (-1) 0 ) - texCoord2f (TexCoord2 0 8); vertex3f (Vertex3 ( -2) 1 0 ) - texCoord2f (TexCoord2 8 8); vertex3f (Vertex3 2000 1 (-6000)) - texCoord2f (TexCoord2 8 0); vertex3f (Vertex3 2000 (-1) (-6000)) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 60 (fromIntegral w / fromIntegral h) 1 30000 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 50 50 - _ <- createWindow progName - texName <- myInit - displayCallback $= display texName - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Mipmap.hs (adapted from mipmap.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates using mipmaps for texture maps. To overtly show + the effect of mipmaps, each mipmap reduction level has a solidly colored, + contrasting texture image. Thus, the quadrilateral which is drawn is drawn + with several different colors. +-} + +import Control.Monad ( when ) +import Data.Maybe ( isJust ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +makeImage :: Level -> TextureSize2D -> Color4 GLubyte -> IO () +makeImage level size@(TextureSize2D w h) col = + withArray (replicate (fromIntegral (w * h)) col) $ + texImage2D Texture2D NoProxy level RGBA' size 0 . PixelData RGBA UnsignedByte + +makeImages :: [Color4 GLubyte] -> IO () +makeImages colors = sequence_ $ zipWith3 makeImage levels sizes colors + where numLevels = length colors + levels = [ 0 .. fromIntegral numLevels - 1 ] + sizes = reverse (take numLevels [ TextureSize2D s s | s <- iterate (* 2) 1 ]) + +myInit :: IO (Maybe TextureObject) +myInit = do + depthFunc $= Just Less + shadeModel $= Flat + + translate (Vector3 0 0 (-3.6 :: GLfloat)) + rowAlignment Unpack $= 1 + + exts <- get glExtensions + mbTexName <- if "GL_EXT_texture_object" `elem` exts + then fmap Just genObjectName + else return Nothing + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Just Nearest), Nearest) + + makeImages [ Color4 255 255 0 255, + Color4 255 0 255 255, + Color4 255 0 0 255, + Color4 0 255 0 255, + Color4 0 0 255 255, + Color4 255 255 255 255 ] + + textureFunction $= Decal + texture Texture2D $= Enabled + return mbTexName + +display :: Maybe TextureObject -> DisplayCallback +display mbTexName = do + clear [ ColorBuffer, DepthBuffer ] + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + -- resolve overloading, not needed in "real" programs + let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 ( -2) (-1) 0 ) + texCoord2f (TexCoord2 0 8); vertex3f (Vertex3 ( -2) 1 0 ) + texCoord2f (TexCoord2 8 8); vertex3f (Vertex3 2000 1 (-6000)) + texCoord2f (TexCoord2 8 0); vertex3f (Vertex3 2000 (-1) (-6000)) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30000 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 50 50 + _ <- createWindow progName + texName <- myInit + displayCallback $= display texName + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Model.hs b/examples/RedBook4/Model.hs --- a/examples/RedBook4/Model.hs +++ b/examples/RedBook4/Model.hs @@ -1,86 +1,86 @@ -{- - Model.hs (adapted from model.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates modeling transformations. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - -drawTriangle :: IO () -drawTriangle = do - -- resolve overloading, not needed in "real" programs - let vertex2f = vertex :: Vertex2 GLfloat -> IO () - renderPrimitive LineLoop $ do - vertex2f (Vertex2 0 25 ) - vertex2f (Vertex2 25 (-25)) - vertex2f (Vertex2 (-25) (-25)) - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - translatef = translate :: Vector3 GLfloat -> IO () - scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () - rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () - color3f (Color3 1 1 1) - - loadIdentity - color3f (Color3 1 1 1) - drawTriangle - - lineStipple $= Just (1, 0xF0F0) - loadIdentity - translatef (Vector3 (-20) 0 0) - drawTriangle - - lineStipple $= Just (1, 0xF00F) - loadIdentity - scalef 1.5 0.5 1.0 - drawTriangle - - lineStipple $= Just (1, 0x8888) - loadIdentity - rotatef 90 (Vector3 0 0 1) - drawTriangle - lineStipple $= Nothing - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-50) 50 (-50 * hf/wf) (50 * hf/wf) (-1) 1 - else ortho (-50 * wf/hf) (50 * wf/hf) (-50) 50 (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Model.hs (adapted from model.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates modeling transformations. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +drawTriangle :: IO () +drawTriangle = do + -- resolve overloading, not needed in "real" programs + let vertex2f = vertex :: Vertex2 GLfloat -> IO () + renderPrimitive LineLoop $ do + vertex2f (Vertex2 0 25 ) + vertex2f (Vertex2 25 (-25)) + vertex2f (Vertex2 (-25) (-25)) + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + color3f (Color3 1 1 1) + + loadIdentity + color3f (Color3 1 1 1) + drawTriangle + + lineStipple $= Just (1, 0xF0F0) + loadIdentity + translatef (Vector3 (-20) 0 0) + drawTriangle + + lineStipple $= Just (1, 0xF00F) + loadIdentity + scalef 1.5 0.5 1.0 + drawTriangle + + lineStipple $= Just (1, 0x8888) + loadIdentity + rotatef 90 (Vector3 0 0 1) + drawTriangle + lineStipple $= Nothing + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-50) 50 (-50 * hf/wf) (50 * hf/wf) (-1) 1 + else ortho (-50 * wf/hf) (50 * wf/hf) (-50) 50 (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/MoveLight.hs b/examples/RedBook4/MoveLight.hs --- a/examples/RedBook4/MoveLight.hs +++ b/examples/RedBook4/MoveLight.hs @@ -1,85 +1,85 @@ -{- - MoveLight.hs (adapted from movelight.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates when to issue lighting and transformation - commands to render a model with a light which is moved by a - modeling transformation (rotate or translate). The light position - is reset after the modeling transformation is called. The eye - position does not change. - - A sphere is drawn using a grey material characteristic. A single - light source illuminates the object. - - Interaction: pressing the left mouse button alters the modeling - transformation (x rotation) by 30 degrees. The scene is then - redrawn with the light in a new position. --} - -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { spin :: IORef Int } - -makeState :: IO State -makeState = do - s <- newIORef 0 - return $ State { spin = s } - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Smooth - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) - preservingMatrix $ do - s <- get (spin state) - rotate (fromIntegral s :: GLdouble) (Vector3 1 0 0) - position (Light 0) $= Vertex4 0 0 1.5 1 - translate (Vector3 0 0 1.5 :: Vector3 GLdouble) - lighting $= Disabled - color (Color3 0 1 1 :: Color3 GLfloat) - renderObject Wireframe (Cube 0.1) - lighting $= Enabled - renderObject Solid (Torus 0.275 0.85 8 15) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 40 (fromIntegral w / fromIntegral h) 1 20 - matrixMode $= Modelview 0 - loadIdentity - -keyboardMouse :: State -> KeyboardMouseCallback -keyboardMouse state (MouseButton LeftButton) Down _ _ = do - spin state $~ ((`mod` 360) . (+ 30)) - postRedisplay Nothing -keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess -keyboardMouse _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - state <- makeState - myInit - displayCallback $= display state - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboardMouse state) - mainLoop +{- + MoveLight.hs (adapted from movelight.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates when to issue lighting and transformation + commands to render a model with a light which is moved by a + modeling transformation (rotate or translate). The light position + is reset after the modeling transformation is called. The eye + position does not change. + + A sphere is drawn using a grey material characteristic. A single + light source illuminates the object. + + Interaction: pressing the left mouse button alters the modeling + transformation (x rotation) by 30 degrees. The scene is then + redrawn with the light in a new position. +-} + +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { spin :: IORef Int } + +makeState :: IO State +makeState = do + s <- newIORef 0 + return $ State { spin = s } + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) + preservingMatrix $ do + s <- get (spin state) + rotate (fromIntegral s :: GLdouble) (Vector3 1 0 0) + position (Light 0) $= Vertex4 0 0 1.5 1 + translate (Vector3 0 0 1.5 :: Vector3 GLdouble) + lighting $= Disabled + color (Color3 0 1 1 :: Color3 GLfloat) + renderObject Wireframe (Cube 0.1) + lighting $= Enabled + renderObject Solid (Torus 0.275 0.85 8 15) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 40 (fromIntegral w / fromIntegral h) 1 20 + matrixMode $= Modelview 0 + loadIdentity + +keyboardMouse :: State -> KeyboardMouseCallback +keyboardMouse state (MouseButton LeftButton) Down _ _ = do + spin state $~ ((`mod` 360) . (+ 30)) + postRedisplay Nothing +keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboardMouse _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboardMouse state) + mainLoop diff --git a/examples/RedBook4/MultiTex.hs b/examples/RedBook4/MultiTex.hs --- a/examples/RedBook4/MultiTex.hs +++ b/examples/RedBook4/MultiTex.hs @@ -1,111 +1,111 @@ -{- - MultiTex.hs (adapted from multitex.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE --} - -import Control.Monad ( unless ) -import Foreign ( withArray ) -import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -specifyTexture :: TextureSize2D -> (GLubyte -> GLubyte -> Color4 GLubyte) -> IO () -specifyTexture size@(TextureSize2D w h) f = - withArray [ f i j | i <- [ 0 .. fromIntegral w - 1 ], - j <- [ 0 .. fromIntegral h - 1] ] $ - texImage2D Texture2D NoProxy 0 RGBA' size 0 . PixelData RGBA UnsignedByte - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - depthFunc $= Just Less - rowAlignment Unpack $= 1 - - [texName0, texName1] <- genObjectNames 2 - textureBinding Texture2D $= Just texName0 - -- Note: We use much brighter colors than in the original example where - -- everything was almost black. - specifyTexture (TextureSize2D 32 32) (\i j -> Color4 (i*8) (j*8) ((i*j) `div` 4) 255) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - textureWrapMode Texture2D S $= (Repeated, Repeat) - textureWrapMode Texture2D T $= (Repeated, Repeat) - - textureBinding Texture2D $= Just texName1 - specifyTexture (TextureSize2D 16 16) (\i j -> Color4 255 (i*16) (j*16) 255) - textureFilter Texture2D $= ((Linear', Nothing), Linear') - textureWrapMode Texture2D S $= (Repeated, ClampToEdge) - textureWrapMode Texture2D T $= (Repeated, ClampToEdge) - -- Use the two texture objects to define two texture units - -- for use in multitexturing - activeTexture $= TextureUnit 0 - texture Texture2D $= Enabled - textureBinding Texture2D $= Just texName0 - textureFunction $= Replace - matrixMode $= Texture - loadIdentity - translate (Vector3 0.5 0.5 (0 :: GLfloat)) - rotate (45 :: GLfloat) (Vector3 0 0 1) - translate (Vector3 (-0.5) (-0.5) (0 :: GLfloat)) - matrixMode $= Modelview 0 - activeTexture $= TextureUnit 1 - texture Texture2D $= Enabled - textureBinding Texture2D $= Just texName1 - textureFunction $= Modulate - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - -- resolve overloading, not needed in "real" programs - let multiTexCoord2f = multiTexCoord :: TextureUnit -> TexCoord2 GLfloat -> IO () - vertex2f = vertex :: Vertex2 GLfloat -> IO () - renderPrimitive Triangles $ do - multiTexCoord2f (TextureUnit 0) (TexCoord2 0 0) - multiTexCoord2f (TextureUnit 1) (TexCoord2 1 0) - vertex2f (Vertex2 0 0) - multiTexCoord2f (TextureUnit 0) (TexCoord2 0.5 1) - multiTexCoord2f (TextureUnit 1) (TexCoord2 0.5 0) - vertex2f (Vertex2 50 100) - multiTexCoord2f (TextureUnit 0) (TexCoord2 1 0) - multiTexCoord2f (TextureUnit 1) (TexCoord2 1 1) - vertex2f (Vertex2 100 0) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho2D 0 100 0 (100*hf/wf) - else ortho2D 0 (100*wf/hf) 0 100 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - -- we have to do this *after* createWindow, otherwise we have no OpenGL context - version <- get (majorMinor glVersion) - unless (version >= (1, 3)) $ do - exts <- get glExtensions - unless ("GL_ARB_multitexture" `elem` exts && -- part of 1.3 core - "GL_EXT_texture_object" `elem` exts) $ do -- part of 1.1 core - putStrLn "Sorry, this demo requires the GL_ARB_multitexture and GL_EXT_texture_object extensions." - exitFailure - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop +{- + MultiTex.hs (adapted from multitex.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( unless ) +import Foreign ( withArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +specifyTexture :: TextureSize2D -> (GLubyte -> GLubyte -> Color4 GLubyte) -> IO () +specifyTexture size@(TextureSize2D w h) f = + withArray [ f i j | i <- [ 0 .. fromIntegral w - 1 ], + j <- [ 0 .. fromIntegral h - 1] ] $ + texImage2D Texture2D NoProxy 0 RGBA' size 0 . PixelData RGBA UnsignedByte + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + rowAlignment Unpack $= 1 + + [texName0, texName1] <- genObjectNames 2 + textureBinding Texture2D $= Just texName0 + -- Note: We use much brighter colors than in the original example where + -- everything was almost black. + specifyTexture (TextureSize2D 32 32) (\i j -> Color4 (i*8) (j*8) ((i*j) `div` 4) 255) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + + textureBinding Texture2D $= Just texName1 + specifyTexture (TextureSize2D 16 16) (\i j -> Color4 255 (i*16) (j*16) 255) + textureFilter Texture2D $= ((Linear', Nothing), Linear') + textureWrapMode Texture2D S $= (Repeated, ClampToEdge) + textureWrapMode Texture2D T $= (Repeated, ClampToEdge) + -- Use the two texture objects to define two texture units + -- for use in multitexturing + activeTexture $= TextureUnit 0 + texture Texture2D $= Enabled + textureBinding Texture2D $= Just texName0 + textureFunction $= Replace + matrixMode $= Texture + loadIdentity + translate (Vector3 0.5 0.5 (0 :: GLfloat)) + rotate (45 :: GLfloat) (Vector3 0 0 1) + translate (Vector3 (-0.5) (-0.5) (0 :: GLfloat)) + matrixMode $= Modelview 0 + activeTexture $= TextureUnit 1 + texture Texture2D $= Enabled + textureBinding Texture2D $= Just texName1 + textureFunction $= Modulate + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + -- resolve overloading, not needed in "real" programs + let multiTexCoord2f = multiTexCoord :: TextureUnit -> TexCoord2 GLfloat -> IO () + vertex2f = vertex :: Vertex2 GLfloat -> IO () + renderPrimitive Triangles $ do + multiTexCoord2f (TextureUnit 0) (TexCoord2 0 0) + multiTexCoord2f (TextureUnit 1) (TexCoord2 1 0) + vertex2f (Vertex2 0 0) + multiTexCoord2f (TextureUnit 0) (TexCoord2 0.5 1) + multiTexCoord2f (TextureUnit 1) (TexCoord2 0.5 0) + vertex2f (Vertex2 50 100) + multiTexCoord2f (TextureUnit 0) (TexCoord2 1 0) + multiTexCoord2f (TextureUnit 1) (TexCoord2 1 1) + vertex2f (Vertex2 100 0) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D 0 100 0 (100*hf/wf) + else ortho2D 0 (100*wf/hf) 0 100 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + version <- get (majorMinor glVersion) + unless (version >= (1, 3)) $ do + exts <- get glExtensions + unless ("GL_ARB_multitexture" `elem` exts && -- part of 1.3 core + "GL_EXT_texture_object" `elem` exts) $ do -- part of 1.1 core + putStrLn "Sorry, this demo requires the GL_ARB_multitexture and GL_EXT_texture_object extensions." + exitFailure + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Multisamp.hs b/examples/RedBook4/Multisamp.hs --- a/examples/RedBook4/Multisamp.hs +++ b/examples/RedBook4/Multisamp.hs @@ -1,137 +1,137 @@ -{- - Multisamp.hs (adapted from multisamp.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws shows how to use multisampling to draw anti-aliased - geometric primitives. The same display list, a pinwheel of triangles and - lines of varying widths, is rendered twice. Multisampling is enabled when the - left side is drawn. Multisampling is disabled when the right side is drawn. - - Pressing the 'b' key toggles drawing of the checkerboard background. - Antialiasing is sometimes easier to see when objects are rendered over a - contrasting background. --} - -import Control.Monad ( when ) -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { bgToggle :: IORef Bool } - -makeState :: IO State -makeState = do - b <- newIORef True - return $ State { bgToggle = b } - -data DisplayLists = DisplayLists { pinwheelList, backgroundList :: DisplayList } - --- Print out state values related to multisampling. Create display list with --- "pinwheel" of lines and triangles. -myInit :: IO DisplayLists -myInit = do - clearColor $= Color4 0 0 0 0 - sb <- get sampleBuffers - putStrLn ("number of sample buffers is " ++ show sb) - s <- get samples - putStrLn ("number of samples is " ++ show s) - - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - vertex2f = vertex :: Vertex2 GLfloat -> IO () - - p <- defineNewList Compile $ do - flip mapM_ [ 0 .. 18 ] $ \i -> - preservingMatrix $ do - rotate (360 * fromIntegral i / 19 :: GLfloat) (Vector3 0 0 1) - color3f (Color3 1 1 1) - lineWidth $= fromIntegral ((i `mod` 3 :: Int) + 1) - renderPrimitive Lines $ do - vertex2f (Vertex2 0.25 0.05) - vertex2f (Vertex2 0.9 0.2) - color3f (Color3 0 1 1) - renderPrimitive Triangles $ do - vertex2f (Vertex2 0.25 0) - vertex2f (Vertex2 0.9 0) - vertex2f (Vertex2 0.875 0.1) - - b <- defineNewList Compile $ do - color3f (Color3 1 0.5 0) - renderPrimitive Quads $ - flip mapM_ [ 0 .. 15 ] $ \i -> - flip mapM_ [ 0 .. 15 ] $ \j -> - when (((i + j) `mod` 2 :: Int) == 0) $ do - let ii = fromIntegral i * 0.25 - jj = fromIntegral j * 0.25 - vertex2f (Vertex2 (-2.0 + ii) (-2.0 + jj)) - vertex2f (Vertex2 (-2.0 + ii) (-1.75 + jj)) - vertex2f (Vertex2 (-1.75 + ii) (-1.75 + jj)) - vertex2f (Vertex2 (-1.75 + ii) (-2.0 + jj)) - - return $ DisplayLists { pinwheelList = p, backgroundList = b } - --- Draw two sets of primitives, so that you can compare the user of --- multisampling against its absence. --- --- This code enables antialiasing and draws one display list and disables and --- draws the other display list -display :: State -> DisplayLists -> DisplayCallback -display state displayLists = do - clear [ ColorBuffer ] - - t <- get (bgToggle state) - when t $ - callList (backgroundList displayLists) - - -- resolve overloading, not needed in "real" programs - let translatef = translate :: Vector3 GLfloat -> IO () - - multisample $= Enabled - preservingMatrix $ do - translatef (Vector3 (-1) 0 0) - callList (pinwheelList displayLists) - - multisample $= Disabled - preservingMatrix $ do - translatef (Vector3 1 0 0) - callList (pinwheelList displayLists) - - swapBuffers - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= 2 * h - then ortho2D (-2) 2 (-2*hf/wf) (2*hf/wf) - else ortho2D (-2*wf/hf) (2*wf/hf) (-2) 2 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case toLower c of - 'b' -> do bgToggle state $~ not; postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ DoubleBuffered, RGBMode, Multisampling ] - initialWindowSize $= Size 600 300 - _ <- createWindow progName - state <- makeState - displayLists <- myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - displayCallback $= display state displayLists - mainLoop +{- + Multisamp.hs (adapted from multisamp.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws shows how to use multisampling to draw anti-aliased + geometric primitives. The same display list, a pinwheel of triangles and + lines of varying widths, is rendered twice. Multisampling is enabled when the + left side is drawn. Multisampling is disabled when the right side is drawn. + + Pressing the 'b' key toggles drawing of the checkerboard background. + Antialiasing is sometimes easier to see when objects are rendered over a + contrasting background. +-} + +import Control.Monad ( when ) +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { bgToggle :: IORef Bool } + +makeState :: IO State +makeState = do + b <- newIORef True + return $ State { bgToggle = b } + +data DisplayLists = DisplayLists { pinwheelList, backgroundList :: DisplayList } + +-- Print out state values related to multisampling. Create display list with +-- "pinwheel" of lines and triangles. +myInit :: IO DisplayLists +myInit = do + clearColor $= Color4 0 0 0 0 + sb <- get sampleBuffers + putStrLn ("number of sample buffers is " ++ show sb) + s <- get samples + putStrLn ("number of samples is " ++ show s) + + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + vertex2f = vertex :: Vertex2 GLfloat -> IO () + + p <- defineNewList Compile $ do + flip mapM_ [ 0 .. 18 ] $ \i -> + preservingMatrix $ do + rotate (360 * fromIntegral i / 19 :: GLfloat) (Vector3 0 0 1) + color3f (Color3 1 1 1) + lineWidth $= fromIntegral ((i `mod` 3 :: Int) + 1) + renderPrimitive Lines $ do + vertex2f (Vertex2 0.25 0.05) + vertex2f (Vertex2 0.9 0.2) + color3f (Color3 0 1 1) + renderPrimitive Triangles $ do + vertex2f (Vertex2 0.25 0) + vertex2f (Vertex2 0.9 0) + vertex2f (Vertex2 0.875 0.1) + + b <- defineNewList Compile $ do + color3f (Color3 1 0.5 0) + renderPrimitive Quads $ + flip mapM_ [ 0 .. 15 ] $ \i -> + flip mapM_ [ 0 .. 15 ] $ \j -> + when (((i + j) `mod` 2 :: Int) == 0) $ do + let ii = fromIntegral i * 0.25 + jj = fromIntegral j * 0.25 + vertex2f (Vertex2 (-2.0 + ii) (-2.0 + jj)) + vertex2f (Vertex2 (-2.0 + ii) (-1.75 + jj)) + vertex2f (Vertex2 (-1.75 + ii) (-1.75 + jj)) + vertex2f (Vertex2 (-1.75 + ii) (-2.0 + jj)) + + return $ DisplayLists { pinwheelList = p, backgroundList = b } + +-- Draw two sets of primitives, so that you can compare the user of +-- multisampling against its absence. +-- +-- This code enables antialiasing and draws one display list and disables and +-- draws the other display list +display :: State -> DisplayLists -> DisplayCallback +display state displayLists = do + clear [ ColorBuffer ] + + t <- get (bgToggle state) + when t $ + callList (backgroundList displayLists) + + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + + multisample $= Enabled + preservingMatrix $ do + translatef (Vector3 (-1) 0 0) + callList (pinwheelList displayLists) + + multisample $= Disabled + preservingMatrix $ do + translatef (Vector3 1 0 0) + callList (pinwheelList displayLists) + + swapBuffers + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= 2 * h + then ortho2D (-2) 2 (-2*hf/wf) (2*hf/wf) + else ortho2D (-2*wf/hf) (2*wf/hf) (-2) 2 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'b' -> do bgToggle state $~ not; postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode, Multisampling ] + initialWindowSize $= Size 600 300 + _ <- createWindow progName + state <- makeState + displayLists <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state displayLists + mainLoop diff --git a/examples/RedBook4/PickDepth.hs b/examples/RedBook4/PickDepth.hs --- a/examples/RedBook4/PickDepth.hs +++ b/examples/RedBook4/PickDepth.hs @@ -1,126 +1,126 @@ -{- - PickDepth.hs (adapted from pickdepth.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Picking is demonstrated in this program. In rendering mode, three - overlapping rectangles are drawn. When the left mouse button is pressed, - selection mode is entered with the picking matrix. Rectangles which are drawn - under the cursor position are "picked." Pay special attention to the depth - value range, which is returned. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - depthFunc $= Just Less - shadeModel $= Flat - depthRange $= (0, 1) -- The default z mapping - --- The nine squares are drawn. Each square is given two names: one for the row --- and the other for the column on the grid. The color of each square is --- determined by its position on the grid, and the value in the board array. --- Note: In contrast to the the original example, we always give names to --- squares, regardless of the render mode. This simplifies the code a bit and --- is even suggested by the Red Book. - --- The three rectangles are drawn, each with a different name. Note that each --- rectangle is drawn with a different z value. Note: In contrast to the the --- original example, we always give names to squares, regardless of the render --- mode. This simplifies the code a bit and is even suggested by the Red Book. -drawRects :: IO () -drawRects = do - -- resolve overloading, not needed in "real" programs - let color3 = color :: Color3 GLfloat -> IO () - vertex3 = vertex :: Vertex3 GLint -> IO () - loadName (Name 1) - renderPrimitive Quads $ do - color3 (Color3 1.0 1.0 0.0) - vertex3 (Vertex3 2 0 0) - vertex3 (Vertex3 2 6 0) - vertex3 (Vertex3 6 6 0) - vertex3 (Vertex3 6 0 0) - loadName (Name 2) - renderPrimitive Quads $ do - color3 (Color3 0.0 1.0 1.0) - vertex3 (Vertex3 3 2 (-1)) - vertex3 (Vertex3 3 8 (-1)) - vertex3 (Vertex3 8 8 (-1)) - vertex3 (Vertex3 8 2 (-1)) - loadName (Name 3) - renderPrimitive Quads $ do - color3 (Color3 1.0 0.0 1.0) - vertex3 (Vertex3 0 2 (-2)) - vertex3 (Vertex3 0 7 (-2)) - vertex3 (Vertex3 5 7 (-2)) - vertex3 (Vertex3 5 2 (-2)) - --- processHits prints the hit records. -processHits :: Maybe[HitRecord] -> IO () -processHits Nothing = putStrLn "selection buffer overflow" -processHits (Just hitRecords) = do - putStrLn ("hits = " ++ show (length hitRecords)) - flip mapM_ hitRecords $ \(HitRecord z1 z2 names) -> do - putStrLn (" number of names for hit = " ++ show (length names)) - putStr (" z1 is " ++ show z1) - putStrLn ("; z2 is " ++ show z2) - putStr " the name is" - sequence_ [ putStr (" " ++ show n) | Name n <- names ] - putChar '\n' - --- pickRects() sets up selection mode, name stack, and projection matrix for --- picking. Then the objects are drawn. - -bufSize :: GLsizei -bufSize = 512 - -pickRects :: KeyboardMouseCallback -pickRects (MouseButton LeftButton) Down _ (Position x y) = do - vp@(_, (Size _ height)) <- get viewport - (_, maybeHitRecords) <- getHitRecords bufSize $ - withName (Name 0) $ do - matrixMode $= Projection - preservingMatrix $ do - loadIdentity - -- create 5x5 pixel picking region near cursor location - pickMatrix (fromIntegral x, fromIntegral height - fromIntegral y) (5, 5) vp - ortho 0 8 0 8 (-0.5) 2.5 - drawRects - flush - processHits maybeHitRecords - postRedisplay Nothing -pickRects (Char '\27') Down _ _ = exitWith ExitSuccess -pickRects _ _ _ _ = return () - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - drawRects - flush - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho 0 8 0 8 (-0.5) 2.5 - matrixMode $= Modelview 0 - loadIdentity - --- Main Loop -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 200 200 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just pickRects - mainLoop +{- + PickDepth.hs (adapted from pickdepth.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Picking is demonstrated in this program. In rendering mode, three + overlapping rectangles are drawn. When the left mouse button is pressed, + selection mode is entered with the picking matrix. Rectangles which are drawn + under the cursor position are "picked." Pay special attention to the depth + value range, which is returned. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + depthFunc $= Just Less + shadeModel $= Flat + depthRange $= (0, 1) -- The default z mapping + +-- The nine squares are drawn. Each square is given two names: one for the row +-- and the other for the column on the grid. The color of each square is +-- determined by its position on the grid, and the value in the board array. +-- Note: In contrast to the the original example, we always give names to +-- squares, regardless of the render mode. This simplifies the code a bit and +-- is even suggested by the Red Book. + +-- The three rectangles are drawn, each with a different name. Note that each +-- rectangle is drawn with a different z value. Note: In contrast to the the +-- original example, we always give names to squares, regardless of the render +-- mode. This simplifies the code a bit and is even suggested by the Red Book. +drawRects :: IO () +drawRects = do + -- resolve overloading, not needed in "real" programs + let color3 = color :: Color3 GLfloat -> IO () + vertex3 = vertex :: Vertex3 GLint -> IO () + loadName (Name 1) + renderPrimitive Quads $ do + color3 (Color3 1.0 1.0 0.0) + vertex3 (Vertex3 2 0 0) + vertex3 (Vertex3 2 6 0) + vertex3 (Vertex3 6 6 0) + vertex3 (Vertex3 6 0 0) + loadName (Name 2) + renderPrimitive Quads $ do + color3 (Color3 0.0 1.0 1.0) + vertex3 (Vertex3 3 2 (-1)) + vertex3 (Vertex3 3 8 (-1)) + vertex3 (Vertex3 8 8 (-1)) + vertex3 (Vertex3 8 2 (-1)) + loadName (Name 3) + renderPrimitive Quads $ do + color3 (Color3 1.0 0.0 1.0) + vertex3 (Vertex3 0 2 (-2)) + vertex3 (Vertex3 0 7 (-2)) + vertex3 (Vertex3 5 7 (-2)) + vertex3 (Vertex3 5 2 (-2)) + +-- processHits prints the hit records. +processHits :: Maybe[HitRecord] -> IO () +processHits Nothing = putStrLn "selection buffer overflow" +processHits (Just hitRecords) = do + putStrLn ("hits = " ++ show (length hitRecords)) + flip mapM_ hitRecords $ \(HitRecord z1 z2 names) -> do + putStrLn (" number of names for hit = " ++ show (length names)) + putStr (" z1 is " ++ show z1) + putStrLn ("; z2 is " ++ show z2) + putStr " the name is" + sequence_ [ putStr (" " ++ show n) | Name n <- names ] + putChar '\n' + +-- pickRects() sets up selection mode, name stack, and projection matrix for +-- picking. Then the objects are drawn. + +bufSize :: GLsizei +bufSize = 512 + +pickRects :: KeyboardMouseCallback +pickRects (MouseButton LeftButton) Down _ (Position x y) = do + vp@(_, (Size _ height)) <- get viewport + (_, maybeHitRecords) <- getHitRecords bufSize $ + withName (Name 0) $ do + matrixMode $= Projection + preservingMatrix $ do + loadIdentity + -- create 5x5 pixel picking region near cursor location + pickMatrix (fromIntegral x, fromIntegral height - fromIntegral y) (5, 5) vp + ortho 0 8 0 8 (-0.5) 2.5 + drawRects + flush + processHits maybeHitRecords + postRedisplay Nothing +pickRects (Char '\27') Down _ _ = exitWith ExitSuccess +pickRects _ _ _ _ = return () + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + drawRects + flush + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 8 0 8 (-0.5) 2.5 + matrixMode $= Modelview 0 + loadIdentity + +-- Main Loop +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 200 200 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just pickRects + mainLoop diff --git a/examples/RedBook4/PickSquare.hs b/examples/RedBook4/PickSquare.hs --- a/examples/RedBook4/PickSquare.hs +++ b/examples/RedBook4/PickSquare.hs @@ -1,121 +1,121 @@ -{- - PickSquare.hs (adapted from picksquare.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Use of multiple names and picking are demonstrated. A 3x3 grid of squares is - drawn. When the left mouse button is pressed, all squares under the cursor - position have their color changed. --} - -import Data.Array ( Array, listArray, (!) ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -type Board = Array (Int,Int) (IORef Int) - -data State = State { board :: Board } - -makeState :: IO State -makeState = do - refs <- sequence . replicate 9 . newIORef $ 0 - return $ State { board = listArray ((0,0),(2,2)) refs } - --- Clear color value for every square on the board -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - --- The nine squares are drawn. Each square is given two names: one for the row --- and the other for the column on the grid. The color of each square is --- determined by its position on the grid, and the value in the board array. --- Note: In contrast to the the original example, we always give names to --- squares, regardless of the render mode. This simplifies the code a bit and --- is even suggested by the Red Book. -drawSquares :: State -> IO () -drawSquares state = - flip mapM_ [ 0 .. 2 ] $ \i -> do - loadName (Name (fromIntegral i)) - flip mapM_ [ 0 .. 2 ] $ \j -> - withName (Name (fromIntegral j)) $ do - val <- get (board state ! (i,j)) - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - color3f (Color3 (fromIntegral i / 3.0) - (fromIntegral j / 3.0) - (fromIntegral val / 3.0)) - let vertex2i :: Int -> Int -> Vertex2 GLint - vertex2i x y = Vertex2 (fromIntegral x) (fromIntegral y) - rect (vertex2i i j) (vertex2i (i + 1) (j + 1)) - --- processHits prints the hit records and updates the board array. -processHits :: Maybe[HitRecord] -> State -> IO () -processHits Nothing _ = putStrLn "selection buffer overflow" -processHits (Just hitRecords) state = do - putStrLn ("hits = " ++ show (length hitRecords)) - mapM_ (\(HitRecord z1 z2 names) -> do - putStrLn (" number of names for this hit = " ++ show (length names)) - putStr (" z1 is " ++ show z1) - putStrLn ("; z2 is " ++ show z2) - putStr " names are" - sequence_ [ putStr (" " ++ show n) | Name n <- names ] - putChar '\n' - let [i, j] = [ fromIntegral n | Name n <- names ] - (board state ! (i,j)) $~ (\x -> (x + 1) `mod` 3)) - hitRecords - --- pickSquares sets up selection mode, name stack, and projection matrix for --- picking. Then the objects are drawn. - -bufSize :: GLsizei -bufSize = 512 - -pickSquares :: State -> KeyboardMouseCallback -pickSquares state (MouseButton LeftButton) Down _ (Position x y) = do - vp@(_, (Size _ height)) <- get viewport - (_, maybeHitRecords) <- getHitRecords bufSize $ - withName (Name 0) $ do - matrixMode $= Projection - preservingMatrix $ do - loadIdentity - -- create 5x5 pixel picking region near cursor location - pickMatrix (fromIntegral x, fromIntegral height - fromIntegral y) (5, 5) vp - ortho2D 0 3 0 3 - drawSquares state - flush - processHits maybeHitRecords state - postRedisplay Nothing -pickSquares _ (Char '\27') Down _ _ = exitWith ExitSuccess -pickSquares _ _ _ _ _ = return () - -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer ] - drawSquares state - flush - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 3 0 3 - matrixMode $= Modelview 0 - loadIdentity - --- Main Loop -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 100 100 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - state <- makeState - myInit - reshapeCallback $= Just reshape - displayCallback $= display state - keyboardMouseCallback $= Just (pickSquares state) - mainLoop +{- + PickSquare.hs (adapted from picksquare.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Use of multiple names and picking are demonstrated. A 3x3 grid of squares is + drawn. When the left mouse button is pressed, all squares under the cursor + position have their color changed. +-} + +import Data.Array ( Array, listArray, (!) ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +type Board = Array (Int,Int) (IORef Int) + +data State = State { board :: Board } + +makeState :: IO State +makeState = do + refs <- sequence . replicate 9 . newIORef $ 0 + return $ State { board = listArray ((0,0),(2,2)) refs } + +-- Clear color value for every square on the board +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + +-- The nine squares are drawn. Each square is given two names: one for the row +-- and the other for the column on the grid. The color of each square is +-- determined by its position on the grid, and the value in the board array. +-- Note: In contrast to the the original example, we always give names to +-- squares, regardless of the render mode. This simplifies the code a bit and +-- is even suggested by the Red Book. +drawSquares :: State -> IO () +drawSquares state = + flip mapM_ [ 0 .. 2 ] $ \i -> do + loadName (Name (fromIntegral i)) + flip mapM_ [ 0 .. 2 ] $ \j -> + withName (Name (fromIntegral j)) $ do + val <- get (board state ! (i,j)) + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 (fromIntegral i / 3.0) + (fromIntegral j / 3.0) + (fromIntegral val / 3.0)) + let vertex2i :: Int -> Int -> Vertex2 GLint + vertex2i x y = Vertex2 (fromIntegral x) (fromIntegral y) + rect (vertex2i i j) (vertex2i (i + 1) (j + 1)) + +-- processHits prints the hit records and updates the board array. +processHits :: Maybe[HitRecord] -> State -> IO () +processHits Nothing _ = putStrLn "selection buffer overflow" +processHits (Just hitRecords) state = do + putStrLn ("hits = " ++ show (length hitRecords)) + mapM_ (\(HitRecord z1 z2 names) -> do + putStrLn (" number of names for this hit = " ++ show (length names)) + putStr (" z1 is " ++ show z1) + putStrLn ("; z2 is " ++ show z2) + putStr " names are" + sequence_ [ putStr (" " ++ show n) | Name n <- names ] + putChar '\n' + let [i, j] = [ fromIntegral n | Name n <- names ] + (board state ! (i,j)) $~ (\x -> (x + 1) `mod` 3)) + hitRecords + +-- pickSquares sets up selection mode, name stack, and projection matrix for +-- picking. Then the objects are drawn. + +bufSize :: GLsizei +bufSize = 512 + +pickSquares :: State -> KeyboardMouseCallback +pickSquares state (MouseButton LeftButton) Down _ (Position x y) = do + vp@(_, (Size _ height)) <- get viewport + (_, maybeHitRecords) <- getHitRecords bufSize $ + withName (Name 0) $ do + matrixMode $= Projection + preservingMatrix $ do + loadIdentity + -- create 5x5 pixel picking region near cursor location + pickMatrix (fromIntegral x, fromIntegral height - fromIntegral y) (5, 5) vp + ortho2D 0 3 0 3 + drawSquares state + flush + processHits maybeHitRecords state + postRedisplay Nothing +pickSquares _ (Char '\27') Down _ _ = exitWith ExitSuccess +pickSquares _ _ _ _ _ = return () + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + drawSquares state + flush + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 3 0 3 + matrixMode $= Modelview 0 + loadIdentity + +-- Main Loop +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 100 100 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + myInit + reshapeCallback $= Just reshape + displayCallback $= display state + keyboardMouseCallback $= Just (pickSquares state) + mainLoop diff --git a/examples/RedBook4/Planet.hs b/examples/RedBook4/Planet.hs --- a/examples/RedBook4/Planet.hs +++ b/examples/RedBook4/Planet.hs @@ -1,83 +1,83 @@ -{- - Planet.hs (adapted from planet.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program shows how to composite modeling transformations to draw - translated and rotated models. Interaction: pressing the d and y keys - (day and year) alters the rotation of the planet around the sun. --} - -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { year, day :: IORef GLint } - -makeState :: IO State -makeState = do - y <- newIORef 0 - d <- newIORef 0 - return $ State { year = y, day = d } - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - translatef = translate :: Vector3 GLfloat -> IO () - color3f (Color3 1 1 1) - - preservingMatrix $ do - renderObject Wireframe (Sphere' 1 20 16) -- draw sun - y <- get (year state) - rotate (fromIntegral y :: GLfloat) (Vector3 0 1 0) - translatef (Vector3 2 0 0) - d <- get (day state) - rotate (fromIntegral d :: GLfloat) (Vector3 0 1 0) - renderObject Wireframe (Sphere' 0.2 10 8) -- draw smaller planet - - swapBuffers - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 60 (fromIntegral w / fromIntegral h) 1 20 - matrixMode $= Modelview 0 - loadIdentity - lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case c of - 'd' -> update day 10 - 'D' -> update day (-10) - 'y' -> update year 10 - 'Y' -> update year (-10) - '\27' -> exitWith ExitSuccess - _ -> return () - where update angle inc = do - angle state $~ ((`mod` 360) . (+ inc)) - postRedisplay Nothing -keyboard _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ DoubleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - state <- makeState - myInit - displayCallback $= display state - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - mainLoop +{- + Planet.hs (adapted from planet.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program shows how to composite modeling transformations to draw + translated and rotated models. Interaction: pressing the d and y keys + (day and year) alters the rotation of the planet around the sun. +-} + +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { year, day :: IORef GLint } + +makeState :: IO State +makeState = do + y <- newIORef 0 + d <- newIORef 0 + return $ State { year = y, day = d } + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + color3f (Color3 1 1 1) + + preservingMatrix $ do + renderObject Wireframe (Sphere' 1 20 16) -- draw sun + y <- get (year state) + rotate (fromIntegral y :: GLfloat) (Vector3 0 1 0) + translatef (Vector3 2 0 0) + d <- get (day state) + rotate (fromIntegral d :: GLfloat) (Vector3 0 1 0) + renderObject Wireframe (Sphere' 0.2 10 8) -- draw smaller planet + + swapBuffers + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 20 + matrixMode $= Modelview 0 + loadIdentity + lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case c of + 'd' -> update day 10 + 'D' -> update day (-10) + 'y' -> update year 10 + 'Y' -> update year (-10) + '\27' -> exitWith ExitSuccess + _ -> return () + where update angle inc = do + angle state $~ ((`mod` 360) . (+ inc)) + postRedisplay Nothing +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + mainLoop diff --git a/examples/RedBook4/PointP.hs b/examples/RedBook4/PointP.hs --- a/examples/RedBook4/PointP.hs +++ b/examples/RedBook4/PointP.hs @@ -1,152 +1,152 @@ -{- - PointP.hs (adapted from pointp.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates point parameters and their effect on point - primitives. 250 points are randomly generated within a 10 by 10 by 40 region, - centered at the origin. In some modes (including the default), points that - are closer to the viewer will appear larger. - - Pressing the 'c', 'l', and 'q' keys switch the point parameters attenuation - mode to constant, linear, or quadratic, respectively. - - Pressing the 'f' and 'b' keys move the viewer forward and backwards. In - either linear or quadratic attenuation mode, the distance from the viewer to - the point will change the size of the point primitive. - - Pressing the '+' and '-' keys will change the current point size. In this - program, the point size is bounded, so it will not get less than 2, nor - greater than the maximum returned by pointSizeRange. --} - -import Control.Monad ( when, unless ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure ) -import System.Random ( randomRIO ) -import Graphics.UI.GLUT - -type Attenuation = (GLfloat,GLfloat,GLfloat) - -constant, linear, quadratic :: Attenuation -constant = (1, 0, 0 ) -linear = (0, 0.12, 0 ) -quadratic = (0, 0, 0.01) - -data State = State { distance :: IORef GLfloat } - -makeState :: IO State -makeState = do - d <- newIORef (-10) - return $ State { distance = d } - --- CFloat has no Random instance, so we go via Float -randomGLfloat :: (GLfloat, GLfloat) -> IO GLfloat -randomGLfloat = fmap floatToGLfloat . randomRIO . fmapPair glFloatToFloat - where fmapPair f (x, y) = (f x, f y) - floatToGLfloat = realToFrac :: Float -> GLfloat - glFloatToFloat = realToFrac :: GLfloat -> Float - -randomColor :: IO (Color3 GLfloat) -randomColor = do - g <- randomGLfloat (0.5, 1) - b <- randomGLfloat (0, 1) - return $ Color3 1 g b - -randomVertex :: IO (Vertex3 GLfloat) -randomVertex = do - x <- randomGLfloat (-5, 5) - y <- randomGLfloat (-5, 5) - z <- randomGLfloat (-5, -45) - return $ Vertex3 x y z - -myInit :: IO DisplayList -myInit = do - pointList <- defineNewList Compile $ - renderPrimitive Points $ - sequence_ $ replicate 250 $ do - color =<< randomColor - vertex =<< randomVertex - - depthFunc $= Just Less - pointSmooth $= Enabled - blend $= Enabled - blendFunc $= (SrcAlpha, OneMinusSrcAlpha) - pointSize $= 7 - - pointDistanceAttenuation $= linear - pointFadeThresholdSize $= 2 - - return pointList - -display :: State -> DisplayList -> DisplayCallback -display state pointList = do - clear [ ColorBuffer, DepthBuffer ] - d <- get (distance state) - loadIdentity - translate (Vector3 0 0 d) - callList pointList - swapBuffers - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 35 1 0.25 200 - matrixMode $= Modelview 0 - -setPointDistanceAttenuation :: Attenuation -> IO () -setPointDistanceAttenuation att = do - pointDistanceAttenuation $= att - postRedisplay Nothing - -incDistance :: State -> GLfloat -> IO () -incDistance state inc = do - distance state $~ (+ inc) - postRedisplay Nothing - -incPointSize :: GLfloat -> IO () -incPointSize inc = do - newPointSize <- fmap (+ inc) $ get pointSize - (_,maxPointSize) <- get pointSizeRange - when (2 <= newPointSize && newPointSize <= maxPointSize) $ do - pointSize $= newPointSize - postRedisplay Nothing - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case c of - 'c' -> setPointDistanceAttenuation constant - 'l' -> setPointDistanceAttenuation linear - 'q' -> setPointDistanceAttenuation quadratic - 'b' -> incDistance state (-0.5) - 'f' -> incDistance state 0.5 - '+' -> incPointSize 1 - '-' -> incPointSize (-1) - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ RGBMode, DoubleBuffered, WithDepthBuffer, Multisampling ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - - -- We have to do this *after* createWindow, otherwise we have no OpenGL - -- context. Note that the original C example simply tests for OpenGL 1.4 at - -- compile time, we do a runtime check for the needed extension. - extensions <- get glExtensions - unless ("GL_ARB_point_parameters" `elem` extensions) $ do - putStrLn "Sorry, this demo requires the GL_ARB_point_parameters extension." - exitFailure - - state <- makeState - pointList <- myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - displayCallback $= display state pointList - mainLoop +{- + PointP.hs (adapted from pointp.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates point parameters and their effect on point + primitives. 250 points are randomly generated within a 10 by 10 by 40 region, + centered at the origin. In some modes (including the default), points that + are closer to the viewer will appear larger. + + Pressing the 'c', 'l', and 'q' keys switch the point parameters attenuation + mode to constant, linear, or quadratic, respectively. + + Pressing the 'f' and 'b' keys move the viewer forward and backwards. In + either linear or quadratic attenuation mode, the distance from the viewer to + the point will change the size of the point primitive. + + Pressing the '+' and '-' keys will change the current point size. In this + program, the point size is bounded, so it will not get less than 2, nor + greater than the maximum returned by pointSizeRange. +-} + +import Control.Monad ( when, unless ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure ) +import System.Random ( randomRIO ) +import Graphics.UI.GLUT + +type Attenuation = (GLfloat,GLfloat,GLfloat) + +constant, linear, quadratic :: Attenuation +constant = (1, 0, 0 ) +linear = (0, 0.12, 0 ) +quadratic = (0, 0, 0.01) + +data State = State { distance :: IORef GLfloat } + +makeState :: IO State +makeState = do + d <- newIORef (-10) + return $ State { distance = d } + +-- CFloat has no Random instance, so we go via Float +randomGLfloat :: (GLfloat, GLfloat) -> IO GLfloat +randomGLfloat = fmap floatToGLfloat . randomRIO . fmapPair glFloatToFloat + where fmapPair f (x, y) = (f x, f y) + floatToGLfloat = realToFrac :: Float -> GLfloat + glFloatToFloat = realToFrac :: GLfloat -> Float + +randomColor :: IO (Color3 GLfloat) +randomColor = do + g <- randomGLfloat (0.5, 1) + b <- randomGLfloat (0, 1) + return $ Color3 1 g b + +randomVertex :: IO (Vertex3 GLfloat) +randomVertex = do + x <- randomGLfloat (-5, 5) + y <- randomGLfloat (-5, 5) + z <- randomGLfloat (-5, -45) + return $ Vertex3 x y z + +myInit :: IO DisplayList +myInit = do + pointList <- defineNewList Compile $ + renderPrimitive Points $ + sequence_ $ replicate 250 $ do + color =<< randomColor + vertex =<< randomVertex + + depthFunc $= Just Less + pointSmooth $= Enabled + blend $= Enabled + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + pointSize $= 7 + + pointDistanceAttenuation $= linear + pointFadeThresholdSize $= 2 + + return pointList + +display :: State -> DisplayList -> DisplayCallback +display state pointList = do + clear [ ColorBuffer, DepthBuffer ] + d <- get (distance state) + loadIdentity + translate (Vector3 0 0 d) + callList pointList + swapBuffers + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 35 1 0.25 200 + matrixMode $= Modelview 0 + +setPointDistanceAttenuation :: Attenuation -> IO () +setPointDistanceAttenuation att = do + pointDistanceAttenuation $= att + postRedisplay Nothing + +incDistance :: State -> GLfloat -> IO () +incDistance state inc = do + distance state $~ (+ inc) + postRedisplay Nothing + +incPointSize :: GLfloat -> IO () +incPointSize inc = do + newPointSize <- fmap (+ inc) $ get pointSize + (_,maxPointSize) <- get pointSizeRange + when (2 <= newPointSize && newPointSize <= maxPointSize) $ do + pointSize $= newPointSize + postRedisplay Nothing + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case c of + 'c' -> setPointDistanceAttenuation constant + 'l' -> setPointDistanceAttenuation linear + 'q' -> setPointDistanceAttenuation quadratic + 'b' -> incDistance state (-0.5) + 'f' -> incDistance state 0.5 + '+' -> incPointSize 1 + '-' -> incPointSize (-1) + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ RGBMode, DoubleBuffered, WithDepthBuffer, Multisampling ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + + -- We have to do this *after* createWindow, otherwise we have no OpenGL + -- context. Note that the original C example simply tests for OpenGL 1.4 at + -- compile time, we do a runtime check for the needed extension. + extensions <- get glExtensions + unless ("GL_ARB_point_parameters" `elem` extensions) $ do + putStrLn "Sorry, this demo requires the GL_ARB_point_parameters extension." + exitFailure + + state <- makeState + pointList <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state pointList + mainLoop diff --git a/examples/RedBook4/PolyOff.hs b/examples/RedBook4/PolyOff.hs --- a/examples/RedBook4/PolyOff.hs +++ b/examples/RedBook4/PolyOff.hs @@ -1,151 +1,151 @@ -{- - PolyOff.hs (adapted from polyoff.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates polygon offset to draw a shaded polygon and its - wireframe counterpart without ugly visual artifacts ("stitching"). --} - -import Control.Monad ( when ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure ) -import Graphics.UI.GLUT - -data State = State { - spinX, spinY :: IORef GLfloat, - tDist :: IORef GLfloat, - polyFactor :: IORef GLfloat, - polyUnits :: IORef GLfloat - } - -makeState :: IO State -makeState = do - x <- newIORef 0 - y <- newIORef 0 - t <- newIORef 0 - f <- newIORef 1 - u <- newIORef 1 - return $ State { spinX = x, spinY = y, tDist = t, polyFactor = f, polyUnits = u } - --- display draws two spheres, one with a gray, diffuse material, the other --- sphere with a magenta material with a specular highlight. -display :: State -> DisplayList -> DisplayCallback -display state sphereList = do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - t <- get (tDist state) - translate (Vector3 0 0 t) - x <- get (spinX state) - rotate x (Vector3 1 0 0) - y <- get (spinY state) - rotate y (Vector3 0 1 0) - - materialAmbientAndDiffuse Front $= Color4 0.8 0.8 0.8 1 - materialSpecular Front $= Color4 0 0 0 1 - materialShininess Front $= 0 - lighting $= Enabled - light (Light 0) $= Enabled - polygonOffsetFill $= Enabled - f <- get (polyFactor state) - u <- get (polyUnits state) - polygonOffset $= (f, u) - callList sphereList - polygonOffsetFill $= Disabled - - lighting $= Disabled - light (Light 0) $= Disabled - color (Color3 1 1 (1 :: GLfloat)) - polygonMode $= (Line, Line) - callList sphereList - polygonMode $= (Fill, Fill) - - flush - --- specify initial properties --- create display list with sphere --- initialize lighting and depth buffer -gfxinit :: IO DisplayList -gfxinit = do - clearColor $= Color4 0 0 0 1 - - sphereList <- defineNewList Compile $ - renderObject Solid (Sphere' 1 20 12) - - depthFunc $= Just Less - - ambient (Light 0) $= Color4 0 0 0 1 - diffuse (Light 0) $= Color4 1 1 1 1 - specular (Light 0) $= Color4 1 1 1 1 - position (Light 0) $= Vertex4 1 1 1 0 - lightModelAmbient $= Color4 0.2 0.2 0.2 1 - - return sphereList - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 45 (fromIntegral w / fromIntegral h) 1 10 - matrixMode $= Modelview 0 - loadIdentity - lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) - -incSpin :: IORef GLfloat -> IO () -incSpin spinRef = do - let wrap n s = if s > n then s - n else s - spinRef $~ (wrap 360 . (+ 5)) - postRedisplay Nothing - -incDist :: State -> GLfloat -> IO () -incDist state inc = do - newDist <- fmap (+ inc) $ get (tDist state) - when (-5 <= newDist && newDist <= 4) $ do - tDist state $= newDist - postRedisplay Nothing - -incPoly :: String -> IORef GLfloat -> GLfloat -> IO () -incPoly name polyRef inc = do - polyRef $~ (+ inc) - p <- get polyRef - putStrLn (name ++ " is " ++ show p) - postRedisplay Nothing - -keyboardMouse :: State -> KeyboardMouseCallback -keyboardMouse state k Down _ _ = case k of - (MouseButton LeftButton) -> incSpin (spinX state) - (MouseButton MiddleButton) -> incSpin (spinY state) - (MouseButton RightButton) -> exitWith ExitSuccess - (Char 't') -> incDist state 0.5 - (Char 'T') -> incDist state (-0.5) - (Char 'F') -> incPoly "polyFactor" (polyFactor state) 0.1 - (Char 'f') -> incPoly "polyFactor" (polyFactor state) (-0.1) - (Char 'U') -> incPoly "polyUnits" (polyUnits state) 1 - (Char 'u') -> incPoly "polyUnits" (polyUnits state) (-1) - _ -> return () -keyboardMouse _ _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - _ <- createWindow progName - - -- we have to do this *after* createWindow, otherwise we have no OpenGL context - version <- get (majorMinor glVersion) - when (version == (1,0)) $ do - putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." - putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," - putStrLn "you may be able to modify this program to make it run." - exitFailure - - state <- makeState - sphereList <- gfxinit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboardMouse state) - displayCallback $= display state sphereList - mainLoop +{- + PolyOff.hs (adapted from polyoff.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates polygon offset to draw a shaded polygon and its + wireframe counterpart without ugly visual artifacts ("stitching"). +-} + +import Control.Monad ( when ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure ) +import Graphics.UI.GLUT + +data State = State { + spinX, spinY :: IORef GLfloat, + tDist :: IORef GLfloat, + polyFactor :: IORef GLfloat, + polyUnits :: IORef GLfloat + } + +makeState :: IO State +makeState = do + x <- newIORef 0 + y <- newIORef 0 + t <- newIORef 0 + f <- newIORef 1 + u <- newIORef 1 + return $ State { spinX = x, spinY = y, tDist = t, polyFactor = f, polyUnits = u } + +-- display draws two spheres, one with a gray, diffuse material, the other +-- sphere with a magenta material with a specular highlight. +display :: State -> DisplayList -> DisplayCallback +display state sphereList = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + t <- get (tDist state) + translate (Vector3 0 0 t) + x <- get (spinX state) + rotate x (Vector3 1 0 0) + y <- get (spinY state) + rotate y (Vector3 0 1 0) + + materialAmbientAndDiffuse Front $= Color4 0.8 0.8 0.8 1 + materialSpecular Front $= Color4 0 0 0 1 + materialShininess Front $= 0 + lighting $= Enabled + light (Light 0) $= Enabled + polygonOffsetFill $= Enabled + f <- get (polyFactor state) + u <- get (polyUnits state) + polygonOffset $= (f, u) + callList sphereList + polygonOffsetFill $= Disabled + + lighting $= Disabled + light (Light 0) $= Disabled + color (Color3 1 1 (1 :: GLfloat)) + polygonMode $= (Line, Line) + callList sphereList + polygonMode $= (Fill, Fill) + + flush + +-- specify initial properties +-- create display list with sphere +-- initialize lighting and depth buffer +gfxinit :: IO DisplayList +gfxinit = do + clearColor $= Color4 0 0 0 1 + + sphereList <- defineNewList Compile $ + renderObject Solid (Sphere' 1 20 12) + + depthFunc $= Just Less + + ambient (Light 0) $= Color4 0 0 0 1 + diffuse (Light 0) $= Color4 1 1 1 1 + specular (Light 0) $= Color4 1 1 1 1 + position (Light 0) $= Vertex4 1 1 1 0 + lightModelAmbient $= Color4 0.2 0.2 0.2 1 + + return sphereList + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 45 (fromIntegral w / fromIntegral h) 1 10 + matrixMode $= Modelview 0 + loadIdentity + lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) + +incSpin :: IORef GLfloat -> IO () +incSpin spinRef = do + let wrap n s = if s > n then s - n else s + spinRef $~ (wrap 360 . (+ 5)) + postRedisplay Nothing + +incDist :: State -> GLfloat -> IO () +incDist state inc = do + newDist <- fmap (+ inc) $ get (tDist state) + when (-5 <= newDist && newDist <= 4) $ do + tDist state $= newDist + postRedisplay Nothing + +incPoly :: String -> IORef GLfloat -> GLfloat -> IO () +incPoly name polyRef inc = do + polyRef $~ (+ inc) + p <- get polyRef + putStrLn (name ++ " is " ++ show p) + postRedisplay Nothing + +keyboardMouse :: State -> KeyboardMouseCallback +keyboardMouse state k Down _ _ = case k of + (MouseButton LeftButton) -> incSpin (spinX state) + (MouseButton MiddleButton) -> incSpin (spinY state) + (MouseButton RightButton) -> exitWith ExitSuccess + (Char 't') -> incDist state 0.5 + (Char 'T') -> incDist state (-0.5) + (Char 'F') -> incPoly "polyFactor" (polyFactor state) 0.1 + (Char 'f') -> incPoly "polyFactor" (polyFactor state) (-0.1) + (Char 'U') -> incPoly "polyUnits" (polyUnits state) 1 + (Char 'u') -> incPoly "polyUnits" (polyUnits state) (-1) + _ -> return () +keyboardMouse _ _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + _ <- createWindow progName + + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + version <- get (majorMinor glVersion) + when (version == (1,0)) $ do + putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." + putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," + putStrLn "you may be able to modify this program to make it run." + exitFailure + + state <- makeState + sphereList <- gfxinit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboardMouse state) + displayCallback $= display state sphereList + mainLoop diff --git a/examples/RedBook4/Polys.hs b/examples/RedBook4/Polys.hs --- a/examples/RedBook4/Polys.hs +++ b/examples/RedBook4/Polys.hs @@ -1,84 +1,84 @@ -{- - Polys.hs (adapted from polys.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates polygon stippling. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -fly :: IO GLpolygonstipple -fly = newPolygonStipple [ - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x03, 0x80, 0x01, 0xC0, 0x06, 0xC0, 0x03, 0x60, - 0x04, 0x60, 0x06, 0x20, 0x04, 0x30, 0x0C, 0x20, - 0x04, 0x18, 0x18, 0x20, 0x04, 0x0C, 0x30, 0x20, - 0x04, 0x06, 0x60, 0x20, 0x44, 0x03, 0xC0, 0x22, - 0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22, - 0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22, - 0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22, - 0x66, 0x01, 0x80, 0x66, 0x33, 0x01, 0x80, 0xCC, - 0x19, 0x81, 0x81, 0x98, 0x0C, 0xC1, 0x83, 0x30, - 0x07, 0xe1, 0x87, 0xe0, 0x03, 0x3f, 0xfc, 0xc0, - 0x03, 0x31, 0x8c, 0xc0, 0x03, 0x33, 0xcc, 0xc0, - 0x06, 0x64, 0x26, 0x60, 0x0c, 0xcc, 0x33, 0x30, - 0x18, 0xcc, 0x33, 0x18, 0x10, 0xc4, 0x23, 0x08, - 0x10, 0x63, 0xC6, 0x08, 0x10, 0x30, 0x0c, 0x08, - 0x10, 0x18, 0x18, 0x08, 0x10, 0x00, 0x00, 0x08] - -halftone :: IO GLpolygonstipple -halftone = newPolygonStipple . take 128 . cycle $ [ - 0xAA, 0xAA, 0xAA, 0xAA, 0x55, 0x55, 0x55, 0x55] - -display :: (GLpolygonstipple, GLpolygonstipple) -> DisplayCallback -display (flyStipple, halftoneStipple) = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - rectf = rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO () - color3f (Color3 1 1 1) - - -- draw one solid, unstippled rectangle, - -- then two stippled rectangles - rectf (Vertex2 25 25) (Vertex2 125 125) - polygonStipple $= Just flyStipple - rectf (Vertex2 125 25) (Vertex2 225 125) - polygonStipple $= Just halftoneStipple - rectf (Vertex2 225 25) (Vertex2 325 125) - polygonStipple $= (Nothing :: Maybe GLpolygonstipple) - - flush - -myInit :: IO (GLpolygonstipple, GLpolygonstipple) -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - flyStipple <- fly - halftoneStipple <- halftone - return (flyStipple, halftoneStipple) - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0.0 (fromIntegral w) 0.0 (fromIntegral h) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 350 150 - _ <- createWindow progName - stipples <- myInit - displayCallback $= display stipples - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Polys.hs (adapted from polys.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates polygon stippling. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +fly :: IO GLpolygonstipple +fly = newPolygonStipple [ + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x03, 0x80, 0x01, 0xC0, 0x06, 0xC0, 0x03, 0x60, + 0x04, 0x60, 0x06, 0x20, 0x04, 0x30, 0x0C, 0x20, + 0x04, 0x18, 0x18, 0x20, 0x04, 0x0C, 0x30, 0x20, + 0x04, 0x06, 0x60, 0x20, 0x44, 0x03, 0xC0, 0x22, + 0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22, + 0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22, + 0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22, + 0x66, 0x01, 0x80, 0x66, 0x33, 0x01, 0x80, 0xCC, + 0x19, 0x81, 0x81, 0x98, 0x0C, 0xC1, 0x83, 0x30, + 0x07, 0xe1, 0x87, 0xe0, 0x03, 0x3f, 0xfc, 0xc0, + 0x03, 0x31, 0x8c, 0xc0, 0x03, 0x33, 0xcc, 0xc0, + 0x06, 0x64, 0x26, 0x60, 0x0c, 0xcc, 0x33, 0x30, + 0x18, 0xcc, 0x33, 0x18, 0x10, 0xc4, 0x23, 0x08, + 0x10, 0x63, 0xC6, 0x08, 0x10, 0x30, 0x0c, 0x08, + 0x10, 0x18, 0x18, 0x08, 0x10, 0x00, 0x00, 0x08] + +halftone :: IO GLpolygonstipple +halftone = newPolygonStipple . take 128 . cycle $ [ + 0xAA, 0xAA, 0xAA, 0xAA, 0x55, 0x55, 0x55, 0x55] + +display :: (GLpolygonstipple, GLpolygonstipple) -> DisplayCallback +display (flyStipple, halftoneStipple) = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + rectf = rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO () + color3f (Color3 1 1 1) + + -- draw one solid, unstippled rectangle, + -- then two stippled rectangles + rectf (Vertex2 25 25) (Vertex2 125 125) + polygonStipple $= Just flyStipple + rectf (Vertex2 125 25) (Vertex2 225 125) + polygonStipple $= Just halftoneStipple + rectf (Vertex2 225 25) (Vertex2 325 125) + polygonStipple $= (Nothing :: Maybe GLpolygonstipple) + + flush + +myInit :: IO (GLpolygonstipple, GLpolygonstipple) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + flyStipple <- fly + halftoneStipple <- halftone + return (flyStipple, halftoneStipple) + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0.0 (fromIntegral w) 0.0 (fromIntegral h) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 350 150 + _ <- createWindow progName + stipples <- myInit + displayCallback $= display stipples + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Quadric.hs b/examples/RedBook4/Quadric.hs --- a/examples/RedBook4/Quadric.hs +++ b/examples/RedBook4/Quadric.hs @@ -1,106 +1,106 @@ -{- - Quadric.hs (adapted from quadric.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates the use of the renderQuadric routine. Quadric - objects are created with some quadric properties and errors are reported. - Note that the cylinder has no top or bottom and the circle has a hole in it. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO (DisplayList, DisplayList, DisplayList, DisplayList) -myInit = do - clearColor $= Color4 0 0 0 0 - - materialAmbient Front $= Color4 0.5 0.5 0.5 1 - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 50 - position (Light 0) $= Vertex4 1 1 1 0 - lightModelAmbient $= Color4 0.5 0.5 0.5 1 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - - -- Create 4 display lists, each with a different quadric object. - -- Different drawing styles and surface normal specifications - -- are demonstrated. - -- smooth shaded - dl1 <- newQuadricDL (Just Smooth) FillStyle (Sphere 0.75 15 10) - -- flat shaded - dl2 <- newQuadricDL (Just Flat) FillStyle (Cylinder 0.5 0.3 1 15 5) - -- all polygons wireframe - dl3 <- newQuadricDL Nothing LineStyle (Disk 0.25 1 20 4) - -- boundary only - dl4 <- newQuadricDL Nothing SilhouetteStyle (PartialDisk 0 1 20 4 0 225) - return (dl1, dl2, dl3, dl4) - -newQuadricDL :: QuadricNormal -> QuadricDrawStyle -> QuadricPrimitive -> IO DisplayList -newQuadricDL n s p = - defineNewList Compile $ do - renderQuadric (QuadricStyle n NoTextureCoordinates Outside s) p - reportErrors - -display :: (DisplayList, DisplayList, DisplayList, DisplayList) -> DisplayCallback -display (dl1, dl2, dl3, dl4) = do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - -- resolve overloading, not needed in "real" programs - let translatef = translate :: Vector3 GLfloat -> IO () - rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () - color3f = color :: Color3 GLfloat -> IO () - - lighting $= Enabled - shadeModel $= Smooth - translatef (Vector3 (-1) (-1) 0) - callList dl1 - - shadeModel $= Flat - translatef (Vector3 0 2 0) - preservingMatrix $ do - rotatef 300 (Vector3 1 0 0) - callList dl2 - - lighting $= Disabled - color3f (Color3 0 1 1) - translatef (Vector3 2 (-2) 0) - callList dl3 - - color3f (Color3 1 1 0) - translatef (Vector3 0 2 0) - callList dl4 - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10) 10 - else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10) 10 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - displayLists <- myInit - displayCallback $= display displayLists - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Quadric.hs (adapted from quadric.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the use of the renderQuadric routine. Quadric + objects are created with some quadric properties and errors are reported. + Note that the cylinder has no top or bottom and the circle has a hole in it. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO (DisplayList, DisplayList, DisplayList, DisplayList) +myInit = do + clearColor $= Color4 0 0 0 0 + + materialAmbient Front $= Color4 0.5 0.5 0.5 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 50 + position (Light 0) $= Vertex4 1 1 1 0 + lightModelAmbient $= Color4 0.5 0.5 0.5 1 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + + -- Create 4 display lists, each with a different quadric object. + -- Different drawing styles and surface normal specifications + -- are demonstrated. + -- smooth shaded + dl1 <- newQuadricDL (Just Smooth) FillStyle (Sphere 0.75 15 10) + -- flat shaded + dl2 <- newQuadricDL (Just Flat) FillStyle (Cylinder 0.5 0.3 1 15 5) + -- all polygons wireframe + dl3 <- newQuadricDL Nothing LineStyle (Disk 0.25 1 20 4) + -- boundary only + dl4 <- newQuadricDL Nothing SilhouetteStyle (PartialDisk 0 1 20 4 0 225) + return (dl1, dl2, dl3, dl4) + +newQuadricDL :: QuadricNormal -> QuadricDrawStyle -> QuadricPrimitive -> IO DisplayList +newQuadricDL n s p = + defineNewList Compile $ do + renderQuadric (QuadricStyle n NoTextureCoordinates Outside s) p + reportErrors + +display :: (DisplayList, DisplayList, DisplayList, DisplayList) -> DisplayCallback +display (dl1, dl2, dl3, dl4) = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + color3f = color :: Color3 GLfloat -> IO () + + lighting $= Enabled + shadeModel $= Smooth + translatef (Vector3 (-1) (-1) 0) + callList dl1 + + shadeModel $= Flat + translatef (Vector3 0 2 0) + preservingMatrix $ do + rotatef 300 (Vector3 1 0 0) + callList dl2 + + lighting $= Disabled + color3f (Color3 0 1 1) + translatef (Vector3 2 (-2) 0) + callList dl3 + + color3f (Color3 1 1 0) + translatef (Vector3 0 2 0) + callList dl4 + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10) 10 + else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10) 10 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + displayLists <- myInit + displayCallback $= display displayLists + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/ReadImage.hs b/examples/RedBook4/ReadImage.hs --- a/examples/RedBook4/ReadImage.hs +++ b/examples/RedBook4/ReadImage.hs @@ -1,65 +1,65 @@ -{- - ReadImage.hs (adapted from readImage.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Support for reading a file of raw RGB data: - 4 bytes big-endian width - 4 bytes big-endian height - width * height RGB byte triples --} - -module ReadImage ( readImage ) where - -import Data.Word ( Word8, Word32 ) -import Control.Exception ( bracket ) -import Control.Monad ( when ) -import System.IO ( Handle, IOMode(ReadMode), openBinaryFile, hGetBuf, hClose ) -import System.IO.Error ( mkIOError, eofErrorType ) -import Foreign ( Ptr, alloca, mallocBytes, Storable(..) ) -import Graphics.UI.GLUT - --- This is probably overkill, but anyway... -newtype Word32BigEndian = Word32BigEndian Word32 - -word32BigEndianToGLsizei :: Word32BigEndian -> GLsizei -word32BigEndianToGLsizei (Word32BigEndian x) = fromIntegral x - -instance Storable Word32BigEndian where - sizeOf ~(Word32BigEndian x) = sizeOf x - alignment ~(Word32BigEndian x) = alignment x - peek ptr = do - let numBytes = sizeOf (undefined :: Word32BigEndian) - bytes <- mapM (peekByteOff ptr) [ 0 .. numBytes - 1 ] :: IO [Word8] - let value = foldl (\val byte -> val * 256 + fromIntegral byte) 0 bytes - return $ Word32BigEndian value - poke = error "" - --- This is the reason for all this stuff above... -readGLsizei :: Handle -> IO GLsizei -readGLsizei handle = - alloca $ \buf -> do - hGetBufFully handle buf (sizeOf (undefined :: Word32BigEndian)) - fmap word32BigEndianToGLsizei $ peek buf - --- A handy variant of hGetBuf with additional error checking -hGetBufFully :: Handle -> Ptr a -> Int -> IO () -hGetBufFully handle ptr numBytes = do - bytesRead <- hGetBuf handle ptr numBytes - when (bytesRead /= numBytes) $ - ioError $ mkIOError eofErrorType "hGetBufFully" (Just handle) Nothing - --- Closing a file is nice, even when an error occurs during reading. -withBinaryFile :: FilePath -> (Handle -> IO a) -> IO a -withBinaryFile filePath = bracket (openBinaryFile filePath ReadMode) hClose - -readImage :: FilePath -> IO (Size, PixelData a) -readImage filePath = - withBinaryFile filePath $ \handle -> do - width <- readGLsizei handle - height <- readGLsizei handle - let numBytes = fromIntegral (3 * width * height) - buf <- mallocBytes numBytes - hGetBufFully handle buf numBytes - return (Size width height, PixelData RGB UnsignedByte buf) +{- + ReadImage.hs (adapted from readImage.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Support for reading a file of raw RGB data: + 4 bytes big-endian width + 4 bytes big-endian height + width * height RGB byte triples +-} + +module ReadImage ( readImage ) where + +import Data.Word ( Word8, Word32 ) +import Control.Exception ( bracket ) +import Control.Monad ( when ) +import System.IO ( Handle, IOMode(ReadMode), openBinaryFile, hGetBuf, hClose ) +import System.IO.Error ( mkIOError, eofErrorType ) +import Foreign ( Ptr, alloca, mallocBytes, Storable(..) ) +import Graphics.UI.GLUT + +-- This is probably overkill, but anyway... +newtype Word32BigEndian = Word32BigEndian Word32 + +word32BigEndianToGLsizei :: Word32BigEndian -> GLsizei +word32BigEndianToGLsizei (Word32BigEndian x) = fromIntegral x + +instance Storable Word32BigEndian where + sizeOf ~(Word32BigEndian x) = sizeOf x + alignment ~(Word32BigEndian x) = alignment x + peek ptr = do + let numBytes = sizeOf (undefined :: Word32BigEndian) + bytes <- mapM (peekByteOff ptr) [ 0 .. numBytes - 1 ] :: IO [Word8] + let value = foldl (\val byte -> val * 256 + fromIntegral byte) 0 bytes + return $ Word32BigEndian value + poke = error "" + +-- This is the reason for all this stuff above... +readGLsizei :: Handle -> IO GLsizei +readGLsizei handle = + alloca $ \buf -> do + hGetBufFully handle buf (sizeOf (undefined :: Word32BigEndian)) + fmap word32BigEndianToGLsizei $ peek buf + +-- A handy variant of hGetBuf with additional error checking +hGetBufFully :: Handle -> Ptr a -> Int -> IO () +hGetBufFully handle ptr numBytes = do + bytesRead <- hGetBuf handle ptr numBytes + when (bytesRead /= numBytes) $ + ioError $ mkIOError eofErrorType "hGetBufFully" (Just handle) Nothing + +-- Closing a file is nice, even when an error occurs during reading. +withBinaryFile :: FilePath -> (Handle -> IO a) -> IO a +withBinaryFile filePath = bracket (openBinaryFile filePath ReadMode) hClose + +readImage :: FilePath -> IO (Size, PixelData a) +readImage filePath = + withBinaryFile filePath $ \handle -> do + width <- readGLsizei handle + height <- readGLsizei handle + let numBytes = fromIntegral (3 * width * height) + buf <- mallocBytes numBytes + hGetBufFully handle buf numBytes + return (Size width height, PixelData RGB UnsignedByte buf) diff --git a/examples/RedBook4/Robot.hs b/examples/RedBook4/Robot.hs --- a/examples/RedBook4/Robot.hs +++ b/examples/RedBook4/Robot.hs @@ -1,89 +1,89 @@ -{- - Robot.hs (adapted from robot.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program shows how to composite modeling transformations to draw - translated and rotated hierarchical models. Interaction: pressing the s - and e keys (shoulder and elbow) alters the rotation of the robot arm. --} - -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { shoulder, elbow :: IORef GLint } - -makeState :: IO State -makeState = do - s <- newIORef 0 - e <- newIORef 0 - return $ State { shoulder = s, elbow = e } - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let translatef = translate :: Vector3 GLfloat -> IO () - scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () - preservingMatrix $ do - translatef (Vector3 (-1) 0 0) - s <- get (shoulder state) - rotate (fromIntegral s :: GLfloat) (Vector3 0 0 1) - translatef (Vector3 1 0 0) - preservingMatrix $ do - scalef 2 0.4 1 - renderObject Wireframe (Cube 1) - translatef (Vector3 1 0 0) - e <- get (elbow state) - rotate (fromIntegral e :: GLfloat) (Vector3 0 0 1) - translatef (Vector3 1 0 0) - preservingMatrix $ do - scalef 2 0.4 1 - renderObject Wireframe (Cube 1) - swapBuffers - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 65 (fromIntegral w / fromIntegral h) 1 20 - matrixMode $= Modelview 0 - loadIdentity - -- resolve overloading, not needed in "real" programs - let translatef = translate :: Vector3 GLfloat -> IO () - translatef (Vector3 0 0 (-5)) - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case c of - 's' -> update shoulder 5 - 'S' -> update shoulder (-5) - 'e' -> update elbow 5 - 'E' -> update elbow (-5) - '\27' -> exitWith ExitSuccess - _ -> return () - where update joint inc = do - joint state $~ ((`mod` 360) . (+ inc)) - postRedisplay Nothing -keyboard _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ DoubleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - state <- makeState - myInit - displayCallback $= display state - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - mainLoop +{- + Robot.hs (adapted from robot.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program shows how to composite modeling transformations to draw + translated and rotated hierarchical models. Interaction: pressing the s + and e keys (shoulder and elbow) alters the rotation of the robot arm. +-} + +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { shoulder, elbow :: IORef GLint } + +makeState :: IO State +makeState = do + s <- newIORef 0 + e <- newIORef 0 + return $ State { shoulder = s, elbow = e } + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () + preservingMatrix $ do + translatef (Vector3 (-1) 0 0) + s <- get (shoulder state) + rotate (fromIntegral s :: GLfloat) (Vector3 0 0 1) + translatef (Vector3 1 0 0) + preservingMatrix $ do + scalef 2 0.4 1 + renderObject Wireframe (Cube 1) + translatef (Vector3 1 0 0) + e <- get (elbow state) + rotate (fromIntegral e :: GLfloat) (Vector3 0 0 1) + translatef (Vector3 1 0 0) + preservingMatrix $ do + scalef 2 0.4 1 + renderObject Wireframe (Cube 1) + swapBuffers + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 65 (fromIntegral w / fromIntegral h) 1 20 + matrixMode $= Modelview 0 + loadIdentity + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + translatef (Vector3 0 0 (-5)) + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case c of + 's' -> update shoulder 5 + 'S' -> update shoulder (-5) + 'e' -> update elbow 5 + 'E' -> update elbow (-5) + '\27' -> exitWith ExitSuccess + _ -> return () + where update joint inc = do + joint state $~ ((`mod` 360) . (+ inc)) + postRedisplay Nothing +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + mainLoop diff --git a/examples/RedBook4/Scene.hs b/examples/RedBook4/Scene.hs --- a/examples/RedBook4/Scene.hs +++ b/examples/RedBook4/Scene.hs @@ -1,73 +1,73 @@ -{- - Scene.hs (adapted from scene.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates the use of the GL lighting model. Objects are - drawn using a grey material characteristic. A single light source - illuminates the objects. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Initialize material property and light source. -myInit :: IO () -myInit = do - ambient (Light 0) $= Color4 0 0 0 1 - diffuse (Light 0) $= Color4 1 1 1 1 - specular (Light 0) $= Color4 1 1 1 1 - -- light position is NOT default value - position (Light 0) $= Vertex4 1 1 1 0 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - rotate (20 :: GLfloat) (Vector3 1 0 0) - preservingMatrix $ do - translate (Vector3 (-0.75) 0.5 (0 :: GLfloat)) - rotate (90 :: GLfloat) (Vector3 1 0 0) - renderObject Solid (Torus 0.275 0.85 15 15) - preservingMatrix $ do - translate (Vector3 (-0.75) (-0.5) (0 :: GLfloat)) - rotate (270 :: GLfloat) (Vector3 1 0 0) - renderObject Solid (Cone 1 2 15 15) - preservingMatrix $ do - translate (Vector3 0.75 0 (-1 :: GLfloat)) - renderObject Solid (Sphere' 1 15 15) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-2.5) 2.5 (-2.5 * hf/wf) (2.5 * hf/wf) (-10) 10 - else ortho (-2.5 * wf/hf) (2.5 * wf/hf) (-2.5) 2.5 (-10) 10 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - _ <- createWindow progName - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Scene.hs (adapted from scene.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the use of the GL lighting model. Objects are + drawn using a grey material characteristic. A single light source + illuminates the objects. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Initialize material property and light source. +myInit :: IO () +myInit = do + ambient (Light 0) $= Color4 0 0 0 1 + diffuse (Light 0) $= Color4 1 1 1 1 + specular (Light 0) $= Color4 1 1 1 1 + -- light position is NOT default value + position (Light 0) $= Vertex4 1 1 1 0 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + rotate (20 :: GLfloat) (Vector3 1 0 0) + preservingMatrix $ do + translate (Vector3 (-0.75) 0.5 (0 :: GLfloat)) + rotate (90 :: GLfloat) (Vector3 1 0 0) + renderObject Solid (Torus 0.275 0.85 15 15) + preservingMatrix $ do + translate (Vector3 (-0.75) (-0.5) (0 :: GLfloat)) + rotate (270 :: GLfloat) (Vector3 1 0 0) + renderObject Solid (Cone 1 2 15 15) + preservingMatrix $ do + translate (Vector3 0.75 0 (-1 :: GLfloat)) + renderObject Solid (Sphere' 1 15 15) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-2.5) 2.5 (-2.5 * hf/wf) (2.5 * hf/wf) (-10) 10 + else ortho (-2.5 * wf/hf) (2.5 * wf/hf) (-2.5) 2.5 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Select.hs b/examples/RedBook4/Select.hs --- a/examples/RedBook4/Select.hs +++ b/examples/RedBook4/Select.hs @@ -1,150 +1,150 @@ -{- - Select.hs (adapted from select.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This is an illustration of the selection mode and name stack, which detects - whether objects which collide with a viewing volume. First, four triangles - and a rectangular box representing a viewing volume are drawn (drawScene - routine). The green triangle and yellow triangles appear to lie within the - viewing volume, but the red triangle appears to lie outside it. Then the - selection mode is entered (selectObjects routine). Drawing to the screen - ceases. To see if any collisions occur, the four triangles are called. In - this example, the green triangle causes one hit with the name 1, and the - yellow triangles cause one hit with the name 3. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- draw a triangle with vertices at (x1, y1), (x2, y2) and (x3, y3) at z units --- away from the origin. -drawTriangle :: - Vertex2 GLfloat -> Vertex2 GLfloat -> Vertex2 GLfloat -> GLfloat -> IO () -drawTriangle (Vertex2 x1 y1) (Vertex2 x2 y2) (Vertex2 x3 y3) z = do - renderPrimitive Triangles $ mapM_ vertex [ - Vertex3 x1 y1 z, - Vertex3 x2 y2 z, - Vertex3 x3 y3 z] - --- draw a rectangular box with these outer x, y, and z values -drawViewVolume :: Vertex3 GLfloat -> Vertex3 GLfloat -> IO () -drawViewVolume (Vertex3 x1 y1 z1) (Vertex3 x2 y2 z2) = do - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - color3f (Color3 1 1 1) - renderPrimitive LineLoop $ mapM_ vertex [ - Vertex3 x1 y1 (-z1), - Vertex3 x2 y1 (-z1), - Vertex3 x2 y2 (-z1), - Vertex3 x1 y2 (-z1)] - - renderPrimitive LineLoop $ mapM_ vertex [ - Vertex3 x1 y1 (-z2), - Vertex3 x2 y1 (-z2), - Vertex3 x2 y2 (-z2), - Vertex3 x1 y2 (-z2)] - - renderPrimitive Lines $ mapM_ vertex [ -- 4 lines - Vertex3 x1 y1 (-z1), - Vertex3 x1 y1 (-z2), - Vertex3 x1 y2 (-z1), - Vertex3 x1 y2 (-z2), - Vertex3 x2 y1 (-z1), - Vertex3 x2 y1 (-z2), - Vertex3 x2 y2 (-z1), - Vertex3 x2 y2 (-z2)] - --- drawScene draws 4 triangles and a wire frame which represents the viewing --- volume. -drawScene :: IO () -drawScene = do - matrixMode $= Projection - loadIdentity - perspective 40 (4/3) 1 100 - - matrixMode $= Modelview 0 - loadIdentity - lookAt (Vertex3 7.5 7.5 12.5) (Vertex3 2.5 2.5 (-5)) (Vector3 0 1 0) - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - color3f (Color3 0 1 0) -- green triangle - drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-5) - color3f (Color3 1 0 0) -- red triangle - drawTriangle (Vertex2 2 7) (Vertex2 3 7) (Vertex2 2.5 8) (-5) - color3f (Color3 1 1 0) -- yellow triangles - drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-1) - drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-9) - drawViewVolume (Vertex3 0 0 0) (Vertex3 5 5 10) - -processHits :: Maybe [HitRecord] -> IO () -processHits Nothing = putStrLn "selection buffer overflow" -processHits (Just hitRecords) = do - putStrLn ("hits = " ++ show (length hitRecords)) - mapM_ (\(HitRecord z1 z2 names) -> do - putStrLn (" number of names for hit = " ++ show (length names)) - putStr (" z1 is " ++ show z1) - putStrLn ("; z2 is " ++ show z2) - putStr " the name is" - sequence_ [ putStr (" " ++ show n) | Name n <- names ] - putChar '\n') - hitRecords - --- selectObjects "draws" the triangles in selection mode, assigning names for --- the triangles. Note that the third and fourth triangles share one name, so --- that if either or both triangles intersects the viewing/clipping volume, --- only one hit will be registered. - -bufSize :: GLsizei -bufSize = 512 - -selectObjects :: IO () -selectObjects = do - (_, maybeHitRecords) <- getHitRecords bufSize $ do - withName (Name 0) $ do - preservingMatrix $ do - matrixMode $= Projection - loadIdentity - ortho 0 5 0 5 0 10 - matrixMode $= Modelview 0 - loadIdentity - loadName (Name 1) - drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-5) - loadName (Name 2) - drawTriangle (Vertex2 2 7) (Vertex2 3 7) (Vertex2 2.5 8) (-5) - loadName (Name 3) - drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-1) - drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-9) - flush - processHits maybeHitRecords - -myInit :: IO () -myInit = do - depthFunc $= Just Less - shadeModel $= Flat - -display :: DisplayCallback -display = do - clearColor $= Color4 0 0 0 0 - clear [ ColorBuffer, DepthBuffer ] - drawScene - selectObjects - flush - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 200 200 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Select.hs (adapted from select.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This is an illustration of the selection mode and name stack, which detects + whether objects which collide with a viewing volume. First, four triangles + and a rectangular box representing a viewing volume are drawn (drawScene + routine). The green triangle and yellow triangles appear to lie within the + viewing volume, but the red triangle appears to lie outside it. Then the + selection mode is entered (selectObjects routine). Drawing to the screen + ceases. To see if any collisions occur, the four triangles are called. In + this example, the green triangle causes one hit with the name 1, and the + yellow triangles cause one hit with the name 3. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- draw a triangle with vertices at (x1, y1), (x2, y2) and (x3, y3) at z units +-- away from the origin. +drawTriangle :: + Vertex2 GLfloat -> Vertex2 GLfloat -> Vertex2 GLfloat -> GLfloat -> IO () +drawTriangle (Vertex2 x1 y1) (Vertex2 x2 y2) (Vertex2 x3 y3) z = do + renderPrimitive Triangles $ mapM_ vertex [ + Vertex3 x1 y1 z, + Vertex3 x2 y2 z, + Vertex3 x3 y3 z] + +-- draw a rectangular box with these outer x, y, and z values +drawViewVolume :: Vertex3 GLfloat -> Vertex3 GLfloat -> IO () +drawViewVolume (Vertex3 x1 y1 z1) (Vertex3 x2 y2 z2) = do + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 1 1 1) + renderPrimitive LineLoop $ mapM_ vertex [ + Vertex3 x1 y1 (-z1), + Vertex3 x2 y1 (-z1), + Vertex3 x2 y2 (-z1), + Vertex3 x1 y2 (-z1)] + + renderPrimitive LineLoop $ mapM_ vertex [ + Vertex3 x1 y1 (-z2), + Vertex3 x2 y1 (-z2), + Vertex3 x2 y2 (-z2), + Vertex3 x1 y2 (-z2)] + + renderPrimitive Lines $ mapM_ vertex [ -- 4 lines + Vertex3 x1 y1 (-z1), + Vertex3 x1 y1 (-z2), + Vertex3 x1 y2 (-z1), + Vertex3 x1 y2 (-z2), + Vertex3 x2 y1 (-z1), + Vertex3 x2 y1 (-z2), + Vertex3 x2 y2 (-z1), + Vertex3 x2 y2 (-z2)] + +-- drawScene draws 4 triangles and a wire frame which represents the viewing +-- volume. +drawScene :: IO () +drawScene = do + matrixMode $= Projection + loadIdentity + perspective 40 (4/3) 1 100 + + matrixMode $= Modelview 0 + loadIdentity + lookAt (Vertex3 7.5 7.5 12.5) (Vertex3 2.5 2.5 (-5)) (Vector3 0 1 0) + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 0 1 0) -- green triangle + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-5) + color3f (Color3 1 0 0) -- red triangle + drawTriangle (Vertex2 2 7) (Vertex2 3 7) (Vertex2 2.5 8) (-5) + color3f (Color3 1 1 0) -- yellow triangles + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-1) + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-9) + drawViewVolume (Vertex3 0 0 0) (Vertex3 5 5 10) + +processHits :: Maybe [HitRecord] -> IO () +processHits Nothing = putStrLn "selection buffer overflow" +processHits (Just hitRecords) = do + putStrLn ("hits = " ++ show (length hitRecords)) + mapM_ (\(HitRecord z1 z2 names) -> do + putStrLn (" number of names for hit = " ++ show (length names)) + putStr (" z1 is " ++ show z1) + putStrLn ("; z2 is " ++ show z2) + putStr " the name is" + sequence_ [ putStr (" " ++ show n) | Name n <- names ] + putChar '\n') + hitRecords + +-- selectObjects "draws" the triangles in selection mode, assigning names for +-- the triangles. Note that the third and fourth triangles share one name, so +-- that if either or both triangles intersects the viewing/clipping volume, +-- only one hit will be registered. + +bufSize :: GLsizei +bufSize = 512 + +selectObjects :: IO () +selectObjects = do + (_, maybeHitRecords) <- getHitRecords bufSize $ do + withName (Name 0) $ do + preservingMatrix $ do + matrixMode $= Projection + loadIdentity + ortho 0 5 0 5 0 10 + matrixMode $= Modelview 0 + loadIdentity + loadName (Name 1) + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-5) + loadName (Name 2) + drawTriangle (Vertex2 2 7) (Vertex2 3 7) (Vertex2 2.5 8) (-5) + loadName (Name 3) + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-1) + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-9) + flush + processHits maybeHitRecords + +myInit :: IO () +myInit = do + depthFunc $= Just Less + shadeModel $= Flat + +display :: DisplayCallback +display = do + clearColor $= Color4 0 0 0 0 + clear [ ColorBuffer, DepthBuffer ] + drawScene + selectObjects + flush + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 200 200 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/ShadowMap.hs b/examples/RedBook4/ShadowMap.hs --- a/examples/RedBook4/ShadowMap.hs +++ b/examples/RedBook4/ShadowMap.hs @@ -1,255 +1,255 @@ -{- - ShadowMap.hs (adapted from shadowmap.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE --} - -import Control.Monad ( when, unless ) -import Data.IORef ( IORef, newIORef ) -import Foreign.Marshal.Array ( allocaArray ) -import Foreign.Ptr ( nullPtr ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -shadowMapSize :: TextureSize2D -shadowMapSize = TextureSize2D 256 256 - -fovy, nearPlane, farPlane :: GLdouble -fovy = 60 -nearPlane = 10 -farPlane = 100 - -lightPos :: Vertex4 GLfloat -lightPos = Vertex4 25 25 25 1 - -lookat :: Vertex3 GLdouble -lookat = Vertex3 0 0 0 - -up :: Vector3 GLdouble -up = Vector3 0 0 1 - -data State = State { - angle :: IORef GLdouble, - torusAngle :: IORef GLfloat, - showShadow :: IORef Bool, - animate :: IORef Bool, - funcMode :: IORef ComparisonFunction } - -makeState :: IO State -makeState = do - a <- newIORef 0 - t <- newIORef 0 - s <- newIORef False - n <- newIORef True - f <- newIORef Lequal - return $ State { angle = a, torusAngle = t, showShadow = s, - animate = n, funcMode = f } - -myInit :: IO () -myInit = do - texImage2D Texture2D NoProxy 0 DepthComponent' shadowMapSize 0 - (PixelData DepthComponent UnsignedByte nullPtr) - - position (Light 0) $= lightPos - let white = Color4 1 1 1 1 - specular (Light 0) $= white - diffuse (Light 0) $= white - - textureWrapMode Texture2D S $= (Repeated, ClampToEdge) - textureWrapMode Texture2D T $= (Repeated, ClampToEdge) - textureFilter Texture2D $= ((Linear', Nothing), Linear') - textureCompareMode Texture2D $= Just Lequal - depthTextureMode Texture2D $= Luminance' - - colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse) - - cullFace $= Just Back - - depthFunc $= Just Less - light (Light 0) $= Enabled - lighting $= Enabled - texture Texture2D $= Enabled - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective fovy (fromIntegral w / fromIntegral h) nearPlane farPlane - matrixMode $= Modelview 0 - -idle :: State -> IdleCallback -idle state = do - angle state $~! (+ (pi / 10000)) - torusAngle state $~! (+ 0.1) - postRedisplay Nothing - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = do - case c of - '\27' -> exitWith ExitSuccess - 't' -> - texture Texture2D $~ \cap -> if cap == Enabled then Disabled else Enabled - 'm' -> do - fm <- get (funcMode state) - textureCompareMode Texture2D $~ maybe (Just fm) (const Nothing) - compareMode <- get (textureCompareMode Texture2D) - putStrLn ("Compare mode " ++ maybe "Off" (const "On") compareMode) - 'f' -> do - funcMode state $~ \fm -> if fm == Lequal then Gequal else Lequal - fm <- get (funcMode state) - putStrLn ("Operator " ++ show fm) - textureCompareMode Texture2D $~ maybe Nothing (const (Just fm)) - 's' -> showShadow state $~ not - 'p' -> do - animate state $~ not - animate' <- get (animate state) - idleCallback $= if animate' then Just (idle state) else Nothing - _ -> return () - postRedisplay Nothing -keyboard _ _ _ _ _ = return () - -drawObjects :: GLfloat -> Bool -> IO () -drawObjects torusAngle' shadowRender = do - textureOn <- get (texture Texture2D) - - when shadowRender $ - texture Texture2D $= Disabled - - -- resolve overloading, not needed in "real" programs - let normal3f = normal :: Normal3 GLfloat -> IO () - color3f = color :: Color3 GLfloat -> IO () - rectf = rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO () - translatef = translate :: Vector3 GLfloat -> IO () - rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () - - unless shadowRender $ do - normal3f (Normal3 0 0 1) - color3f (Color3 1 1 1) - rectf (Vertex2 (-20) (-20)) (Vertex2 20 20) - - preservingMatrix $ do - translatef (Vector3 11 11 11) - rotatef 54.73 (Vector3 (-5) 5 0) - rotate torusAngle' (Vector3 1 0 0) - color3f (Color3 1 0 0) - renderObject Solid (Torus 1 4 8 36) - - preservingMatrix $ do - translatef (Vector3 2 2 2) - color3f (Color3 0 0 1) - renderObject Solid (Cube 4) - - preservingMatrix $ do - getLightPos Vector3 >>= translate - color3f (Color3 1 1 1) - renderObject Wireframe (Sphere' 0.5 6 6) - - when (shadowRender && textureOn == Enabled) $ - texture Texture2D $= Enabled - -getLightPos :: (GLdouble -> GLdouble -> GLdouble -> a) -> IO a -getLightPos f = do - Vertex4 x y z _ <- get (position (Light 0)) - return $ f (realToFrac x) (realToFrac y) (realToFrac z) - -generateShadowMap :: GLfloat -> Bool -> IO () -generateShadowMap torusAngle' showShadow' = do - lightPos' <- getLightPos Vertex3 - let (TextureSize2D shadowMapWidth shadowMapHeight) = shadowMapSize - shadowMapSize' = Size shadowMapWidth shadowMapHeight - - preservingViewport $ do - viewport $= (Position 0 0, shadowMapSize') - - clear [ ColorBuffer, DepthBuffer ] - - matrixMode $= Projection - preservingMatrix $ do - loadIdentity - perspective 80 1 10 1000 - matrixMode $= Modelview 0 - preservingMatrix $ do - loadIdentity - lookAt lightPos' lookat up - drawObjects torusAngle' True - matrixMode $= Projection - matrixMode $= Modelview 0 - - copyTexImage2D Texture2D 0 DepthComponent' (Position 0 0) shadowMapSize 0 - - when showShadow' $ do - let numShadowMapPixels = fromIntegral (shadowMapWidth * shadowMapHeight) - allocaArray numShadowMapPixels $ \depthImage -> do - let pixelData fmt = PixelData fmt Float depthImage :: PixelData GLfloat - readPixels (Position 0 0) shadowMapSize' (pixelData DepthComponent) - (_, Size viewPortWidth _) <- get viewport - windowPos (Vertex2 (fromIntegral viewPortWidth / 2 :: GLfloat) 0) - drawPixels shadowMapSize' (pixelData Luminance) - swapBuffers - --- Note: preservingViewport is not exception safe, but it doesn't matter here -preservingViewport :: IO a -> IO a -preservingViewport act = do - v <- get viewport - x <- act - viewport $= v - return x - -generateTextureMatrix :: IO () -generateTextureMatrix = do - -- Set up projective texture matrix. We use the Modelview matrix stack and - -- OpenGL matrix commands to make the matrix. - m <- preservingMatrix $ do - loadIdentity - -- resolve overloading, not needed in "real" programs - let translatef = translate :: Vector3 GLfloat -> IO () - scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () - translatef (Vector3 0.5 0.5 0.0) - scalef 0.5 0.5 1.0 - perspective 60 1 1 1000 - lightPos' <- getLightPos Vertex3 - lookAt lightPos' lookat up - get (matrix (Just (Modelview 0))) - - [ sx, sy, sz, sw, - tx, ty, tz, tw, - rx, ry, rz, rw, - qx, qy, qz, qw ] <- getMatrixComponents RowMajor (m :: GLmatrix GLdouble) - - textureGenMode S $= Just (ObjectLinear (Plane sx sy sz sw)) - textureGenMode T $= Just (ObjectLinear (Plane tx ty tz tw)) - textureGenMode R $= Just (ObjectLinear (Plane rx ry rz rw)) - textureGenMode Q $= Just (ObjectLinear (Plane qx qy qz qw)) - -display :: State -> DisplayCallback -display state = do - let radius = 30 - torusAngle' <- get (torusAngle state) - showShadow' <- get (showShadow state) - generateShadowMap torusAngle' showShadow' - generateTextureMatrix - unless showShadow' $ do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - angle' <- get (angle state) - lookAt (Vertex3 (radius * cos angle') (radius * sin angle') 30) lookat up - drawObjects torusAngle' False - swapBuffers - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ RGBAMode, WithDepthBuffer, DoubleBuffered ] - initialWindowSize $= Size 521 512 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - state <- makeState - myInit - displayCallback $= display state - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - idleCallback $= Just (idle state) - - mainLoop +{- + ShadowMap.hs (adapted from shadowmap.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( when, unless ) +import Data.IORef ( IORef, newIORef ) +import Foreign.Marshal.Array ( allocaArray ) +import Foreign.Ptr ( nullPtr ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +shadowMapSize :: TextureSize2D +shadowMapSize = TextureSize2D 256 256 + +fovy, nearPlane, farPlane :: GLdouble +fovy = 60 +nearPlane = 10 +farPlane = 100 + +lightPos :: Vertex4 GLfloat +lightPos = Vertex4 25 25 25 1 + +lookat :: Vertex3 GLdouble +lookat = Vertex3 0 0 0 + +up :: Vector3 GLdouble +up = Vector3 0 0 1 + +data State = State { + angle :: IORef GLdouble, + torusAngle :: IORef GLfloat, + showShadow :: IORef Bool, + animate :: IORef Bool, + funcMode :: IORef ComparisonFunction } + +makeState :: IO State +makeState = do + a <- newIORef 0 + t <- newIORef 0 + s <- newIORef False + n <- newIORef True + f <- newIORef Lequal + return $ State { angle = a, torusAngle = t, showShadow = s, + animate = n, funcMode = f } + +myInit :: IO () +myInit = do + texImage2D Texture2D NoProxy 0 DepthComponent' shadowMapSize 0 + (PixelData DepthComponent UnsignedByte nullPtr) + + position (Light 0) $= lightPos + let white = Color4 1 1 1 1 + specular (Light 0) $= white + diffuse (Light 0) $= white + + textureWrapMode Texture2D S $= (Repeated, ClampToEdge) + textureWrapMode Texture2D T $= (Repeated, ClampToEdge) + textureFilter Texture2D $= ((Linear', Nothing), Linear') + textureCompareMode Texture2D $= Just Lequal + depthTextureMode Texture2D $= Luminance' + + colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse) + + cullFace $= Just Back + + depthFunc $= Just Less + light (Light 0) $= Enabled + lighting $= Enabled + texture Texture2D $= Enabled + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective fovy (fromIntegral w / fromIntegral h) nearPlane farPlane + matrixMode $= Modelview 0 + +idle :: State -> IdleCallback +idle state = do + angle state $~! (+ (pi / 10000)) + torusAngle state $~! (+ 0.1) + postRedisplay Nothing + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = do + case c of + '\27' -> exitWith ExitSuccess + 't' -> + texture Texture2D $~ \cap -> if cap == Enabled then Disabled else Enabled + 'm' -> do + fm <- get (funcMode state) + textureCompareMode Texture2D $~ maybe (Just fm) (const Nothing) + compareMode <- get (textureCompareMode Texture2D) + putStrLn ("Compare mode " ++ maybe "Off" (const "On") compareMode) + 'f' -> do + funcMode state $~ \fm -> if fm == Lequal then Gequal else Lequal + fm <- get (funcMode state) + putStrLn ("Operator " ++ show fm) + textureCompareMode Texture2D $~ maybe Nothing (const (Just fm)) + 's' -> showShadow state $~ not + 'p' -> do + animate state $~ not + animate' <- get (animate state) + idleCallback $= if animate' then Just (idle state) else Nothing + _ -> return () + postRedisplay Nothing +keyboard _ _ _ _ _ = return () + +drawObjects :: GLfloat -> Bool -> IO () +drawObjects torusAngle' shadowRender = do + textureOn <- get (texture Texture2D) + + when shadowRender $ + texture Texture2D $= Disabled + + -- resolve overloading, not needed in "real" programs + let normal3f = normal :: Normal3 GLfloat -> IO () + color3f = color :: Color3 GLfloat -> IO () + rectf = rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + + unless shadowRender $ do + normal3f (Normal3 0 0 1) + color3f (Color3 1 1 1) + rectf (Vertex2 (-20) (-20)) (Vertex2 20 20) + + preservingMatrix $ do + translatef (Vector3 11 11 11) + rotatef 54.73 (Vector3 (-5) 5 0) + rotate torusAngle' (Vector3 1 0 0) + color3f (Color3 1 0 0) + renderObject Solid (Torus 1 4 8 36) + + preservingMatrix $ do + translatef (Vector3 2 2 2) + color3f (Color3 0 0 1) + renderObject Solid (Cube 4) + + preservingMatrix $ do + getLightPos Vector3 >>= translate + color3f (Color3 1 1 1) + renderObject Wireframe (Sphere' 0.5 6 6) + + when (shadowRender && textureOn == Enabled) $ + texture Texture2D $= Enabled + +getLightPos :: (GLdouble -> GLdouble -> GLdouble -> a) -> IO a +getLightPos f = do + Vertex4 x y z _ <- get (position (Light 0)) + return $ f (realToFrac x) (realToFrac y) (realToFrac z) + +generateShadowMap :: GLfloat -> Bool -> IO () +generateShadowMap torusAngle' showShadow' = do + lightPos' <- getLightPos Vertex3 + let (TextureSize2D shadowMapWidth shadowMapHeight) = shadowMapSize + shadowMapSize' = Size shadowMapWidth shadowMapHeight + + preservingViewport $ do + viewport $= (Position 0 0, shadowMapSize') + + clear [ ColorBuffer, DepthBuffer ] + + matrixMode $= Projection + preservingMatrix $ do + loadIdentity + perspective 80 1 10 1000 + matrixMode $= Modelview 0 + preservingMatrix $ do + loadIdentity + lookAt lightPos' lookat up + drawObjects torusAngle' True + matrixMode $= Projection + matrixMode $= Modelview 0 + + copyTexImage2D Texture2D 0 DepthComponent' (Position 0 0) shadowMapSize 0 + + when showShadow' $ do + let numShadowMapPixels = fromIntegral (shadowMapWidth * shadowMapHeight) + allocaArray numShadowMapPixels $ \depthImage -> do + let pixelData fmt = PixelData fmt Float depthImage :: PixelData GLfloat + readPixels (Position 0 0) shadowMapSize' (pixelData DepthComponent) + (_, Size viewPortWidth _) <- get viewport + windowPos (Vertex2 (fromIntegral viewPortWidth / 2 :: GLfloat) 0) + drawPixels shadowMapSize' (pixelData Luminance) + swapBuffers + +-- Note: preservingViewport is not exception safe, but it doesn't matter here +preservingViewport :: IO a -> IO a +preservingViewport act = do + v <- get viewport + x <- act + viewport $= v + return x + +generateTextureMatrix :: IO () +generateTextureMatrix = do + -- Set up projective texture matrix. We use the Modelview matrix stack and + -- OpenGL matrix commands to make the matrix. + m <- preservingMatrix $ do + loadIdentity + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () + translatef (Vector3 0.5 0.5 0.0) + scalef 0.5 0.5 1.0 + perspective 60 1 1 1000 + lightPos' <- getLightPos Vertex3 + lookAt lightPos' lookat up + get (matrix (Just (Modelview 0))) + + [ sx, sy, sz, sw, + tx, ty, tz, tw, + rx, ry, rz, rw, + qx, qy, qz, qw ] <- getMatrixComponents RowMajor (m :: GLmatrix GLdouble) + + textureGenMode S $= Just (ObjectLinear (Plane sx sy sz sw)) + textureGenMode T $= Just (ObjectLinear (Plane tx ty tz tw)) + textureGenMode R $= Just (ObjectLinear (Plane rx ry rz rw)) + textureGenMode Q $= Just (ObjectLinear (Plane qx qy qz qw)) + +display :: State -> DisplayCallback +display state = do + let radius = 30 + torusAngle' <- get (torusAngle state) + showShadow' <- get (showShadow state) + generateShadowMap torusAngle' showShadow' + generateTextureMatrix + unless showShadow' $ do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + angle' <- get (angle state) + lookAt (Vertex3 (radius * cos angle') (radius * sin angle') 30) lookat up + drawObjects torusAngle' False + swapBuffers + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ RGBAMode, WithDepthBuffer, DoubleBuffered ] + initialWindowSize $= Size 521 512 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + idleCallback $= Just (idle state) + + mainLoop diff --git a/examples/RedBook4/Smooth.hs b/examples/RedBook4/Smooth.hs --- a/examples/RedBook4/Smooth.hs +++ b/examples/RedBook4/Smooth.hs @@ -1,65 +1,65 @@ -{- - Smooth.hs (adapted from smooth.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates smooth shading. A smooth shaded polygon is drawn in - a 2-D projection. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Smooth - -triangle :: IO () -triangle = - -- resolve overloading, not needed in "real" programs - let vertex2f = vertex :: Vertex2 GLfloat -> IO () - color3f = color :: Color3 GLfloat -> IO () - in renderPrimitive Triangles $ do - color3f (Color3 1 0 0) - vertex2f (Vertex2 5 5) - color3f (Color3 0 1 0) - vertex2f (Vertex2 25 5) - color3f (Color3 0 0 1) - vertex2f (Vertex2 5 25) - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - triangle - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho2D 0 30 0 (30 * hf/wf) - else ortho2D 0 (30 * wf/hf) 0 30 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Smooth.hs (adapted from smooth.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates smooth shading. A smooth shaded polygon is drawn in + a 2-D projection. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + +triangle :: IO () +triangle = + -- resolve overloading, not needed in "real" programs + let vertex2f = vertex :: Vertex2 GLfloat -> IO () + color3f = color :: Color3 GLfloat -> IO () + in renderPrimitive Triangles $ do + color3f (Color3 1 0 0) + vertex2f (Vertex2 5 5) + color3f (Color3 0 1 0) + vertex2f (Vertex2 25 5) + color3f (Color3 0 0 1) + vertex2f (Vertex2 5 25) + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + triangle + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D 0 30 0 (30 * hf/wf) + else ortho2D 0 (30 * wf/hf) 0 30 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Stencil.hs b/examples/RedBook4/Stencil.hs --- a/examples/RedBook4/Stencil.hs +++ b/examples/RedBook4/Stencil.hs @@ -1,123 +1,123 @@ -{- - Stencil.hs (adapted from stencil.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates use of the stencil buffer for masking - nonrectangular regions. Whenever the window is redrawn, a value of 1 is drawn - into a diamond-shaped region in the stencil buffer. Elsewhere in the stencil - buffer, the value is 0. Then a blue sphere is drawn where the stencil value - is 1, and yellow torii are drawn where the stencil value is not 1. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data DisplayLists = DisplayLists { yellowMat, blueMat :: DisplayList } - -myInit :: IO DisplayLists -myInit = do - y <- defineNewList Compile $ do - materialDiffuse Front $= Color4 0.7 0.7 0 1 - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 64 - - b <- defineNewList Compile $ do - materialDiffuse Front $= Color4 0.1 0.1 0.7 1 - materialSpecular Front $= Color4 0.1 1 1 1 - materialShininess Front $= 45 - - position (Light 0) $= Vertex4 1 1 1 0 - - light (Light 0) $= Enabled - lighting $= Enabled - depthFunc $= Just Less - - clearStencil $= 0 - stencilTest $= Enabled - - return $ DisplayLists { yellowMat = y, blueMat = b } - --- Draw a sphere in a diamond-shaped section in the middle of a window with 2 --- torii. -display :: DisplayLists -> DisplayCallback -display displayLists = do - clear [ ColorBuffer, DepthBuffer ] - - -- draw blue sphere where the stencil is 1 - stencilFunc $= (Equal, 1, 1) - stencilOp $= (OpKeep, OpKeep, OpKeep) - callList (blueMat displayLists) - renderObject Solid (Sphere' 0.5 15 15) - - -- resolve overloading, not needed in "real" programs - let rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () - - -- draw the tori where the stencil is not 1 - stencilFunc $= (Notequal, 1, 1) - preservingMatrix $ do - rotatef 45 (Vector3 0 0 1) - rotatef 45 (Vector3 0 1 0) - callList (yellowMat displayLists) - renderObject Solid (Torus 0.275 0.85 15 15) - preservingMatrix $ do - rotatef 90 (Vector3 1 0 0) - renderObject Solid (Torus 0.275 0.85 15 15) - - flush - --- Whenever the window is reshaped, redefine the coordinate system and redraw --- the stencil area. -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - - -- create a diamond shaped stencil area - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho2D (-3) 3 (-3*hf/wf) (3*hf/wf) - else ortho2D (-3*wf/hf) (3*wf/hf) (-3) 3 - matrixMode $= Modelview 0 - loadIdentity - - -- resolve overloading, not needed in "real" programs - let vertex2f = vertex :: Vertex2 GLfloat -> IO () - translatef = translate :: Vector3 GLfloat -> IO () - - clear [ StencilBuffer ] - stencilFunc $= (Always, 1, 1) - stencilOp $= (OpReplace, OpReplace, OpReplace) - renderPrimitive Quads $ do - vertex2f (Vertex2 (-1) 0) - vertex2f (Vertex2 0 1) - vertex2f (Vertex2 1 0) - vertex2f (Vertex2 0 (-1)) - - matrixMode $= Projection - loadIdentity - perspective 45 (wf/hf) 3 7 - matrixMode $= Modelview 0 - loadIdentity - translatef (Vector3 0 0 (-5)) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Be certain to request stencil bits. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer, WithStencilBuffer ] - initialWindowSize $= Size 400 400 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - displayLists <- myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display displayLists - mainLoop +{- + Stencil.hs (adapted from stencil.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates use of the stencil buffer for masking + nonrectangular regions. Whenever the window is redrawn, a value of 1 is drawn + into a diamond-shaped region in the stencil buffer. Elsewhere in the stencil + buffer, the value is 0. Then a blue sphere is drawn where the stencil value + is 1, and yellow torii are drawn where the stencil value is not 1. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data DisplayLists = DisplayLists { yellowMat, blueMat :: DisplayList } + +myInit :: IO DisplayLists +myInit = do + y <- defineNewList Compile $ do + materialDiffuse Front $= Color4 0.7 0.7 0 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 64 + + b <- defineNewList Compile $ do + materialDiffuse Front $= Color4 0.1 0.1 0.7 1 + materialSpecular Front $= Color4 0.1 1 1 1 + materialShininess Front $= 45 + + position (Light 0) $= Vertex4 1 1 1 0 + + light (Light 0) $= Enabled + lighting $= Enabled + depthFunc $= Just Less + + clearStencil $= 0 + stencilTest $= Enabled + + return $ DisplayLists { yellowMat = y, blueMat = b } + +-- Draw a sphere in a diamond-shaped section in the middle of a window with 2 +-- torii. +display :: DisplayLists -> DisplayCallback +display displayLists = do + clear [ ColorBuffer, DepthBuffer ] + + -- draw blue sphere where the stencil is 1 + stencilFunc $= (Equal, 1, 1) + stencilOp $= (OpKeep, OpKeep, OpKeep) + callList (blueMat displayLists) + renderObject Solid (Sphere' 0.5 15 15) + + -- resolve overloading, not needed in "real" programs + let rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + + -- draw the tori where the stencil is not 1 + stencilFunc $= (Notequal, 1, 1) + preservingMatrix $ do + rotatef 45 (Vector3 0 0 1) + rotatef 45 (Vector3 0 1 0) + callList (yellowMat displayLists) + renderObject Solid (Torus 0.275 0.85 15 15) + preservingMatrix $ do + rotatef 90 (Vector3 1 0 0) + renderObject Solid (Torus 0.275 0.85 15 15) + + flush + +-- Whenever the window is reshaped, redefine the coordinate system and redraw +-- the stencil area. +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + + -- create a diamond shaped stencil area + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D (-3) 3 (-3*hf/wf) (3*hf/wf) + else ortho2D (-3*wf/hf) (3*wf/hf) (-3) 3 + matrixMode $= Modelview 0 + loadIdentity + + -- resolve overloading, not needed in "real" programs + let vertex2f = vertex :: Vertex2 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + + clear [ StencilBuffer ] + stencilFunc $= (Always, 1, 1) + stencilOp $= (OpReplace, OpReplace, OpReplace) + renderPrimitive Quads $ do + vertex2f (Vertex2 (-1) 0) + vertex2f (Vertex2 0 1) + vertex2f (Vertex2 1 0) + vertex2f (Vertex2 0 (-1)) + + matrixMode $= Projection + loadIdentity + perspective 45 (wf/hf) 3 7 + matrixMode $= Modelview 0 + loadIdentity + translatef (Vector3 0 0 (-5)) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Be certain to request stencil bits. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer, WithStencilBuffer ] + initialWindowSize $= Size 400 400 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + displayLists <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display displayLists + mainLoop diff --git a/examples/RedBook4/Stroke.hs b/examples/RedBook4/Stroke.hs --- a/examples/RedBook4/Stroke.hs +++ b/examples/RedBook4/Stroke.hs @@ -1,127 +1,127 @@ -{- - Stroke.hs (adapted from stroke.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates some characters of a stroke (vector) font. The - characters are represented by display lists, which are given numbers which - correspond to the ASCII values of the characters. Use of callLists is - demonstrated. --} - -import Data.List ( genericLength ) -import Foreign.C.String ( castCharToCChar ) -import Foreign.Marshal.Array ( withArray ) -import Graphics.UI.GLUT -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) - -aData, eData, pData, rData, sData :: [[Vertex2 GLfloat]] -aData = [ - [ Vertex2 0 0, Vertex2 0 9, Vertex2 1 10, Vertex2 4 10, Vertex2 5 9, - Vertex2 5 0 ], - [ Vertex2 0 5, Vertex2 5 5 ] ] - -eData = [ - [ Vertex2 5 0, Vertex2 0 0, Vertex2 0 10, Vertex2 5 10 ], - [ Vertex2 0 5, Vertex2 4 5 ] ] - -pData = [ - [ Vertex2 0 0, Vertex2 0 10, Vertex2 4 10, Vertex2 5 9, Vertex2 5 6, - Vertex2 4 5, Vertex2 0 5 ] ] - -rData = [ - [ Vertex2 0 0, Vertex2 0 10, Vertex2 4 10, Vertex2 5 9, Vertex2 5 6, - Vertex2 4 5, Vertex2 0 5 ], - [ Vertex2 3 5, Vertex2 5 0 ] ] - -sData = [ - [ Vertex2 0 1, Vertex2 1 0, Vertex2 4 0, Vertex2 5 1, Vertex2 5 4, - Vertex2 4 5, Vertex2 1 5, Vertex2 0 6, Vertex2 0 9, Vertex2 1 10, - Vertex2 4 10, Vertex2 5 9 ] ] - -advance :: IO () -advance = translate (Vector3 8 0 (0 :: GLfloat)) - --- drawLetter renders a letter with line segments given by the list of line --- strips. -drawLetter :: [[Vertex2 GLfloat]] -> IO () -drawLetter lineStrips = do - mapM_ (renderPrimitive LineStrip . mapM_ vertex) lineStrips - advance - -charToGLubyte :: Char -> GLubyte -charToGLubyte = fromIntegral . castCharToCChar - -myInit :: IO () -myInit = do - shadeModel $= Flat - - (base@(DisplayList b):_) <- genObjectNames 128 - listBase $= base - let charToDisplayList c = DisplayList (b + fromIntegral (charToGLubyte c)) - mapM_ (\(c, d) -> defineList (charToDisplayList c) Compile d) - [ ('A', drawLetter aData), - ('E', drawLetter eData), - ('P', drawLetter pData), - ('R', drawLetter rData), - ('S', drawLetter sData), - (' ', advance) ] - -test1, test2 :: String -test1 = "A SPARE SERAPE APPEARS AS" -test2 = "APES PREPARE RARE PEPPERS" - -printStrokedString :: String -> IO () -printStrokedString s = - withArray (map charToGLubyte s) $ - callLists (genericLength s) UnsignedByte - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () - translatef = translate :: Vector3 GLfloat -> IO () - - color3f (Color3 1 1 1) - preservingMatrix $ do - scalef 2 2 2 - translatef (Vector3 10 30 0) - printStrokedString test1 - preservingMatrix $ do - scalef 2 2 2 - translatef (Vector3 10 13 0) - printStrokedString test2 - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 (fromIntegral w) 0 (fromIntegral h) - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char c) Down _ _ = case c of - ' ' -> postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 440 120 - _ <- createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display - mainLoop +{- + Stroke.hs (adapted from stroke.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates some characters of a stroke (vector) font. The + characters are represented by display lists, which are given numbers which + correspond to the ASCII values of the characters. Use of callLists is + demonstrated. +-} + +import Data.List ( genericLength ) +import Foreign.C.String ( castCharToCChar ) +import Foreign.Marshal.Array ( withArray ) +import Graphics.UI.GLUT +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) + +aData, eData, pData, rData, sData :: [[Vertex2 GLfloat]] +aData = [ + [ Vertex2 0 0, Vertex2 0 9, Vertex2 1 10, Vertex2 4 10, Vertex2 5 9, + Vertex2 5 0 ], + [ Vertex2 0 5, Vertex2 5 5 ] ] + +eData = [ + [ Vertex2 5 0, Vertex2 0 0, Vertex2 0 10, Vertex2 5 10 ], + [ Vertex2 0 5, Vertex2 4 5 ] ] + +pData = [ + [ Vertex2 0 0, Vertex2 0 10, Vertex2 4 10, Vertex2 5 9, Vertex2 5 6, + Vertex2 4 5, Vertex2 0 5 ] ] + +rData = [ + [ Vertex2 0 0, Vertex2 0 10, Vertex2 4 10, Vertex2 5 9, Vertex2 5 6, + Vertex2 4 5, Vertex2 0 5 ], + [ Vertex2 3 5, Vertex2 5 0 ] ] + +sData = [ + [ Vertex2 0 1, Vertex2 1 0, Vertex2 4 0, Vertex2 5 1, Vertex2 5 4, + Vertex2 4 5, Vertex2 1 5, Vertex2 0 6, Vertex2 0 9, Vertex2 1 10, + Vertex2 4 10, Vertex2 5 9 ] ] + +advance :: IO () +advance = translate (Vector3 8 0 (0 :: GLfloat)) + +-- drawLetter renders a letter with line segments given by the list of line +-- strips. +drawLetter :: [[Vertex2 GLfloat]] -> IO () +drawLetter lineStrips = do + mapM_ (renderPrimitive LineStrip . mapM_ vertex) lineStrips + advance + +charToGLubyte :: Char -> GLubyte +charToGLubyte = fromIntegral . castCharToCChar + +myInit :: IO () +myInit = do + shadeModel $= Flat + + (base@(DisplayList b):_) <- genObjectNames 128 + listBase $= base + let charToDisplayList c = DisplayList (b + fromIntegral (charToGLubyte c)) + mapM_ (\(c, d) -> defineList (charToDisplayList c) Compile d) + [ ('A', drawLetter aData), + ('E', drawLetter eData), + ('P', drawLetter pData), + ('R', drawLetter rData), + ('S', drawLetter sData), + (' ', advance) ] + +test1, test2 :: String +test1 = "A SPARE SERAPE APPEARS AS" +test2 = "APES PREPARE RARE PEPPERS" + +printStrokedString :: String -> IO () +printStrokedString s = + withArray (map charToGLubyte s) $ + callLists (genericLength s) UnsignedByte + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + + color3f (Color3 1 1 1) + preservingMatrix $ do + scalef 2 2 2 + translatef (Vector3 10 30 0) + printStrokedString test1 + preservingMatrix $ do + scalef 2 2 2 + translatef (Vector3 10 13 0) + printStrokedString test2 + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char c) Down _ _ = case c of + ' ' -> postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 440 120 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display + mainLoop diff --git a/examples/RedBook4/SurfPoints.hs b/examples/RedBook4/SurfPoints.hs --- a/examples/RedBook4/SurfPoints.hs +++ b/examples/RedBook4/SurfPoints.hs @@ -1,129 +1,129 @@ -{- - SurfPoints.hs (adapted from surfpoints.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program is a modification of the earlier Surface.hs program. The - vertex data are not directly rendered, but are instead passed to the - callback function. The values of the tessellated vertices are printed - out there. - - This program draws a NURBS surface in the shape of a symmetrical hill. - The 'c' keyboard key allows you to toggle the visibility of the control - points themselves. Note that some of the control points are hidden by - the surface itself. - - NOTE: This example does NOT demonstrate the final NURBS API, it's currently - just a test for the internals... --} - -import Control.Monad ( when ) -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import Foreign.Marshal ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { showPoints :: IORef Bool } - -makeState :: IO State -makeState = do - s <- newIORef False - return $ State { showPoints = s } - --- The control points of the surface form a small hill and --- range from -3 to +3 in x, y, and z. -ctlPoints :: [[Vertex3 GLfloat]] -ctlPoints = - [ [ Vertex3 (2 * u - 3) - (2 * v - 3) - (if (u == 1 || u ==2) && (v == 1 || v == 2) then 3 else -3) - | v <- [ 0 .. 3 ] ] - | u <- [ 0 .. 3 ]] - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - materialDiffuse Front $= Color4 0.7 0.7 0.7 1 - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 100 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - autoNormal $= Enabled - normalize $= Enabled - --------------------------------------------------------------------------------- - -display :: State -> DisplayCallback -display state = do - let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - rotate (330 :: GLfloat) (Vector3 1 0 0) - scale 0.5 0.5 (0.5 :: GLfloat) - - withNURBSObj () $ \nurbsObj -> do - setNURBSMode nurbsObj NURBSTessellator - setSamplingMethod nurbsObj (PathLength 25) - setDisplayMode' nurbsObj Fill' - checkForNURBSError nurbsObj $ - withNURBSBeginCallback nurbsObj print $ - withNURBSVertexCallback nurbsObj print $ - withNURBSNormalCallback nurbsObj print $ - withNURBSEndCallback nurbsObj (putStrLn "end") $ - nurbsBeginEndSurface nurbsObj $ - withArray (concat ctlPoints) $ \cBuf -> - withArray knots $ \kBuf -> - nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4 - - s <- get (showPoints state) - when s $ do - pointSize $= 5 - lighting $= Disabled - color (Color3 1 1 (0 :: GLfloat)) - renderPrimitive Points $ - mapM_ (mapM_ vertex) ctlPoints - lighting $= Enabled - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 45 (fromIntegral w / fromIntegral h) 3 8 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-5 :: GLfloat)) - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case toLower c of - 'c' -> do showPoints state $~ not; postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - version <- get (majorMinor gluVersion) - when (version < (1,3)) $ do - putStrLn "This program demonstrates a feature which is introduced in the" - putStrLn "OpenGL Utility Library (GLU) Version 1.3." - putStrLn "If your implementation of GLU has the right extensions," - putStrLn "you may be able to modify this program to make it run." - putStrLn "Continuing anyway..." - state <- makeState - myInit - reshapeCallback $= Just reshape - displayCallback $= display state - keyboardMouseCallback $= Just (keyboard state) - mainLoop +{- + SurfPoints.hs (adapted from surfpoints.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program is a modification of the earlier Surface.hs program. The + vertex data are not directly rendered, but are instead passed to the + callback function. The values of the tessellated vertices are printed + out there. + + This program draws a NURBS surface in the shape of a symmetrical hill. + The 'c' keyboard key allows you to toggle the visibility of the control + points themselves. Note that some of the control points are hidden by + the surface itself. + + NOTE: This example does NOT demonstrate the final NURBS API, it's currently + just a test for the internals... +-} + +import Control.Monad ( when ) +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import Foreign.Marshal ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { showPoints :: IORef Bool } + +makeState :: IO State +makeState = do + s <- newIORef False + return $ State { showPoints = s } + +-- The control points of the surface form a small hill and +-- range from -3 to +3 in x, y, and z. +ctlPoints :: [[Vertex3 GLfloat]] +ctlPoints = + [ [ Vertex3 (2 * u - 3) + (2 * v - 3) + (if (u == 1 || u ==2) && (v == 1 || v == 2) then 3 else -3) + | v <- [ 0 .. 3 ] ] + | u <- [ 0 .. 3 ]] + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + materialDiffuse Front $= Color4 0.7 0.7 0.7 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 100 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + autoNormal $= Enabled + normalize $= Enabled + +-------------------------------------------------------------------------------- + +display :: State -> DisplayCallback +display state = do + let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + rotate (330 :: GLfloat) (Vector3 1 0 0) + scale 0.5 0.5 (0.5 :: GLfloat) + + withNURBSObj () $ \nurbsObj -> do + setNURBSMode nurbsObj NURBSTessellator + setSamplingMethod nurbsObj (PathLength 25) + setDisplayMode' nurbsObj Fill' + checkForNURBSError nurbsObj $ + withNURBSBeginCallback nurbsObj print $ + withNURBSVertexCallback nurbsObj print $ + withNURBSNormalCallback nurbsObj print $ + withNURBSEndCallback nurbsObj (putStrLn "end") $ + nurbsBeginEndSurface nurbsObj $ + withArray (concat ctlPoints) $ \cBuf -> + withArray knots $ \kBuf -> + nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4 + + s <- get (showPoints state) + when s $ do + pointSize $= 5 + lighting $= Disabled + color (Color3 1 1 (0 :: GLfloat)) + renderPrimitive Points $ + mapM_ (mapM_ vertex) ctlPoints + lighting $= Enabled + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 45 (fromIntegral w / fromIntegral h) 3 8 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-5 :: GLfloat)) + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'c' -> do showPoints state $~ not; postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + version <- get (majorMinor gluVersion) + when (version < (1,3)) $ do + putStrLn "This program demonstrates a feature which is introduced in the" + putStrLn "OpenGL Utility Library (GLU) Version 1.3." + putStrLn "If your implementation of GLU has the right extensions," + putStrLn "you may be able to modify this program to make it run." + putStrLn "Continuing anyway..." + state <- makeState + myInit + reshapeCallback $= Just reshape + displayCallback $= display state + keyboardMouseCallback $= Just (keyboard state) + mainLoop diff --git a/examples/RedBook4/Surface.hs b/examples/RedBook4/Surface.hs --- a/examples/RedBook4/Surface.hs +++ b/examples/RedBook4/Surface.hs @@ -1,112 +1,112 @@ -{- - Surface.hs (adapted from surface.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws a NURBS surface in the shape of a symmetrical hill. - The 'c' keyboard key allows you to toggle the visibility of the control - points themselves. Note that some of the control points are hidden by - the surface itself. - - NOTE: This example does NOT demonstrate the final NURBS API, it's currently - just a test for the internals... --} - -import Control.Monad ( when ) -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import Foreign.Marshal ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { showPoints :: IORef Bool } - -makeState :: IO State -makeState = do - s <- newIORef False - return $ State { showPoints = s } - --- The control points of the surface form a small hill and --- range from -3 to +3 in x, y, and z. -ctlPoints :: [[Vertex3 GLfloat]] -ctlPoints = - [ [ Vertex3 (2 * u - 3) - (2 * v - 3) - (if (u == 1 || u ==2) && (v == 1 || v == 2) then 3 else -3) - | v <- [ 0 .. 3 ] ] - | u <- [ 0 .. 3 ]] - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - materialDiffuse Front $= Color4 0.7 0.7 0.7 1 - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 100 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - autoNormal $= Enabled - normalize $= Enabled - --------------------------------------------------------------------------------- - -display :: State -> DisplayCallback -display state = do - let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - rotate (330 :: GLfloat) (Vector3 1 0 0) - scale 0.5 0.5 (0.5 :: GLfloat) - - withNURBSObj () $ \nurbsObj -> do - setSamplingMethod nurbsObj (PathLength 25) - setDisplayMode' nurbsObj Fill' - checkForNURBSError nurbsObj $ - nurbsBeginEndSurface nurbsObj $ - withArray (concat ctlPoints) $ \cBuf -> - withArray knots $ \kBuf -> - nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4 - - s <- get (showPoints state) - when s $ do - pointSize $= 5 - lighting $= Disabled - color (Color3 1 1 (0 :: GLfloat)) - renderPrimitive Points $ - mapM_ (mapM_ vertex) ctlPoints - lighting $= Enabled - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 45 (fromIntegral w / fromIntegral h) 3 8 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-5 :: GLfloat)) - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case toLower c of - 'c' -> do showPoints state $~ not; postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - state <- makeState - myInit - reshapeCallback $= Just reshape - displayCallback $= display state - keyboardMouseCallback $= Just (keyboard state) - mainLoop +{- + Surface.hs (adapted from surface.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws a NURBS surface in the shape of a symmetrical hill. + The 'c' keyboard key allows you to toggle the visibility of the control + points themselves. Note that some of the control points are hidden by + the surface itself. + + NOTE: This example does NOT demonstrate the final NURBS API, it's currently + just a test for the internals... +-} + +import Control.Monad ( when ) +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import Foreign.Marshal ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { showPoints :: IORef Bool } + +makeState :: IO State +makeState = do + s <- newIORef False + return $ State { showPoints = s } + +-- The control points of the surface form a small hill and +-- range from -3 to +3 in x, y, and z. +ctlPoints :: [[Vertex3 GLfloat]] +ctlPoints = + [ [ Vertex3 (2 * u - 3) + (2 * v - 3) + (if (u == 1 || u ==2) && (v == 1 || v == 2) then 3 else -3) + | v <- [ 0 .. 3 ] ] + | u <- [ 0 .. 3 ]] + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + materialDiffuse Front $= Color4 0.7 0.7 0.7 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 100 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + autoNormal $= Enabled + normalize $= Enabled + +-------------------------------------------------------------------------------- + +display :: State -> DisplayCallback +display state = do + let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + rotate (330 :: GLfloat) (Vector3 1 0 0) + scale 0.5 0.5 (0.5 :: GLfloat) + + withNURBSObj () $ \nurbsObj -> do + setSamplingMethod nurbsObj (PathLength 25) + setDisplayMode' nurbsObj Fill' + checkForNURBSError nurbsObj $ + nurbsBeginEndSurface nurbsObj $ + withArray (concat ctlPoints) $ \cBuf -> + withArray knots $ \kBuf -> + nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4 + + s <- get (showPoints state) + when s $ do + pointSize $= 5 + lighting $= Disabled + color (Color3 1 1 (0 :: GLfloat)) + renderPrimitive Points $ + mapM_ (mapM_ vertex) ctlPoints + lighting $= Enabled + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 45 (fromIntegral w / fromIntegral h) 3 8 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-5 :: GLfloat)) + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'c' -> do showPoints state $~ not; postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + myInit + reshapeCallback $= Just reshape + displayCallback $= display state + keyboardMouseCallback $= Just (keyboard state) + mainLoop diff --git a/examples/RedBook4/Teapots.hs b/examples/RedBook4/Teapots.hs --- a/examples/RedBook4/Teapots.hs +++ b/examples/RedBook4/Teapots.hs @@ -1,226 +1,226 @@ -{- - Teapots.hs (adapted from teapots.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates lots of material properties. A single light - source illuminates the objects. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Initialize depth buffer, projection matrix, light source, and lighting --- model. Do not specify a material property here. -myInit :: IO DisplayList -myInit = do - ambient (Light 0) $= Color4 0 0 0 1 - diffuse (Light 0) $= Color4 1 1 1 1 - position (Light 0) $= Vertex4 0 3 3 0 - lightModelAmbient $= Color4 0.2 0.2 0.2 1 - lightModelLocalViewer $= Disabled - - frontFace $= CW - lighting $= Enabled - light (Light 0) $= Enabled - autoNormal $= Enabled - normalize $= Enabled - depthFunc $= Just Less - -- be efficient--make teapot display list - defineNewList Compile $ - renderObject Solid (Teapot 1) - --- Move object into position, specify the material properties, draw a teapot. -renderTeapot :: DisplayList -> Vector3 GLfloat -> Color4 GLfloat - -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> IO () -renderTeapot teapotList pos amb dif spec shine = do - preservingMatrix $ do - translate pos - materialAmbient Front $= amb - materialDiffuse Front $= dif - materialSpecular Front $= spec - materialShininess Front $= shine * 128 - callList teapotList - --- 1st column: emerald, jade, obsidian, pearl, ruby, turquoise --- 2nd column: brass, bronze, chrome, copper, gold, silver --- 3rd column: black, cyan, green, red, white, yellow plastic --- 4th column: black, cyan, green, red, white, yellow rubber -display :: DisplayList -> DisplayCallback -display teapotList = do - clear [ ColorBuffer, DepthBuffer ] - renderTeapot teapotList - (Vector3 2 17 0) - (Color4 0.0215 0.1745 0.0215 1) - (Color4 0.07568 0.61424 0.07568 1) - (Color4 0.633 0.727811 0.633 1) - 0.6 - renderTeapot teapotList - (Vector3 2 14 0) - (Color4 0.135 0.2225 0.1575 1) - (Color4 0.54 0.89 0.63 1) - (Color4 0.316228 0.316228 0.316228 1) - 0.1 - renderTeapot teapotList - (Vector3 2 11 0) - (Color4 0.05375 0.05 0.06625 1) - (Color4 0.18275 0.17 0.22525 1) - (Color4 0.332741 0.328634 0.346435 1) - 0.3 - renderTeapot teapotList - (Vector3 2 8 0) - (Color4 0.25 0.20725 0.20725 1) - (Color4 1 0.829 0.829 1) - (Color4 0.296648 0.296648 0.296648 1) - 0.088 - renderTeapot teapotList - (Vector3 2 5 0) - (Color4 0.1745 0.01175 0.01175 1) - (Color4 0.61424 0.04136 0.04136 1) - (Color4 0.727811 0.626959 0.626959 1) - 0.6 - renderTeapot teapotList - (Vector3 2 2 0) - (Color4 0.1 0.18725 0.1745 1) - (Color4 0.396 0.74151 0.69102 1) - (Color4 0.297254 0.30829 0.306678 1) - 0.1 - renderTeapot teapotList - (Vector3 6 17 0) - (Color4 0.329412 0.223529 0.027451 1) - (Color4 0.780392 0.568627 0.113725 1) - (Color4 0.992157 0.941176 0.807843 1) - 0.21794872 - renderTeapot teapotList - (Vector3 6 14 0) - (Color4 0.2125 0.1275 0.054 1) - (Color4 0.714 0.4284 0.18144 1) - (Color4 0.393548 0.271906 0.166721 1) - 0.2 - renderTeapot teapotList - (Vector3 6 11 0) - (Color4 0.25 0.25 0.25 1) - (Color4 0.4 0.4 0.4 1) - (Color4 0.774597 0.774597 0.774597 1) - 0.6 - renderTeapot teapotList - (Vector3 6 8 0) - (Color4 0.19125 0.0735 0.0225 1) - (Color4 0.7038 0.27048 0.0828 1) - (Color4 0.256777 0.137622 0.086014 1) - 0.1 - renderTeapot teapotList - (Vector3 6 5 0) - (Color4 0.24725 0.1995 0.0745 1) - (Color4 0.75164 0.60648 0.22648 1) - (Color4 0.628281 0.555802 0.366065 1) - 0.4 - renderTeapot teapotList - (Vector3 6 2 0) - (Color4 0.19225 0.19225 0.19225 1) - (Color4 0.50754 0.50754 0.50754 1) - (Color4 0.508273 0.508273 0.508273 1) - 0.4 - renderTeapot teapotList - (Vector3 10 17 0) - (Color4 0 0 0 1) - (Color4 0.01 0.01 0.01 1) - (Color4 0.50 0.50 0.50 1) - 0.25 - renderTeapot teapotList - (Vector3 10 14 0) - (Color4 0 0.1 0.06 1) - (Color4 0 0.50980392 0.50980392 1) - (Color4 0.50196078 0.50196078 0.50196078 1) - 0.25 - renderTeapot teapotList - (Vector3 10 11 0) - (Color4 0 0 0 1) - (Color4 0.1 0.35 0.1 1) - (Color4 0.45 0.55 0.45 1) - 0.25 - renderTeapot teapotList - (Vector3 10 8 0) - (Color4 0 0 0 1) - (Color4 0.5 0 0 1) - (Color4 0.7 0.6 0.6 1) - 0.25 - renderTeapot teapotList - (Vector3 10 5 0) - (Color4 0 0 0 1) - (Color4 0.55 0.55 0.55 1) - (Color4 0.70 0.70 0.70 1) - 0.25 - renderTeapot teapotList - (Vector3 10 2 0) - (Color4 0 0 0 1) - (Color4 0.5 0.5 0 1) - (Color4 0.60 0.60 0.50 1) - 0.25 - renderTeapot teapotList - (Vector3 14 17 0) - (Color4 0.02 0.02 0.02 1) - (Color4 0.01 0.01 0.01 1) - (Color4 0.4 0.4 0.4 1) - 0.078125 - renderTeapot teapotList - (Vector3 14 14 0) - (Color4 0 0.05 0.05 1) - (Color4 0.4 0.5 0.5 1) - (Color4 0.04 0.7 0.7 1) - 0.078125 - renderTeapot teapotList - (Vector3 14 11 0) - (Color4 0 0.05 0 1) - (Color4 0.4 0.5 0.4 1) - (Color4 0.04 0.7 0.04 1) - 0.078125 - renderTeapot teapotList - (Vector3 14 8 0) - (Color4 0.05 0 0 1) - (Color4 0.5 0.4 0.4 1) - (Color4 0.7 0.04 0.04 1) - 0.078125 - renderTeapot teapotList - (Vector3 14 5 0) - (Color4 0.05 0.05 0.05 1) - (Color4 0.5 0.5 0.5 1) - (Color4 0.7 0.7 0.7 1) - 0.078125 - renderTeapot teapotList - (Vector3 14 2 0) - (Color4 0.05 0.05 0 1) - (Color4 0.5 0.5 0.4 1) - (Color4 0.7 0.7 0.04 1) - 0.078125 - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho 0 16 0 (16 * hf/wf) (-10) 10 - else ortho 0 (16 * wf/hf) 0 16 (-10) 10 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 600 - initialWindowPosition $= Position 50 50 - _ <- createWindow progName - teapotList <- myInit - reshapeCallback $= Just reshape - displayCallback $= display teapotList - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Teapots.hs (adapted from teapots.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates lots of material properties. A single light + source illuminates the objects. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Initialize depth buffer, projection matrix, light source, and lighting +-- model. Do not specify a material property here. +myInit :: IO DisplayList +myInit = do + ambient (Light 0) $= Color4 0 0 0 1 + diffuse (Light 0) $= Color4 1 1 1 1 + position (Light 0) $= Vertex4 0 3 3 0 + lightModelAmbient $= Color4 0.2 0.2 0.2 1 + lightModelLocalViewer $= Disabled + + frontFace $= CW + lighting $= Enabled + light (Light 0) $= Enabled + autoNormal $= Enabled + normalize $= Enabled + depthFunc $= Just Less + -- be efficient--make teapot display list + defineNewList Compile $ + renderObject Solid (Teapot 1) + +-- Move object into position, specify the material properties, draw a teapot. +renderTeapot :: DisplayList -> Vector3 GLfloat -> Color4 GLfloat + -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> IO () +renderTeapot teapotList pos amb dif spec shine = do + preservingMatrix $ do + translate pos + materialAmbient Front $= amb + materialDiffuse Front $= dif + materialSpecular Front $= spec + materialShininess Front $= shine * 128 + callList teapotList + +-- 1st column: emerald, jade, obsidian, pearl, ruby, turquoise +-- 2nd column: brass, bronze, chrome, copper, gold, silver +-- 3rd column: black, cyan, green, red, white, yellow plastic +-- 4th column: black, cyan, green, red, white, yellow rubber +display :: DisplayList -> DisplayCallback +display teapotList = do + clear [ ColorBuffer, DepthBuffer ] + renderTeapot teapotList + (Vector3 2 17 0) + (Color4 0.0215 0.1745 0.0215 1) + (Color4 0.07568 0.61424 0.07568 1) + (Color4 0.633 0.727811 0.633 1) + 0.6 + renderTeapot teapotList + (Vector3 2 14 0) + (Color4 0.135 0.2225 0.1575 1) + (Color4 0.54 0.89 0.63 1) + (Color4 0.316228 0.316228 0.316228 1) + 0.1 + renderTeapot teapotList + (Vector3 2 11 0) + (Color4 0.05375 0.05 0.06625 1) + (Color4 0.18275 0.17 0.22525 1) + (Color4 0.332741 0.328634 0.346435 1) + 0.3 + renderTeapot teapotList + (Vector3 2 8 0) + (Color4 0.25 0.20725 0.20725 1) + (Color4 1 0.829 0.829 1) + (Color4 0.296648 0.296648 0.296648 1) + 0.088 + renderTeapot teapotList + (Vector3 2 5 0) + (Color4 0.1745 0.01175 0.01175 1) + (Color4 0.61424 0.04136 0.04136 1) + (Color4 0.727811 0.626959 0.626959 1) + 0.6 + renderTeapot teapotList + (Vector3 2 2 0) + (Color4 0.1 0.18725 0.1745 1) + (Color4 0.396 0.74151 0.69102 1) + (Color4 0.297254 0.30829 0.306678 1) + 0.1 + renderTeapot teapotList + (Vector3 6 17 0) + (Color4 0.329412 0.223529 0.027451 1) + (Color4 0.780392 0.568627 0.113725 1) + (Color4 0.992157 0.941176 0.807843 1) + 0.21794872 + renderTeapot teapotList + (Vector3 6 14 0) + (Color4 0.2125 0.1275 0.054 1) + (Color4 0.714 0.4284 0.18144 1) + (Color4 0.393548 0.271906 0.166721 1) + 0.2 + renderTeapot teapotList + (Vector3 6 11 0) + (Color4 0.25 0.25 0.25 1) + (Color4 0.4 0.4 0.4 1) + (Color4 0.774597 0.774597 0.774597 1) + 0.6 + renderTeapot teapotList + (Vector3 6 8 0) + (Color4 0.19125 0.0735 0.0225 1) + (Color4 0.7038 0.27048 0.0828 1) + (Color4 0.256777 0.137622 0.086014 1) + 0.1 + renderTeapot teapotList + (Vector3 6 5 0) + (Color4 0.24725 0.1995 0.0745 1) + (Color4 0.75164 0.60648 0.22648 1) + (Color4 0.628281 0.555802 0.366065 1) + 0.4 + renderTeapot teapotList + (Vector3 6 2 0) + (Color4 0.19225 0.19225 0.19225 1) + (Color4 0.50754 0.50754 0.50754 1) + (Color4 0.508273 0.508273 0.508273 1) + 0.4 + renderTeapot teapotList + (Vector3 10 17 0) + (Color4 0 0 0 1) + (Color4 0.01 0.01 0.01 1) + (Color4 0.50 0.50 0.50 1) + 0.25 + renderTeapot teapotList + (Vector3 10 14 0) + (Color4 0 0.1 0.06 1) + (Color4 0 0.50980392 0.50980392 1) + (Color4 0.50196078 0.50196078 0.50196078 1) + 0.25 + renderTeapot teapotList + (Vector3 10 11 0) + (Color4 0 0 0 1) + (Color4 0.1 0.35 0.1 1) + (Color4 0.45 0.55 0.45 1) + 0.25 + renderTeapot teapotList + (Vector3 10 8 0) + (Color4 0 0 0 1) + (Color4 0.5 0 0 1) + (Color4 0.7 0.6 0.6 1) + 0.25 + renderTeapot teapotList + (Vector3 10 5 0) + (Color4 0 0 0 1) + (Color4 0.55 0.55 0.55 1) + (Color4 0.70 0.70 0.70 1) + 0.25 + renderTeapot teapotList + (Vector3 10 2 0) + (Color4 0 0 0 1) + (Color4 0.5 0.5 0 1) + (Color4 0.60 0.60 0.50 1) + 0.25 + renderTeapot teapotList + (Vector3 14 17 0) + (Color4 0.02 0.02 0.02 1) + (Color4 0.01 0.01 0.01 1) + (Color4 0.4 0.4 0.4 1) + 0.078125 + renderTeapot teapotList + (Vector3 14 14 0) + (Color4 0 0.05 0.05 1) + (Color4 0.4 0.5 0.5 1) + (Color4 0.04 0.7 0.7 1) + 0.078125 + renderTeapot teapotList + (Vector3 14 11 0) + (Color4 0 0.05 0 1) + (Color4 0.4 0.5 0.4 1) + (Color4 0.04 0.7 0.04 1) + 0.078125 + renderTeapot teapotList + (Vector3 14 8 0) + (Color4 0.05 0 0 1) + (Color4 0.5 0.4 0.4 1) + (Color4 0.7 0.04 0.04 1) + 0.078125 + renderTeapot teapotList + (Vector3 14 5 0) + (Color4 0.05 0.05 0.05 1) + (Color4 0.5 0.5 0.5 1) + (Color4 0.7 0.7 0.7 1) + 0.078125 + renderTeapot teapotList + (Vector3 14 2 0) + (Color4 0.05 0.05 0 1) + (Color4 0.5 0.5 0.4 1) + (Color4 0.7 0.7 0.04 1) + 0.078125 + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho 0 16 0 (16 * hf/wf) (-10) 10 + else ortho 0 (16 * wf/hf) 0 16 (-10) 10 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 600 + initialWindowPosition $= Position 50 50 + _ <- createWindow progName + teapotList <- myInit + reshapeCallback $= Just reshape + displayCallback $= display teapotList + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Tess.hs b/examples/RedBook4/Tess.hs --- a/examples/RedBook4/Tess.hs +++ b/examples/RedBook4/Tess.hs @@ -1,117 +1,117 @@ -{- - Tess.hs (adapted from tess.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates polygon tessellation. Two tesselated objects are - drawn. The first is a rectangle with a triangular hole. The second is a - smooth shaded, self-intersecting star. - - Note the exterior rectangle is drawn with its vertices in counter-clockwise - order, but its interior clockwise. Note the combineCallback is needed for the - self-intersecting star. Also note that removing the TessProperty for the - star will make the interior unshaded (TessWindingOdd). --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -display :: [DisplayList] -> DisplayCallback -display displayLists = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - color3f (Color3 1 1 1) - mapM_ callList displayLists - flush - --- 'Float' is a dummy, any marshalable type would do -type DontCare = Float - -rectangle :: ComplexContour DontCare -rectangle = ComplexContour [ - AnnotatedVertex (Vertex3 50 50 0) 0, - AnnotatedVertex (Vertex3 200 50 0) 0, - AnnotatedVertex (Vertex3 200 200 0) 0, - AnnotatedVertex (Vertex3 50 200 0) 0 ] - -tri :: ComplexContour DontCare -tri = ComplexContour [ - AnnotatedVertex (Vertex3 75 75 0) 0, - AnnotatedVertex (Vertex3 125 175 0) 0, - AnnotatedVertex (Vertex3 175 75 0) 0 ] - -rectAndTri :: ComplexPolygon DontCare -rectAndTri = ComplexPolygon [ rectangle, tri ] - -noOpCombiner :: Combiner DontCare -noOpCombiner _newVertex _weightedProperties = 0 - -star :: ComplexPolygon (Color3 GLfloat) -star = ComplexPolygon [ - ComplexContour [ - AnnotatedVertex (Vertex3 250 50 0) (Color3 1 0 1), - AnnotatedVertex (Vertex3 325 200 0) (Color3 1 1 0), - AnnotatedVertex (Vertex3 400 50 0) (Color3 0 1 1), - AnnotatedVertex (Vertex3 250 150 0) (Color3 1 0 0), - AnnotatedVertex (Vertex3 400 150 0) (Color3 0 1 0) ] ] - -combineColors :: Combiner (Color3 GLfloat) -combineColors - _newVertex - (WeightedProperties - (w0, Color3 r0 g0 b0) - (w1, Color3 r1 g1 b1) - (w2, Color3 r2 g2 b2) - (w3, Color3 r3 g3 b3)) = - Color3 (w0*r0 + w1*r1 + w2*r2 + w3*r3) - (w0*g0 + w1*g1 + w2*g2 + w3*g3) - (w0*b0 + w1*b1 + w2*b2 + w3*b3) - -myInit :: IO [DisplayList] -myInit = do - clearColor $= Color4 0 0 0 0 - - rectAndTriList <- defineNewList Compile $ - drawSimplePolygon (\_ -> return ()) =<< - tessellate TessWindingOdd 0 (Normal3 0 0 0) noOpCombiner rectAndTri - - starList <- defineNewList Compile $ - drawSimplePolygon color =<< - tessellate TessWindingPositive 0 (Normal3 0 0 0) combineColors star - - return [ rectAndTriList, starList ] - -drawSimplePolygon :: (v -> IO ()) -> SimplePolygon v -> IO () -drawSimplePolygon colorHandler (SimplePolygon primitives) = - flip mapM_ primitives $ \(Primitive primitiveMode vertices) -> - renderPrimitive primitiveMode $ - flip mapM_ vertices $ \(AnnotatedVertex plainVertex col) -> do - colorHandler col - vertex plainVertex - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 (fromIntegral w) 0 (fromIntegral h) - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - _ <- createWindow progName - displayLists <- myInit - displayCallback $= display displayLists - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Tess.hs (adapted from tess.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates polygon tessellation. Two tesselated objects are + drawn. The first is a rectangle with a triangular hole. The second is a + smooth shaded, self-intersecting star. + + Note the exterior rectangle is drawn with its vertices in counter-clockwise + order, but its interior clockwise. Note the combineCallback is needed for the + self-intersecting star. Also note that removing the TessProperty for the + star will make the interior unshaded (TessWindingOdd). +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +display :: [DisplayList] -> DisplayCallback +display displayLists = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 1 1 1) + mapM_ callList displayLists + flush + +-- 'Float' is a dummy, any marshalable type would do +type DontCare = Float + +rectangle :: ComplexContour DontCare +rectangle = ComplexContour [ + AnnotatedVertex (Vertex3 50 50 0) 0, + AnnotatedVertex (Vertex3 200 50 0) 0, + AnnotatedVertex (Vertex3 200 200 0) 0, + AnnotatedVertex (Vertex3 50 200 0) 0 ] + +tri :: ComplexContour DontCare +tri = ComplexContour [ + AnnotatedVertex (Vertex3 75 75 0) 0, + AnnotatedVertex (Vertex3 125 175 0) 0, + AnnotatedVertex (Vertex3 175 75 0) 0 ] + +rectAndTri :: ComplexPolygon DontCare +rectAndTri = ComplexPolygon [ rectangle, tri ] + +noOpCombiner :: Combiner DontCare +noOpCombiner _newVertex _weightedProperties = 0 + +star :: ComplexPolygon (Color3 GLfloat) +star = ComplexPolygon [ + ComplexContour [ + AnnotatedVertex (Vertex3 250 50 0) (Color3 1 0 1), + AnnotatedVertex (Vertex3 325 200 0) (Color3 1 1 0), + AnnotatedVertex (Vertex3 400 50 0) (Color3 0 1 1), + AnnotatedVertex (Vertex3 250 150 0) (Color3 1 0 0), + AnnotatedVertex (Vertex3 400 150 0) (Color3 0 1 0) ] ] + +combineColors :: Combiner (Color3 GLfloat) +combineColors + _newVertex + (WeightedProperties + (w0, Color3 r0 g0 b0) + (w1, Color3 r1 g1 b1) + (w2, Color3 r2 g2 b2) + (w3, Color3 r3 g3 b3)) = + Color3 (w0*r0 + w1*r1 + w2*r2 + w3*r3) + (w0*g0 + w1*g1 + w2*g2 + w3*g3) + (w0*b0 + w1*b1 + w2*b2 + w3*b3) + +myInit :: IO [DisplayList] +myInit = do + clearColor $= Color4 0 0 0 0 + + rectAndTriList <- defineNewList Compile $ + drawSimplePolygon (\_ -> return ()) =<< + tessellate TessWindingOdd 0 (Normal3 0 0 0) noOpCombiner rectAndTri + + starList <- defineNewList Compile $ + drawSimplePolygon color =<< + tessellate TessWindingPositive 0 (Normal3 0 0 0) combineColors star + + return [ rectAndTriList, starList ] + +drawSimplePolygon :: (v -> IO ()) -> SimplePolygon v -> IO () +drawSimplePolygon colorHandler (SimplePolygon primitives) = + flip mapM_ primitives $ \(Primitive primitiveMode vertices) -> + renderPrimitive primitiveMode $ + flip mapM_ vertices $ \(AnnotatedVertex plainVertex col) -> do + colorHandler col + vertex plainVertex + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + _ <- createWindow progName + displayLists <- myInit + displayCallback $= display displayLists + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/TessWind.hs b/examples/RedBook4/TessWind.hs --- a/examples/RedBook4/TessWind.hs +++ b/examples/RedBook4/TessWind.hs @@ -1,195 +1,195 @@ -{- - TessWind.hs (adapted from tesswind.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates the winding rule polygon tessellation property. - Four tessellated objects are drawn, each with very different contours. When - the w key is pressed, the objects are drawn with a different winding rule. --} - -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { currentWindingRule :: IORef TessWinding } - -makeState :: IO State -makeState = do - c <- newIORef TessWindingOdd - return $ State { currentWindingRule = c } - -type DisplayLists = (DisplayList, DisplayList, DisplayList, DisplayList) - --- 'Float' is a dummy, any marshalable type would do -type DontCare = Float - -rect1 :: ComplexContour DontCare -rect1 = ComplexContour [ - AnnotatedVertex (Vertex3 50 50 0) 0, - AnnotatedVertex (Vertex3 300 50 0) 0, - AnnotatedVertex (Vertex3 300 300 0) 0, - AnnotatedVertex (Vertex3 50 300 0) 0 ] - -rect2 :: ComplexContour DontCare -rect2 = ComplexContour [ - AnnotatedVertex (Vertex3 100 100 0) 0, - AnnotatedVertex (Vertex3 250 100 0) 0, - AnnotatedVertex (Vertex3 250 250 0) 0, - AnnotatedVertex (Vertex3 100 250 0) 0 ] - -rect3 :: ComplexContour DontCare -rect3 = ComplexContour [ - AnnotatedVertex (Vertex3 150 150 0) 0, - AnnotatedVertex (Vertex3 200 150 0) 0, - AnnotatedVertex (Vertex3 200 200 0) 0, - AnnotatedVertex (Vertex3 150 200 0) 0 ] - -rects1 :: ComplexPolygon DontCare -rects1 = ComplexPolygon [ rect1, rect2, rect3 ] - -rects2 :: ComplexPolygon DontCare -rects2 = ComplexPolygon [ - rect1, reverseComplexContour rect2, reverseComplexContour rect3 ] - -spiral :: ComplexPolygon DontCare -spiral = ComplexPolygon [ - ComplexContour [ - AnnotatedVertex (Vertex3 400 250 0) 0, - AnnotatedVertex (Vertex3 400 50 0) 0, - AnnotatedVertex (Vertex3 50 50 0) 0, - AnnotatedVertex (Vertex3 50 400 0) 0, - AnnotatedVertex (Vertex3 350 400 0) 0, - AnnotatedVertex (Vertex3 350 100 0) 0, - AnnotatedVertex (Vertex3 100 100 0) 0, - AnnotatedVertex (Vertex3 100 350 0) 0, - AnnotatedVertex (Vertex3 300 350 0) 0, - AnnotatedVertex (Vertex3 300 150 0) 0, - AnnotatedVertex (Vertex3 150 150 0) 0, - AnnotatedVertex (Vertex3 150 300 0) 0, - AnnotatedVertex (Vertex3 250 300 0) 0, - AnnotatedVertex (Vertex3 250 200 0) 0, - AnnotatedVertex (Vertex3 200 200 0) 0, - AnnotatedVertex (Vertex3 200 250 0) 0 ] ] - -quad1 :: ComplexContour DontCare -quad1 = ComplexContour [ - AnnotatedVertex (Vertex3 50 150 0) 0, - AnnotatedVertex (Vertex3 350 150 0) 0, - AnnotatedVertex (Vertex3 350 200 0) 0, - AnnotatedVertex (Vertex3 50 200 0) 0 ] - -quad2 :: ComplexContour DontCare -quad2 = ComplexContour [ - AnnotatedVertex (Vertex3 100 100 0) 0, - AnnotatedVertex (Vertex3 300 100 0) 0, - AnnotatedVertex (Vertex3 300 350 0) 0, - AnnotatedVertex (Vertex3 100 350 0) 0 ] - -tri :: ComplexContour DontCare -tri = ComplexContour [ - AnnotatedVertex (Vertex3 200 50 0) 0, - AnnotatedVertex (Vertex3 250 300 0) 0, - AnnotatedVertex (Vertex3 150 300 0) 0 ] - -quadsAndTri :: ComplexPolygon DontCare -quadsAndTri = ComplexPolygon [ quad1, quad2, tri ] - -reverseComplexContour :: ComplexContour DontCare -> ComplexContour DontCare -reverseComplexContour (ComplexContour avs) = ComplexContour (reverse avs) - -makeNewLists :: State -> DisplayLists -> IO () -makeNewLists state (dl1, dl2, dl3, dl4) = do - windingRule <- get (currentWindingRule state) - print windingRule -- not in original program, but useful - compileList windingRule dl1 rects1 - compileList windingRule dl2 rects2 - compileList windingRule dl3 spiral - compileList windingRule dl4 quadsAndTri - -compileList :: TessWinding -> DisplayList -> ComplexPolygon DontCare -> IO () -compileList windingRule displayList complexPolygon = - defineList displayList Compile $ - drawSimplePolygon =<< - tessellate windingRule 0 (Normal3 0 0 0) noOpCombiner complexPolygon - -noOpCombiner :: Combiner DontCare -noOpCombiner _newVertex _weightedProperties = 0 - -drawSimplePolygon :: SimplePolygon DontCare -> IO () -drawSimplePolygon (SimplePolygon primitives) = - flip mapM_ primitives $ \(Primitive primitiveMode vertices) -> - renderPrimitive primitiveMode $ - flip mapM_ vertices $ \(AnnotatedVertex plainVertex _) -> - vertex plainVertex - -display :: DisplayLists -> DisplayCallback -display (dl1, dl2, dl3, dl4) = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - translatef = translate :: Vector3 GLfloat -> IO () - color3f (Color3 1 1 1) - preservingMatrix $ do - callList dl1 - translatef (Vector3 0 500 0) - callList dl2 - translatef (Vector3 500 (-500) 0) - callList dl3 - translatef (Vector3 0 500 0) - callList dl4 - flush - -myInit :: State -> IO DisplayLists -myInit state = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - [dl1, dl2, dl3, dl4] <- genObjectNames 4 - let displayLists = (dl1, dl2, dl3, dl4) - makeNewLists state displayLists - return displayLists - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho2D 0 1000 0 (1000 * hf/wf) - else ortho2D 0 (1000 * wf/hf) 0 1000 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: State -> DisplayLists -> KeyboardMouseCallback -keyboard state displayLists (Char c) Down _ _ = case toLower c of - 'w' -> do currentWindingRule state $~ nextWindingRule - makeNewLists state displayLists - postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ _ = return () - -nextWindingRule :: TessWinding -> TessWinding -nextWindingRule r = case r of - TessWindingOdd -> TessWindingNonzero - TessWindingNonzero -> TessWindingPositive - TessWindingPositive -> TessWindingNegative - TessWindingNegative -> TessWindingAbsGeqTwo - TessWindingAbsGeqTwo -> TessWindingOdd - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - _ <- createWindow progName - state <- makeState - displayLists <- myInit state - displayCallback $= display displayLists - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state displayLists) - mainLoop +{- + TessWind.hs (adapted from tesswind.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the winding rule polygon tessellation property. + Four tessellated objects are drawn, each with very different contours. When + the w key is pressed, the objects are drawn with a different winding rule. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { currentWindingRule :: IORef TessWinding } + +makeState :: IO State +makeState = do + c <- newIORef TessWindingOdd + return $ State { currentWindingRule = c } + +type DisplayLists = (DisplayList, DisplayList, DisplayList, DisplayList) + +-- 'Float' is a dummy, any marshalable type would do +type DontCare = Float + +rect1 :: ComplexContour DontCare +rect1 = ComplexContour [ + AnnotatedVertex (Vertex3 50 50 0) 0, + AnnotatedVertex (Vertex3 300 50 0) 0, + AnnotatedVertex (Vertex3 300 300 0) 0, + AnnotatedVertex (Vertex3 50 300 0) 0 ] + +rect2 :: ComplexContour DontCare +rect2 = ComplexContour [ + AnnotatedVertex (Vertex3 100 100 0) 0, + AnnotatedVertex (Vertex3 250 100 0) 0, + AnnotatedVertex (Vertex3 250 250 0) 0, + AnnotatedVertex (Vertex3 100 250 0) 0 ] + +rect3 :: ComplexContour DontCare +rect3 = ComplexContour [ + AnnotatedVertex (Vertex3 150 150 0) 0, + AnnotatedVertex (Vertex3 200 150 0) 0, + AnnotatedVertex (Vertex3 200 200 0) 0, + AnnotatedVertex (Vertex3 150 200 0) 0 ] + +rects1 :: ComplexPolygon DontCare +rects1 = ComplexPolygon [ rect1, rect2, rect3 ] + +rects2 :: ComplexPolygon DontCare +rects2 = ComplexPolygon [ + rect1, reverseComplexContour rect2, reverseComplexContour rect3 ] + +spiral :: ComplexPolygon DontCare +spiral = ComplexPolygon [ + ComplexContour [ + AnnotatedVertex (Vertex3 400 250 0) 0, + AnnotatedVertex (Vertex3 400 50 0) 0, + AnnotatedVertex (Vertex3 50 50 0) 0, + AnnotatedVertex (Vertex3 50 400 0) 0, + AnnotatedVertex (Vertex3 350 400 0) 0, + AnnotatedVertex (Vertex3 350 100 0) 0, + AnnotatedVertex (Vertex3 100 100 0) 0, + AnnotatedVertex (Vertex3 100 350 0) 0, + AnnotatedVertex (Vertex3 300 350 0) 0, + AnnotatedVertex (Vertex3 300 150 0) 0, + AnnotatedVertex (Vertex3 150 150 0) 0, + AnnotatedVertex (Vertex3 150 300 0) 0, + AnnotatedVertex (Vertex3 250 300 0) 0, + AnnotatedVertex (Vertex3 250 200 0) 0, + AnnotatedVertex (Vertex3 200 200 0) 0, + AnnotatedVertex (Vertex3 200 250 0) 0 ] ] + +quad1 :: ComplexContour DontCare +quad1 = ComplexContour [ + AnnotatedVertex (Vertex3 50 150 0) 0, + AnnotatedVertex (Vertex3 350 150 0) 0, + AnnotatedVertex (Vertex3 350 200 0) 0, + AnnotatedVertex (Vertex3 50 200 0) 0 ] + +quad2 :: ComplexContour DontCare +quad2 = ComplexContour [ + AnnotatedVertex (Vertex3 100 100 0) 0, + AnnotatedVertex (Vertex3 300 100 0) 0, + AnnotatedVertex (Vertex3 300 350 0) 0, + AnnotatedVertex (Vertex3 100 350 0) 0 ] + +tri :: ComplexContour DontCare +tri = ComplexContour [ + AnnotatedVertex (Vertex3 200 50 0) 0, + AnnotatedVertex (Vertex3 250 300 0) 0, + AnnotatedVertex (Vertex3 150 300 0) 0 ] + +quadsAndTri :: ComplexPolygon DontCare +quadsAndTri = ComplexPolygon [ quad1, quad2, tri ] + +reverseComplexContour :: ComplexContour DontCare -> ComplexContour DontCare +reverseComplexContour (ComplexContour avs) = ComplexContour (reverse avs) + +makeNewLists :: State -> DisplayLists -> IO () +makeNewLists state (dl1, dl2, dl3, dl4) = do + windingRule <- get (currentWindingRule state) + print windingRule -- not in original program, but useful + compileList windingRule dl1 rects1 + compileList windingRule dl2 rects2 + compileList windingRule dl3 spiral + compileList windingRule dl4 quadsAndTri + +compileList :: TessWinding -> DisplayList -> ComplexPolygon DontCare -> IO () +compileList windingRule displayList complexPolygon = + defineList displayList Compile $ + drawSimplePolygon =<< + tessellate windingRule 0 (Normal3 0 0 0) noOpCombiner complexPolygon + +noOpCombiner :: Combiner DontCare +noOpCombiner _newVertex _weightedProperties = 0 + +drawSimplePolygon :: SimplePolygon DontCare -> IO () +drawSimplePolygon (SimplePolygon primitives) = + flip mapM_ primitives $ \(Primitive primitiveMode vertices) -> + renderPrimitive primitiveMode $ + flip mapM_ vertices $ \(AnnotatedVertex plainVertex _) -> + vertex plainVertex + +display :: DisplayLists -> DisplayCallback +display (dl1, dl2, dl3, dl4) = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + color3f (Color3 1 1 1) + preservingMatrix $ do + callList dl1 + translatef (Vector3 0 500 0) + callList dl2 + translatef (Vector3 500 (-500) 0) + callList dl3 + translatef (Vector3 0 500 0) + callList dl4 + flush + +myInit :: State -> IO DisplayLists +myInit state = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + [dl1, dl2, dl3, dl4] <- genObjectNames 4 + let displayLists = (dl1, dl2, dl3, dl4) + makeNewLists state displayLists + return displayLists + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D 0 1000 0 (1000 * hf/wf) + else ortho2D 0 (1000 * wf/hf) 0 1000 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: State -> DisplayLists -> KeyboardMouseCallback +keyboard state displayLists (Char c) Down _ _ = case toLower c of + 'w' -> do currentWindingRule state $~ nextWindingRule + makeNewLists state displayLists + postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ _ = return () + +nextWindingRule :: TessWinding -> TessWinding +nextWindingRule r = case r of + TessWindingOdd -> TessWindingNonzero + TessWindingNonzero -> TessWindingPositive + TessWindingPositive -> TessWindingNegative + TessWindingNegative -> TessWindingAbsGeqTwo + TessWindingAbsGeqTwo -> TessWindingOdd + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + _ <- createWindow progName + state <- makeState + displayLists <- myInit state + displayCallback $= display displayLists + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state displayLists) + mainLoop diff --git a/examples/RedBook4/TexBind.hs b/examples/RedBook4/TexBind.hs --- a/examples/RedBook4/TexBind.hs +++ b/examples/RedBook4/TexBind.hs @@ -1,108 +1,108 @@ -{- - TexBind.hs (adapted from texbind.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates using textureBinding by creating and managing - two textures. --} - -import Control.Monad ( when ) -import Data.Bits ( (.&.) ) -import Foreign ( withArray ) -import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Create checkerboard image -checkImageSize :: TextureSize2D -checkImageSize = TextureSize2D 64 64 - -withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) - -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () -withCheckImage (TextureSize2D w h) n f act = - withArray [ f c | - i <- [ 0 .. w - 1 ], - j <- [ 0 .. h - 1 ], - let c | (i .&. n) == (j .&. n) = 0 - | otherwise = 255 ] $ - act . PixelData RGBA UnsignedByte - -myInit :: IO (TextureObject, TextureObject) -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - depthFunc $= Just Less - rowAlignment Unpack $= 1 - - [texName0, texName1] <- genObjectNames 2 - textureBinding Texture2D $= Just texName0 - textureWrapMode Texture2D S $= (Repeated, Clamp) - textureWrapMode Texture2D T $= (Repeated, Clamp) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - withCheckImage checkImageSize 0x08 (\c -> Color4 c c c 255) $ - texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 - - textureBinding Texture2D $= Just texName1 - textureWrapMode Texture2D S $= (Repeated, Clamp) - textureWrapMode Texture2D T $= (Repeated, Clamp) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - textureFunction $= Decal - withCheckImage checkImageSize 0x10 (\c -> Color4 c 0 0 255) $ - texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 - texture Texture2D $= Enabled - return (texName0, texName1) - -display :: (TextureObject, TextureObject) -> DisplayCallback -display (texName0, texName1) = do - clear [ ColorBuffer, DepthBuffer ] - -- resolve overloading, not needed in "real" programs - let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - textureBinding Texture2D $= Just texName0 - renderPrimitive Quads $ do - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) - texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) - texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 ) - texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) - textureBinding Texture2D $= Just texName1 - renderPrimitive Quads $ do - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) - texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 ) - texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) - texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 60 (fromIntegral w / fromIntegral h) 1 30 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-3.6 :: GLfloat)) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - -- we have to do this *after* createWindow, otherwise we have no OpenGL context - version <- get (majorMinor glVersion) - when (version == (1,0)) $ do - putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." - putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," - putStrLn "you may be able to modify this program to make it run." - exitFailure - texNames <- myInit - reshapeCallback $= Just reshape - displayCallback $= display texNames - keyboardMouseCallback $= Just keyboard - mainLoop +{- + TexBind.hs (adapted from texbind.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates using textureBinding by creating and managing + two textures. +-} + +import Control.Monad ( when ) +import Data.Bits ( (.&.) ) +import Foreign ( withArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Create checkerboard image +checkImageSize :: TextureSize2D +checkImageSize = TextureSize2D 64 64 + +withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) + -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () +withCheckImage (TextureSize2D w h) n f act = + withArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] $ + act . PixelData RGBA UnsignedByte + +myInit :: IO (TextureObject, TextureObject) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + rowAlignment Unpack $= 1 + + [texName0, texName1] <- genObjectNames 2 + textureBinding Texture2D $= Just texName0 + textureWrapMode Texture2D S $= (Repeated, Clamp) + textureWrapMode Texture2D T $= (Repeated, Clamp) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + withCheckImage checkImageSize 0x08 (\c -> Color4 c c c 255) $ + texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 + + textureBinding Texture2D $= Just texName1 + textureWrapMode Texture2D S $= (Repeated, Clamp) + textureWrapMode Texture2D T $= (Repeated, Clamp) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + textureFunction $= Decal + withCheckImage checkImageSize 0x10 (\c -> Color4 c 0 0 255) $ + texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 + texture Texture2D $= Enabled + return (texName0, texName1) + +display :: (TextureObject, TextureObject) -> DisplayCallback +display (texName0, texName1) = do + clear [ ColorBuffer, DepthBuffer ] + -- resolve overloading, not needed in "real" programs + let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + textureBinding Texture2D $= Just texName0 + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) + textureBinding Texture2D $= Just texName1 + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-3.6 :: GLfloat)) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + version <- get (majorMinor glVersion) + when (version == (1,0)) $ do + putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." + putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," + putStrLn "you may be able to modify this program to make it run." + exitFailure + texNames <- myInit + reshapeCallback $= Just reshape + displayCallback $= display texNames + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/TexGen.hs b/examples/RedBook4/TexGen.hs --- a/examples/RedBook4/TexGen.hs +++ b/examples/RedBook4/TexGen.hs @@ -1,132 +1,132 @@ -{- - TexGen.hs (adapted from texgen.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws a texture mapped teapot with automatically generated - texture coordinates. The texture is rendered as stripes on the teapot. - Initially, the object is drawn with texture coordinates based upon the - object coordinates of the vertex and distance from the plane x = 0. - Pressing the 'e' key changes the coordinate generation to eye coordinates - of the vertex. Pressing the 'o' key switches it back to the object - coordinates. Pressing the 's' key changes the plane to a slanted one - (x + y + z = 0). Pressing the 'x' key switches it back to x = 0. --} - -import Control.Monad ( when ) -import Data.Char ( toLower ) -import Data.Maybe ( isJust ) -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -stripeImageWidth :: TextureSize1D -stripeImageWidth = TextureSize1D 32 - -xEqualZero, slanted :: Plane GLdouble -xEqualZero = Plane 1 0 0 0 -slanted = Plane 1 1 1 0 - -withStripeImage :: (PixelData (Color4 GLubyte) -> IO a) -> IO a -withStripeImage act = - withArray [ Color4 (if j <= 4 then 255 else 0) - (if j > 4 then 255 else 0) - 0 - 255 - | j <- [ 0 .. w - 1 ] ] $ - act . PixelData RGBA UnsignedByte - where TextureSize1D w = stripeImageWidth - -myInit :: IO (Maybe TextureObject) -myInit = do - clearColor $= Color4 0 0 0 0 - depthFunc $= Just Less - shadeModel $= Smooth - rowAlignment Unpack $= 1 - - exts <- get glExtensions - mbTexName <- if "GL_EXT_texture_object" `elem` exts - then fmap Just genObjectName - else return Nothing - when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName - - textureWrapMode Texture1D S $= (Repeated, Repeat) - textureFilter Texture1D $= ((Linear', Nothing), Linear') - withStripeImage $ texImage1D Texture1D NoProxy 0 RGBA' stripeImageWidth 0 - - textureFunction $= Modulate - textureGenMode S $= Just (ObjectLinear xEqualZero) - - texture Texture1D $= Enabled - lighting $= Enabled - light (Light 0) $= Enabled - autoNormal $= Enabled - normalize $= Enabled - frontFace $= CW - cullFace $= Just Back - materialShininess Front $= 64 - return mbTexName - -display :: Maybe TextureObject -> DisplayCallback -display mbTexName = do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - rotate (45 :: GLfloat) (Vector3 0 0 1) - when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName - renderObject Solid (Teapot 2) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-3.5) 3.5 (-3.5*hf/wf) (3.5*hf/wf) (-3.5) 3.5 - else ortho (-3.5*wf/hf) (3.5*wf/hf) (-3.5) 3.5 (-3.5) 3.5 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char c) Down _ _ = case toLower c of - 'e' -> setGenMode EyeLinear - 'o' -> setGenMode ObjectLinear - 's' -> setPlane slanted - 'x' -> setPlane xEqualZero - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ = return () - -setGenMode :: (Plane GLdouble -> TextureGenMode) -> IO () -setGenMode mode = do - currentGenMode <- get (textureGenMode S) - case currentGenMode of - Just (EyeLinear plane) -> textureGenMode S $= Just (mode plane) - Just (ObjectLinear plane) -> textureGenMode S $= Just (mode plane) - _ -> error "setGenMode: should never happen..." - postRedisplay Nothing - -setPlane :: Plane GLdouble -> IO () -setPlane plane = do - currentGenMode <- get (textureGenMode S) - case currentGenMode of - Just (EyeLinear _) -> textureGenMode S $= Just (EyeLinear plane) - Just (ObjectLinear _) -> textureGenMode S $= Just (ObjectLinear plane) - _ -> error "setPlane: should never happen..." - postRedisplay Nothing - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 256 256 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - mbTexName <- myInit - displayCallback $= display mbTexName - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + TexGen.hs (adapted from texgen.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws a texture mapped teapot with automatically generated + texture coordinates. The texture is rendered as stripes on the teapot. + Initially, the object is drawn with texture coordinates based upon the + object coordinates of the vertex and distance from the plane x = 0. + Pressing the 'e' key changes the coordinate generation to eye coordinates + of the vertex. Pressing the 'o' key switches it back to the object + coordinates. Pressing the 's' key changes the plane to a slanted one + (x + y + z = 0). Pressing the 'x' key switches it back to x = 0. +-} + +import Control.Monad ( when ) +import Data.Char ( toLower ) +import Data.Maybe ( isJust ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +stripeImageWidth :: TextureSize1D +stripeImageWidth = TextureSize1D 32 + +xEqualZero, slanted :: Plane GLdouble +xEqualZero = Plane 1 0 0 0 +slanted = Plane 1 1 1 0 + +withStripeImage :: (PixelData (Color4 GLubyte) -> IO a) -> IO a +withStripeImage act = + withArray [ Color4 (if j <= 4 then 255 else 0) + (if j > 4 then 255 else 0) + 0 + 255 + | j <- [ 0 .. w - 1 ] ] $ + act . PixelData RGBA UnsignedByte + where TextureSize1D w = stripeImageWidth + +myInit :: IO (Maybe TextureObject) +myInit = do + clearColor $= Color4 0 0 0 0 + depthFunc $= Just Less + shadeModel $= Smooth + rowAlignment Unpack $= 1 + + exts <- get glExtensions + mbTexName <- if "GL_EXT_texture_object" `elem` exts + then fmap Just genObjectName + else return Nothing + when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName + + textureWrapMode Texture1D S $= (Repeated, Repeat) + textureFilter Texture1D $= ((Linear', Nothing), Linear') + withStripeImage $ texImage1D Texture1D NoProxy 0 RGBA' stripeImageWidth 0 + + textureFunction $= Modulate + textureGenMode S $= Just (ObjectLinear xEqualZero) + + texture Texture1D $= Enabled + lighting $= Enabled + light (Light 0) $= Enabled + autoNormal $= Enabled + normalize $= Enabled + frontFace $= CW + cullFace $= Just Back + materialShininess Front $= 64 + return mbTexName + +display :: Maybe TextureObject -> DisplayCallback +display mbTexName = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + rotate (45 :: GLfloat) (Vector3 0 0 1) + when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName + renderObject Solid (Teapot 2) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-3.5) 3.5 (-3.5*hf/wf) (3.5*hf/wf) (-3.5) 3.5 + else ortho (-3.5*wf/hf) (3.5*wf/hf) (-3.5) 3.5 (-3.5) 3.5 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char c) Down _ _ = case toLower c of + 'e' -> setGenMode EyeLinear + 'o' -> setGenMode ObjectLinear + 's' -> setPlane slanted + 'x' -> setPlane xEqualZero + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ = return () + +setGenMode :: (Plane GLdouble -> TextureGenMode) -> IO () +setGenMode mode = do + currentGenMode <- get (textureGenMode S) + case currentGenMode of + Just (EyeLinear plane) -> textureGenMode S $= Just (mode plane) + Just (ObjectLinear plane) -> textureGenMode S $= Just (mode plane) + _ -> error "setGenMode: should never happen..." + postRedisplay Nothing + +setPlane :: Plane GLdouble -> IO () +setPlane plane = do + currentGenMode <- get (textureGenMode S) + case currentGenMode of + Just (EyeLinear _) -> textureGenMode S $= Just (EyeLinear plane) + Just (ObjectLinear _) -> textureGenMode S $= Just (ObjectLinear plane) + _ -> error "setPlane: should never happen..." + postRedisplay Nothing + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 256 256 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + mbTexName <- myInit + displayCallback $= display mbTexName + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/TexProx.hs b/examples/RedBook4/TexProx.hs --- a/examples/RedBook4/TexProx.hs +++ b/examples/RedBook4/TexProx.hs @@ -1,58 +1,58 @@ -{- - TexProx.hs (adapted from texprox.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - The brief program illustrates use of texture proxies. This program only - prints out some messages about whether certain size textures are supported - and then exits. --} - -import Control.Monad ( when ) -import Foreign.Ptr ( nullPtr ) -import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - let check = do - ok <- get (textureProxyOK Texture2D 0) - putStrLn ("proxy allocation " ++ if ok then "succeeded" else "failed") - - texImage2D Texture2D Proxy 0 RGBA8 (TextureSize2D 64 64) 0 (PixelData RGBA UnsignedByte nullPtr) - check - - -- Note: We use a larger texture size here to demonstrate failure, - -- modern graphic cards can handle the original size. - texImage2D Texture2D Proxy 0 RGBA16 (TextureSize2D 8192 8192) 0 (PixelData RGBA UnsignedShort nullPtr) - check - - -display :: DisplayCallback -display = exitWith ExitSuccess - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - -- we have to do this *after* createWindow, otherwise we have no OpenGL context - version <- get (majorMinor glVersion) - when (version == (1,0)) $ do - putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." - putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," - putStrLn "you may be able to modify this program to make it run." - exitFailure - myInit - displayCallback $= display - reshapeCallback $= Just reshape - mainLoop +{- + TexProx.hs (adapted from texprox.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + The brief program illustrates use of texture proxies. This program only + prints out some messages about whether certain size textures are supported + and then exits. +-} + +import Control.Monad ( when ) +import Foreign.Ptr ( nullPtr ) +import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + let check = do + ok <- get (textureProxyOK Texture2D 0) + putStrLn ("proxy allocation " ++ if ok then "succeeded" else "failed") + + texImage2D Texture2D Proxy 0 RGBA8 (TextureSize2D 64 64) 0 (PixelData RGBA UnsignedByte nullPtr) + check + + -- Note: We use a larger texture size here to demonstrate failure, + -- modern graphic cards can handle the original size. + texImage2D Texture2D Proxy 0 RGBA16 (TextureSize2D 8192 8192) 0 (PixelData RGBA UnsignedShort nullPtr) + check + + +display :: DisplayCallback +display = exitWith ExitSuccess + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + version <- get (majorMinor glVersion) + when (version == (1,0)) $ do + putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." + putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," + putStrLn "you may be able to modify this program to make it run." + exitFailure + myInit + displayCallback $= display + reshapeCallback $= Just reshape + mainLoop diff --git a/examples/RedBook4/TexSub.hs b/examples/RedBook4/TexSub.hs --- a/examples/RedBook4/TexSub.hs +++ b/examples/RedBook4/TexSub.hs @@ -1,120 +1,120 @@ -{- - TexSub.hs (adapted from texsub.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program texture maps a checkerboard image onto two rectangles. This - program clamps the texture, if the texture coordinates fall outside 0.0 - and 1.0. If the s key is pressed, a texture subimage is used to alter the - original texture. If the r key is pressed, the original texture is restored. --} - -import Control.Monad ( when ) -import Data.Char ( toLower ) -import Data.Bits ( (.&.) ) -import Foreign ( newArray ) -import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -checkImageSize, subImageSize :: TextureSize2D -checkImageSize = TextureSize2D 64 64 -subImageSize = TextureSize2D 16 16 - -type Image = PixelData (Color4 GLubyte) - -makeCheckImage :: - TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) -> IO Image -makeCheckImage (TextureSize2D w h) n f = - fmap (PixelData RGBA UnsignedByte) $ - newArray [ f c | - i <- [ 0 .. w - 1 ], - j <- [ 0 .. h - 1 ], - let c | (i .&. n) == (j .&. n) = 0 - | otherwise = 255 ] - -myInit :: IO (TextureObject, Image, Image) -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - depthFunc $= Just Less - - checkImage <- makeCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) - subImage <- makeCheckImage subImageSize 0x4 (\c -> Color4 c 0 0 255) - rowAlignment Unpack $= 1 - - texName <- genObjectName - textureBinding Texture2D $= Just texName - - textureWrapMode Texture2D S $= (Repeated, Repeat) - textureWrapMode Texture2D T $= (Repeated, Repeat) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 checkImage - return (texName, checkImage, subImage) - -display :: TextureObject -> DisplayCallback -display texName = do - clear [ ColorBuffer, DepthBuffer ] - texture Texture2D $= Enabled - textureFunction $= Decal - textureBinding Texture2D $= Just texName - - -- resolve overloading, not needed in "real" programs - let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - renderPrimitive Quads $ do - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) - texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) - texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 ) - texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) - - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) - texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 ) - texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) - texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) - flush - texture Texture2D $= Disabled - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 60 (fromIntegral w / fromIntegral h) 1 30 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-3.6 :: GLfloat)) - -keyboard :: TextureObject -> Image -> Image -> KeyboardMouseCallback -keyboard texName checkImage subImage (Char c) Down _ _ = case toLower c of - 's' -> do - textureBinding Texture2D $= Just texName - texSubImage2D Texture2D 0 (TexturePosition2D 12 44) subImageSize subImage - postRedisplay Nothing - 'r' -> do - textureBinding Texture2D $= Just texName - texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 checkImage - postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - -- we have to do this *after* createWindow, otherwise we have no OpenGL context - version <- get (majorMinor glVersion) - when (version == (1,0)) $ do - putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." - putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," - putStrLn "you may be able to modify this program to make it run." - exitFailure - (texName, checkImage, subImage) <- myInit - displayCallback $= display texName - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard texName checkImage subImage) - mainLoop +{- + TexSub.hs (adapted from texsub.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program texture maps a checkerboard image onto two rectangles. This + program clamps the texture, if the texture coordinates fall outside 0.0 + and 1.0. If the s key is pressed, a texture subimage is used to alter the + original texture. If the r key is pressed, the original texture is restored. +-} + +import Control.Monad ( when ) +import Data.Char ( toLower ) +import Data.Bits ( (.&.) ) +import Foreign ( newArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +checkImageSize, subImageSize :: TextureSize2D +checkImageSize = TextureSize2D 64 64 +subImageSize = TextureSize2D 16 16 + +type Image = PixelData (Color4 GLubyte) + +makeCheckImage :: + TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) -> IO Image +makeCheckImage (TextureSize2D w h) n f = + fmap (PixelData RGBA UnsignedByte) $ + newArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] + +myInit :: IO (TextureObject, Image, Image) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + + checkImage <- makeCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) + subImage <- makeCheckImage subImageSize 0x4 (\c -> Color4 c 0 0 255) + rowAlignment Unpack $= 1 + + texName <- genObjectName + textureBinding Texture2D $= Just texName + + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 checkImage + return (texName, checkImage, subImage) + +display :: TextureObject -> DisplayCallback +display texName = do + clear [ ColorBuffer, DepthBuffer ] + texture Texture2D $= Enabled + textureFunction $= Decal + textureBinding Texture2D $= Just texName + + -- resolve overloading, not needed in "real" programs + let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) + + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) + flush + texture Texture2D $= Disabled + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-3.6 :: GLfloat)) + +keyboard :: TextureObject -> Image -> Image -> KeyboardMouseCallback +keyboard texName checkImage subImage (Char c) Down _ _ = case toLower c of + 's' -> do + textureBinding Texture2D $= Just texName + texSubImage2D Texture2D 0 (TexturePosition2D 12 44) subImageSize subImage + postRedisplay Nothing + 'r' -> do + textureBinding Texture2D $= Just texName + texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 checkImage + postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + version <- get (majorMinor glVersion) + when (version == (1,0)) $ do + putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." + putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," + putStrLn "you may be able to modify this program to make it run." + exitFailure + (texName, checkImage, subImage) <- myInit + displayCallback $= display texName + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard texName checkImage subImage) + mainLoop diff --git a/examples/RedBook4/Texture3D.hs b/examples/RedBook4/Texture3D.hs --- a/examples/RedBook4/Texture3D.hs +++ b/examples/RedBook4/Texture3D.hs @@ -1,94 +1,94 @@ -{- - Texture3D.hs (adapted from texture3d.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates using a three-dimensional texture. It creates - a 3D texture and then renders two rectangles with different texture - coordinates to obtain different "slices" of the 3D texture. --} - -import Control.Monad ( unless ) -import Foreign ( withArray ) -import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Create checkerboard image -imageSize :: TextureSize3D -imageSize = TextureSize3D 16 16 16 - -withImage :: (PixelData (Color3 GLubyte) -> IO ()) -> IO () -withImage act = - withArray [ Color3 (s * 17) (t * 17) (r * 17) | - r <- [ 0 .. fromIntegral d - 1 ], - t <- [ 0 .. fromIntegral h - 1 ], - s <- [ 0 .. fromIntegral w - 1 ] ] $ - act . PixelData RGB UnsignedByte - where (TextureSize3D w h d) = imageSize - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - depthFunc $= Just Less - rowAlignment Unpack $= 1 - - texName <- genObjectName - textureBinding Texture3D $= Just texName - textureWrapMode Texture3D S $= (Repeated, Clamp) - textureWrapMode Texture3D T $= (Repeated, Clamp) - textureWrapMode Texture3D R $= (Repeated, Clamp) - textureFilter Texture3D $= ((Nearest, Nothing), Nearest) - withImage $ texImage3D Texture3D NoProxy 0 RGB' imageSize 0 - texture Texture3D $= Enabled - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - -- resolve overloading, not needed in "real" programs - let texCoord3f = texCoord :: TexCoord3 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - renderPrimitive Quads $ do - texCoord3f (TexCoord3 0 0 0); vertex3f (Vertex3 (-2.25) (-1) 0) - texCoord3f (TexCoord3 0 1 0); vertex3f (Vertex3 (-2.25) 1 0) - texCoord3f (TexCoord3 1 1 1); vertex3f (Vertex3 (-0.25) 1 0) - texCoord3f (TexCoord3 1 0 1); vertex3f (Vertex3 (-0.25) (-1) 0) - - texCoord3f (TexCoord3 0 0 1); vertex3f (Vertex3 0.25 (-1) 0) - texCoord3f (TexCoord3 0 1 1); vertex3f (Vertex3 0.25 1 0) - texCoord3f (TexCoord3 1 1 0); vertex3f (Vertex3 2.25 1 0) - texCoord3f (TexCoord3 1 0 0); vertex3f (Vertex3 2.25 (-1) 0) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 60 (fromIntegral w / fromIntegral h) 1 30 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-4 :: GLfloat)) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - -- we have to do this *after* createWindow, otherwise we have no OpenGL context - exts <- get glExtensions - unless ("GL_EXT_texture3D" `elem` exts) $ do - putStrLn "Sorry, this demo requires the GL_EXT_texture3D extension." - exitFailure - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Texture3D.hs (adapted from texture3d.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates using a three-dimensional texture. It creates + a 3D texture and then renders two rectangles with different texture + coordinates to obtain different "slices" of the 3D texture. +-} + +import Control.Monad ( unless ) +import Foreign ( withArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Create checkerboard image +imageSize :: TextureSize3D +imageSize = TextureSize3D 16 16 16 + +withImage :: (PixelData (Color3 GLubyte) -> IO ()) -> IO () +withImage act = + withArray [ Color3 (s * 17) (t * 17) (r * 17) | + r <- [ 0 .. fromIntegral d - 1 ], + t <- [ 0 .. fromIntegral h - 1 ], + s <- [ 0 .. fromIntegral w - 1 ] ] $ + act . PixelData RGB UnsignedByte + where (TextureSize3D w h d) = imageSize + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + rowAlignment Unpack $= 1 + + texName <- genObjectName + textureBinding Texture3D $= Just texName + textureWrapMode Texture3D S $= (Repeated, Clamp) + textureWrapMode Texture3D T $= (Repeated, Clamp) + textureWrapMode Texture3D R $= (Repeated, Clamp) + textureFilter Texture3D $= ((Nearest, Nothing), Nearest) + withImage $ texImage3D Texture3D NoProxy 0 RGB' imageSize 0 + texture Texture3D $= Enabled + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + -- resolve overloading, not needed in "real" programs + let texCoord3f = texCoord :: TexCoord3 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Quads $ do + texCoord3f (TexCoord3 0 0 0); vertex3f (Vertex3 (-2.25) (-1) 0) + texCoord3f (TexCoord3 0 1 0); vertex3f (Vertex3 (-2.25) 1 0) + texCoord3f (TexCoord3 1 1 1); vertex3f (Vertex3 (-0.25) 1 0) + texCoord3f (TexCoord3 1 0 1); vertex3f (Vertex3 (-0.25) (-1) 0) + + texCoord3f (TexCoord3 0 0 1); vertex3f (Vertex3 0.25 (-1) 0) + texCoord3f (TexCoord3 0 1 1); vertex3f (Vertex3 0.25 1 0) + texCoord3f (TexCoord3 1 1 0); vertex3f (Vertex3 2.25 1 0) + texCoord3f (TexCoord3 1 0 0); vertex3f (Vertex3 2.25 (-1) 0) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-4 :: GLfloat)) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + exts <- get glExtensions + unless ("GL_EXT_texture3D" `elem` exts) $ do + putStrLn "Sorry, this demo requires the GL_EXT_texture3D extension." + exitFailure + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/TextureSurf.hs b/examples/RedBook4/TextureSurf.hs --- a/examples/RedBook4/TextureSurf.hs +++ b/examples/RedBook4/TextureSurf.hs @@ -1,99 +1,99 @@ -{- - TextureSurf.hs (adapted from texturesurf.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program uses evaluators to generate a curved surface and automatically - generated texture coordinates. --} - -import Data.List ( transpose ) -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -ctrlPoints :: [[Vertex3 GLfloat]] -ctrlPoints = [ - [ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0, - Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ], - [ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0, - Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ], - [ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0, - Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ], - [ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0), - Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]] - -texPts :: [[TexCoord2 GLfloat]] -texPts = [ - [ TexCoord2 0 0, TexCoord2 0 1 ], - [ TexCoord2 1 0, TexCoord2 1 1 ]] - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - color (Color3 1 1 1 :: Color3 GLfloat) - evalMesh2 Fill (0, 20) (0, 20) - flush - -imageSize :: TextureSize2D -imageSize = TextureSize2D 64 64 - -withImage :: (PixelData (Color3 GLubyte) -> IO ()) -> IO () -withImage act = - withArray [ Color3 (s (sin ti)) (s (cos (2 * tj))) (s (cos (ti + tj))) | - i <- [ 0 .. fromIntegral w - 1 ], - let ti = 2 * pi * i / fromIntegral w, - j <- [ 0 .. fromIntegral h - 1 ], - let tj = 2 * pi * j / fromIntegral h ] $ - act . PixelData RGB UnsignedByte - where (TextureSize2D w h) = imageSize - s :: Double -> GLubyte - s x = truncate (127 * (1 + x)) - -myInit :: IO () -myInit = do - m <- newMap2 (0, 1) (0, 1) (transpose ctrlPoints) - map2 $= Just (m :: GLmap2 Vertex3 GLfloat) - t <- newMap2 (0, 1) (0, 1) (transpose texPts) - map2 $= Just (t :: GLmap2 TexCoord2 GLfloat) - mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat))) - textureFunction $= Decal - textureWrapMode Texture2D S $= (Repeated, Repeat) - textureWrapMode Texture2D T $= (Repeated, Repeat) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - withImage $ texImage2D Texture2D NoProxy 0 RGB' imageSize 0 - texture Texture2D $= Enabled - depthFunc $= Just Less - shadeModel $= Flat - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0 - else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0 - matrixMode $= Modelview 0 - loadIdentity - rotate (85 :: GLfloat) (Vector3 1 1 1) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + TextureSurf.hs (adapted from texturesurf.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program uses evaluators to generate a curved surface and automatically + generated texture coordinates. +-} + +import Data.List ( transpose ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +ctrlPoints :: [[Vertex3 GLfloat]] +ctrlPoints = [ + [ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0, + Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ], + [ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0, + Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ], + [ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0, + Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ], + [ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0), + Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]] + +texPts :: [[TexCoord2 GLfloat]] +texPts = [ + [ TexCoord2 0 0, TexCoord2 0 1 ], + [ TexCoord2 1 0, TexCoord2 1 1 ]] + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + color (Color3 1 1 1 :: Color3 GLfloat) + evalMesh2 Fill (0, 20) (0, 20) + flush + +imageSize :: TextureSize2D +imageSize = TextureSize2D 64 64 + +withImage :: (PixelData (Color3 GLubyte) -> IO ()) -> IO () +withImage act = + withArray [ Color3 (s (sin ti)) (s (cos (2 * tj))) (s (cos (ti + tj))) | + i <- [ 0 .. fromIntegral w - 1 ], + let ti = 2 * pi * i / fromIntegral w, + j <- [ 0 .. fromIntegral h - 1 ], + let tj = 2 * pi * j / fromIntegral h ] $ + act . PixelData RGB UnsignedByte + where (TextureSize2D w h) = imageSize + s :: Double -> GLubyte + s x = truncate (127 * (1 + x)) + +myInit :: IO () +myInit = do + m <- newMap2 (0, 1) (0, 1) (transpose ctrlPoints) + map2 $= Just (m :: GLmap2 Vertex3 GLfloat) + t <- newMap2 (0, 1) (0, 1) (transpose texPts) + map2 $= Just (t :: GLmap2 TexCoord2 GLfloat) + mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat))) + textureFunction $= Decal + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + withImage $ texImage2D Texture2D NoProxy 0 RGB' imageSize 0 + texture Texture2D $= Enabled + depthFunc $= Just Less + shadeModel $= Flat + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0 + else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0 + matrixMode $= Modelview 0 + loadIdentity + rotate (85 :: GLfloat) (Vector3 1 1 1) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Torus.hs b/examples/RedBook4/Torus.hs --- a/examples/RedBook4/Torus.hs +++ b/examples/RedBook4/Torus.hs @@ -1,93 +1,93 @@ -{- - Torus.hs (adapted from torus.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates the creation of a display list. --} - -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { spinX, spinY :: IORef GLfloat } - -makeState :: IO State -makeState = do - x <- newIORef 0 - y <- newIORef 0 - return $ State { spinX = x, spinY = y } - -torus :: Int -> Int -> IO () -torus numC numT = do - let stepC = 2 * pi / fromIntegral numC :: GLfloat - stepT = 2 * pi / fromIntegral numT - flip mapM_ [ 0 .. numC - 1 ] $ \i -> - renderPrimitive QuadStrip $ - flip mapM_ [ 0 .. numT ] $ \j -> - flip mapM_ [ 1, 0 ] $ \k -> do - let s = (fromIntegral ((i + k) `mod` numC) + 0.5) * stepC - t = (fromIntegral ( j `mod` numT) ) * stepT - x = (1 + 0.1 * cos s) * cos t - y = (1 + 0.1 * cos s) * sin t - z = 0.1 * sin s - vertex (Vertex3 x y z) - -myInit :: IO DisplayList -myInit = do - theTorus <- defineNewList Compile $ - torus 8 25 - shadeModel $= Flat - clearColor $= Color4 0 0 0 0 - return theTorus - -display :: State -> DisplayList -> DisplayCallback -display state theTorus = do - clear [ ColorBuffer ] - loadIdentity - lookAt (Vertex3 0 0 10) (Vertex3 0 0 0) (Vector3 0 1 0) - x <- get (spinX state) - rotate x (Vector3 1 0 0) - y <- get (spinY state) - rotate y (Vector3 0 1 0) - color (Color3 1 1 (1 :: GLfloat)) - callList theTorus - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 30 (fromIntegral w / fromIntegral h) 1 100 - matrixMode $= Modelview 0 - -incSpin :: IORef GLfloat -> IO () -incSpin spinRef = do - let wrap n s = if s > n then s - n else s - spinRef $~ (wrap 360 . (+ 30)) - postRedisplay Nothing - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case toLower c of - 'x' -> incSpin (spinX state) - 'y' -> incSpin (spinY state) - 'i' -> do spinX state $= 0; spinY state $= 0; postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 200 200 - _ <- createWindow progName - state <- makeState - theTorus <- myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - displayCallback $= display state theTorus - mainLoop +{- + Torus.hs (adapted from torus.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the creation of a display list. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { spinX, spinY :: IORef GLfloat } + +makeState :: IO State +makeState = do + x <- newIORef 0 + y <- newIORef 0 + return $ State { spinX = x, spinY = y } + +torus :: Int -> Int -> IO () +torus numC numT = do + let stepC = 2 * pi / fromIntegral numC :: GLfloat + stepT = 2 * pi / fromIntegral numT + flip mapM_ [ 0 .. numC - 1 ] $ \i -> + renderPrimitive QuadStrip $ + flip mapM_ [ 0 .. numT ] $ \j -> + flip mapM_ [ 1, 0 ] $ \k -> do + let s = (fromIntegral ((i + k) `mod` numC) + 0.5) * stepC + t = (fromIntegral ( j `mod` numT) ) * stepT + x = (1 + 0.1 * cos s) * cos t + y = (1 + 0.1 * cos s) * sin t + z = 0.1 * sin s + vertex (Vertex3 x y z) + +myInit :: IO DisplayList +myInit = do + theTorus <- defineNewList Compile $ + torus 8 25 + shadeModel $= Flat + clearColor $= Color4 0 0 0 0 + return theTorus + +display :: State -> DisplayList -> DisplayCallback +display state theTorus = do + clear [ ColorBuffer ] + loadIdentity + lookAt (Vertex3 0 0 10) (Vertex3 0 0 0) (Vector3 0 1 0) + x <- get (spinX state) + rotate x (Vector3 1 0 0) + y <- get (spinY state) + rotate y (Vector3 0 1 0) + color (Color3 1 1 (1 :: GLfloat)) + callList theTorus + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 30 (fromIntegral w / fromIntegral h) 1 100 + matrixMode $= Modelview 0 + +incSpin :: IORef GLfloat -> IO () +incSpin spinRef = do + let wrap n s = if s > n then s - n else s + spinRef $~ (wrap 360 . (+ 30)) + postRedisplay Nothing + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'x' -> incSpin (spinX state) + 'y' -> incSpin (spinY state) + 'i' -> do spinX state $= 0; spinY state $= 0; postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 200 200 + _ <- createWindow progName + state <- makeState + theTorus <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state theTorus + mainLoop diff --git a/examples/RedBook4/Trim.hs b/examples/RedBook4/Trim.hs --- a/examples/RedBook4/Trim.hs +++ b/examples/RedBook4/Trim.hs @@ -1,107 +1,107 @@ -{- - Trim.hs (adapted from trim.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws a NURBS surface in the shape of a symmetrical hill, - using both a NURBS curve and pwl (piecewise linear) curve to trim part - of the surface. - - NOTE: This example does NOT demonstrate the final NURBS API, it's currently - just a test for the internals... --} - -import Foreign.Marshal ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- The control points of the surface form a small hill and --- range from -3 to +3 in x, y, and z. -ctlPoints :: [[Vertex3 GLfloat]] -ctlPoints = - [ [ Vertex3 (2 * u - 3) - (2 * v - 3) - (if (u == 1 || u ==2) && (v == 1 || v == 2) then 3 else -3) - | v <- [ 0 .. 3 ] ] - | u <- [ 0 .. 3 ]] - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - materialDiffuse Front $= Color4 0.7 0.7 0.7 1 - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 100 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - autoNormal $= Enabled - normalize $= Enabled - --------------------------------------------------------------------------------- - -display :: DisplayCallback -display = do - let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] - edgePt = -- counter clockwise - [ Vertex2 0 0, Vertex2 1 0, Vertex2 1 1, Vertex2 0 1, Vertex2 0 0 ] :: [Vertex2 GLfloat] - curvePt = -- clockwise - [ Vertex2 0.25 0.5, Vertex2 0.25 0.75, Vertex2 0.75 0.75, Vertex2 0.75 0.5 ] :: [Vertex2 GLfloat] - curveKnots = - [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] - pwlPt = -- clockwise - [Vertex2 0.75 0.5, Vertex2 0.5 0.25, Vertex2 0.25 0.5 ] :: [Vertex2 GLfloat] - - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - rotate (330 :: GLfloat) (Vector3 1 0 0) - scale 0.5 0.5 (0.5 :: GLfloat) - - withNURBSObj () $ \nurbsObj -> do - setSamplingMethod nurbsObj (PathLength 25) - setDisplayMode' nurbsObj Fill' - checkForNURBSError nurbsObj $ - nurbsBeginEndSurface nurbsObj $ - withArray (concat ctlPoints) $ \cBuf -> - withArray knots $ \kBuf -> do - nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4 - nurbsBeginEndTrim nurbsObj $ - withArray edgePt $ \edgePtBuf -> - pwlCurve nurbsObj 5 edgePtBuf 2 - nurbsBeginEndTrim nurbsObj $ do - withArray curveKnots $ \curveKnotsBuf -> - withArray curvePt $ \curvePtBuf -> - trimmingCurve nurbsObj 8 curveKnotsBuf 2 curvePtBuf 4 - withArray pwlPt $ \pwlPtBuf -> - pwlCurve nurbsObj 3 pwlPtBuf 2 - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 45 (fromIntegral w / fromIntegral h) 3 8 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-5 :: GLfloat)) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Trim.hs (adapted from trim.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws a NURBS surface in the shape of a symmetrical hill, + using both a NURBS curve and pwl (piecewise linear) curve to trim part + of the surface. + + NOTE: This example does NOT demonstrate the final NURBS API, it's currently + just a test for the internals... +-} + +import Foreign.Marshal ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- The control points of the surface form a small hill and +-- range from -3 to +3 in x, y, and z. +ctlPoints :: [[Vertex3 GLfloat]] +ctlPoints = + [ [ Vertex3 (2 * u - 3) + (2 * v - 3) + (if (u == 1 || u ==2) && (v == 1 || v == 2) then 3 else -3) + | v <- [ 0 .. 3 ] ] + | u <- [ 0 .. 3 ]] + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + materialDiffuse Front $= Color4 0.7 0.7 0.7 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 100 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + autoNormal $= Enabled + normalize $= Enabled + +-------------------------------------------------------------------------------- + +display :: DisplayCallback +display = do + let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] + edgePt = -- counter clockwise + [ Vertex2 0 0, Vertex2 1 0, Vertex2 1 1, Vertex2 0 1, Vertex2 0 0 ] :: [Vertex2 GLfloat] + curvePt = -- clockwise + [ Vertex2 0.25 0.5, Vertex2 0.25 0.75, Vertex2 0.75 0.75, Vertex2 0.75 0.5 ] :: [Vertex2 GLfloat] + curveKnots = + [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] + pwlPt = -- clockwise + [Vertex2 0.75 0.5, Vertex2 0.5 0.25, Vertex2 0.25 0.5 ] :: [Vertex2 GLfloat] + + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + rotate (330 :: GLfloat) (Vector3 1 0 0) + scale 0.5 0.5 (0.5 :: GLfloat) + + withNURBSObj () $ \nurbsObj -> do + setSamplingMethod nurbsObj (PathLength 25) + setDisplayMode' nurbsObj Fill' + checkForNURBSError nurbsObj $ + nurbsBeginEndSurface nurbsObj $ + withArray (concat ctlPoints) $ \cBuf -> + withArray knots $ \kBuf -> do + nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4 + nurbsBeginEndTrim nurbsObj $ + withArray edgePt $ \edgePtBuf -> + pwlCurve nurbsObj 5 edgePtBuf 2 + nurbsBeginEndTrim nurbsObj $ do + withArray curveKnots $ \curveKnotsBuf -> + withArray curvePt $ \curvePtBuf -> + trimmingCurve nurbsObj 8 curveKnotsBuf 2 curvePtBuf 4 + withArray pwlPt $ \pwlPtBuf -> + pwlCurve nurbsObj 3 pwlPtBuf 2 + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 45 (fromIntegral w / fromIntegral h) 3 8 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-5 :: GLfloat)) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/UnProject.hs b/examples/RedBook4/UnProject.hs --- a/examples/RedBook4/UnProject.hs +++ b/examples/RedBook4/UnProject.hs @@ -1,54 +1,54 @@ -{- - UnProject.hs (adapted from unproject.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - When the left mouse button is pressed, this program reads the mouse - position and determines two 3D points from which it was transformed. - Very little is displayed. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 45 (fromIntegral w / fromIntegral h) 1 100 - matrixMode $= Modelview 0 - loadIdentity - -keyboardMouse :: KeyboardMouseCallback -keyboardMouse (MouseButton LeftButton) Down _ (Position x y) = do - v@(_, Size _ h) <- get viewport - mvMatrix <- get (matrix (Just (Modelview 0))) :: IO (GLmatrix GLdouble) - projMatrix <- get (matrix (Just Projection)) :: IO (GLmatrix GLdouble) - let realY = fromIntegral h - y -1 - putStrLn ("Coordinates at cursor are (" ++ show x ++", " ++ show realY ++ ")") - w0 <- unProject (Vertex3 (fromIntegral x) (fromIntegral realY) 0) mvMatrix projMatrix v - putStrLn ("World coords at z=0.0 are " ++ show w0) - w1 <- unProject (Vertex3 (fromIntegral x) (fromIntegral realY) 1) mvMatrix projMatrix v - putStrLn ("World coords at z=1.0 are " ++ show w1) -keyboardMouse (MouseButton RightButton) Down _ _ = exitWith ExitSuccess -keyboardMouse (Char '\27') Down _ _ = exitWith ExitSuccess -keyboardMouse _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboardMouse - mainLoop +{- + UnProject.hs (adapted from unproject.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + When the left mouse button is pressed, this program reads the mouse + position and determines two 3D points from which it was transformed. + Very little is displayed. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 45 (fromIntegral w / fromIntegral h) 1 100 + matrixMode $= Modelview 0 + loadIdentity + +keyboardMouse :: KeyboardMouseCallback +keyboardMouse (MouseButton LeftButton) Down _ (Position x y) = do + v@(_, Size _ h) <- get viewport + mvMatrix <- get (matrix (Just (Modelview 0))) :: IO (GLmatrix GLdouble) + projMatrix <- get (matrix (Just Projection)) :: IO (GLmatrix GLdouble) + let realY = fromIntegral h - y -1 + putStrLn ("Coordinates at cursor are (" ++ show x ++", " ++ show realY ++ ")") + w0 <- unProject (Vertex3 (fromIntegral x) (fromIntegral realY) 0) mvMatrix projMatrix v + putStrLn ("World coords at z=0.0 are " ++ show w0) + w1 <- unProject (Vertex3 (fromIntegral x) (fromIntegral realY) 1) mvMatrix projMatrix v + putStrLn ("World coords at z=1.0 are " ++ show w1) +keyboardMouse (MouseButton RightButton) Down _ _ = exitWith ExitSuccess +keyboardMouse (Char '\27') Down _ _ = exitWith ExitSuccess +keyboardMouse _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboardMouse + mainLoop diff --git a/examples/RedBook4/VArray.hs b/examples/RedBook4/VArray.hs --- a/examples/RedBook4/VArray.hs +++ b/examples/RedBook4/VArray.hs @@ -1,141 +1,141 @@ -{- - VArray.hs (adapted from varray.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates vertex arrays. --} - -import Control.Monad ( when ) -import Data.IORef ( IORef, newIORef ) -import Foreign ( Ptr, newArray ) -import System.Exit ( exitFailure, exitWith, ExitCode(..) ) -import Graphics.UI.GLUT - -data SetupMethod = Pointer | Interleaved - deriving ( Eq, Bounded, Enum ) - -data DerefMethod = DrawArray | ArrayElement | DrawElements - deriving ( Eq, Bounded, Enum ) - -makeVertices :: IO (Ptr (Vertex2 GLint)) -makeVertices = newArray [ - Vertex2 25 25, - Vertex2 100 325, - Vertex2 175 25, - Vertex2 175 325, - Vertex2 250 25, - Vertex2 325 325 ] - -makeColors :: IO (Ptr (Color3 GLfloat)) -makeColors = newArray [ - Color3 1.0 0.2 0.2, - Color3 0.2 0.2 1.0, - Color3 0.8 1.0 0.2, - Color3 0.75 0.75 0.75, - Color3 0.35 0.35 0.35, - Color3 0.5 0.5 0.5 ] - -makeIntertwined :: IO (Ptr GLfloat) -makeIntertwined = newArray [ - 1.0, 0.2, 1.0, 100.0, 100.0, 0.0, - 1.0, 0.2, 0.2, 0.0, 200.0, 0.0, - 1.0, 1.0, 0.2, 100.0, 300.0, 0.0, - 0.2, 1.0, 0.2, 200.0, 300.0, 0.0, - 0.2, 1.0, 1.0, 300.0, 200.0, 0.0, - 0.2, 0.2, 1.0, 200.0, 100.0, 0.0 ] - -makeIndices :: IO (Ptr GLuint) -makeIndices = newArray [ 0, 1, 3, 4 ] - -data State = State { - vertices :: Ptr (Vertex2 GLint), - colors :: Ptr (Color3 GLfloat), - intertwined :: Ptr GLfloat, - indices :: Ptr GLuint, - setupMethod :: IORef SetupMethod, - derefMethod :: IORef DerefMethod } - -makeState :: IO State -makeState = do - v <- makeVertices - c <- makeColors - i <- makeIntertwined - n <- makeIndices - s <- newIORef Pointer - d <- newIORef DrawArray - return $ State { vertices = v, colors = c, intertwined = i, - indices = n, setupMethod = s, derefMethod = d } - -setup :: State -> IO () -setup state = do - s <- get (setupMethod state) - case s of - Pointer -> do - clientState VertexArray $= Enabled - clientState ColorArray $= Enabled - arrayPointer VertexArray $= VertexArrayDescriptor 2 Int 0 (vertices state) - arrayPointer ColorArray $= VertexArrayDescriptor 3 Float 0 (colors state) - Interleaved -> - interleavedArrays C3fV3f 0 (intertwined state) - -myInit :: State -> IO () -myInit state = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Smooth - setup state - -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer ] - d <- get (derefMethod state) - case d of - DrawArray -> drawArrays Triangles 0 6 - ArrayElement -> renderPrimitive Triangles $ mapM_ arrayElement [ 2, 3, 5 ] - DrawElements -> drawElements Polygon 4 UnsignedInt (indices state) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 (fromIntegral w) 0 (fromIntegral h) - -- the following line is not in the original example, but it's good style... - matrixMode $= Modelview 0 - -keyboardMouse :: State -> KeyboardMouseCallback -keyboardMouse state (MouseButton LeftButton) Down _ _ = do - setupMethod state $~ nextValue - setup state - postRedisplay Nothing -keyboardMouse state (MouseButton _) Down _ _ = do - derefMethod state $~ nextValue - postRedisplay Nothing -keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess -keyboardMouse _ _ _ _ _ = return () - -nextValue :: (Eq a, Bounded a, Enum a) => a -> a -nextValue x = if x == maxBound then minBound else succ x - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 350 350 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - -- we have to do this *after* createWindow, otherwise we have no OpenGL context - version <- get (majorMinor glVersion) - when (version == (1,0)) $ do - putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." - putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," - putStrLn "you may be able to modify this program to make it run." - exitFailure - state <- makeState - myInit state - displayCallback $= display state - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboardMouse state) - mainLoop +{- + VArray.hs (adapted from varray.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates vertex arrays. +-} + +import Control.Monad ( when ) +import Data.IORef ( IORef, newIORef ) +import Foreign ( Ptr, newArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(..) ) +import Graphics.UI.GLUT + +data SetupMethod = Pointer | Interleaved + deriving ( Eq, Bounded, Enum ) + +data DerefMethod = DrawArray | ArrayElement | DrawElements + deriving ( Eq, Bounded, Enum ) + +makeVertices :: IO (Ptr (Vertex2 GLint)) +makeVertices = newArray [ + Vertex2 25 25, + Vertex2 100 325, + Vertex2 175 25, + Vertex2 175 325, + Vertex2 250 25, + Vertex2 325 325 ] + +makeColors :: IO (Ptr (Color3 GLfloat)) +makeColors = newArray [ + Color3 1.0 0.2 0.2, + Color3 0.2 0.2 1.0, + Color3 0.8 1.0 0.2, + Color3 0.75 0.75 0.75, + Color3 0.35 0.35 0.35, + Color3 0.5 0.5 0.5 ] + +makeIntertwined :: IO (Ptr GLfloat) +makeIntertwined = newArray [ + 1.0, 0.2, 1.0, 100.0, 100.0, 0.0, + 1.0, 0.2, 0.2, 0.0, 200.0, 0.0, + 1.0, 1.0, 0.2, 100.0, 300.0, 0.0, + 0.2, 1.0, 0.2, 200.0, 300.0, 0.0, + 0.2, 1.0, 1.0, 300.0, 200.0, 0.0, + 0.2, 0.2, 1.0, 200.0, 100.0, 0.0 ] + +makeIndices :: IO (Ptr GLuint) +makeIndices = newArray [ 0, 1, 3, 4 ] + +data State = State { + vertices :: Ptr (Vertex2 GLint), + colors :: Ptr (Color3 GLfloat), + intertwined :: Ptr GLfloat, + indices :: Ptr GLuint, + setupMethod :: IORef SetupMethod, + derefMethod :: IORef DerefMethod } + +makeState :: IO State +makeState = do + v <- makeVertices + c <- makeColors + i <- makeIntertwined + n <- makeIndices + s <- newIORef Pointer + d <- newIORef DrawArray + return $ State { vertices = v, colors = c, intertwined = i, + indices = n, setupMethod = s, derefMethod = d } + +setup :: State -> IO () +setup state = do + s <- get (setupMethod state) + case s of + Pointer -> do + clientState VertexArray $= Enabled + clientState ColorArray $= Enabled + arrayPointer VertexArray $= VertexArrayDescriptor 2 Int 0 (vertices state) + arrayPointer ColorArray $= VertexArrayDescriptor 3 Float 0 (colors state) + Interleaved -> + interleavedArrays C3fV3f 0 (intertwined state) + +myInit :: State -> IO () +myInit state = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + setup state + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + d <- get (derefMethod state) + case d of + DrawArray -> drawArrays Triangles 0 6 + ArrayElement -> renderPrimitive Triangles $ mapM_ arrayElement [ 2, 3, 5 ] + DrawElements -> drawElements Polygon 4 UnsignedInt (indices state) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + -- the following line is not in the original example, but it's good style... + matrixMode $= Modelview 0 + +keyboardMouse :: State -> KeyboardMouseCallback +keyboardMouse state (MouseButton LeftButton) Down _ _ = do + setupMethod state $~ nextValue + setup state + postRedisplay Nothing +keyboardMouse state (MouseButton _) Down _ _ = do + derefMethod state $~ nextValue + postRedisplay Nothing +keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboardMouse _ _ _ _ _ = return () + +nextValue :: (Eq a, Bounded a, Enum a) => a -> a +nextValue x = if x == maxBound then minBound else succ x + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 350 350 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + version <- get (majorMinor glVersion) + when (version == (1,0)) $ do + putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." + putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," + putStrLn "you may be able to modify this program to make it run." + exitFailure + state <- makeState + myInit state + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboardMouse state) + mainLoop diff --git a/examples/RedBook4/Wrap.hs b/examples/RedBook4/Wrap.hs --- a/examples/RedBook4/Wrap.hs +++ b/examples/RedBook4/Wrap.hs @@ -1,114 +1,114 @@ -{- - Wrap.hs (adapted from wrap.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program texture maps a checkerboard image onto two rectangles. This - program demonstrates the wrapping modes, if the texture coordinates fall - outside 0.0 and 1.0. Interaction: Pressing the 's' and 'S' keys switch the - wrapping between clamping and repeating for the s parameter. The 't' and 'T' - keys control the wrapping for the t parameter. - - Texture objects are only used when GL_EXT_texture_object is supported. --} - -import Control.Monad ( when ) -import Data.Maybe ( isJust ) -import Data.Bits ( (.&.) ) -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Create checkerboard image -checkImageSize :: TextureSize2D -checkImageSize = TextureSize2D 64 64 - -withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) - -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () -withCheckImage (TextureSize2D w h) n f act = - withArray [ f c | - i <- [ 0 .. w - 1 ], - j <- [ 0 .. h - 1 ], - let c | (i .&. n) == (j .&. n) = 0 - | otherwise = 255 ] $ - act. PixelData RGBA UnsignedByte - -myInit :: IO (Maybe TextureObject) -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - depthFunc $= Just Less - rowAlignment Unpack $= 1 - - exts <- get glExtensions - mbTexName <- if "GL_EXT_texture_object" `elem` exts - then fmap Just genObjectName - else return Nothing - when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName - - textureWrapMode Texture2D S $= (Repeated, Repeat) - textureWrapMode Texture2D T $= (Repeated, Repeat) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - withCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) $ - texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 - return mbTexName - -display :: Maybe TextureObject -> DisplayCallback -display mbTexName = do - clear [ ColorBuffer, DepthBuffer ] - texture Texture2D $= Enabled - textureFunction $= Decal - when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName - - -- resolve overloading, not needed in "real" programs - let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - renderPrimitive Quads $ do - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) - texCoord2f (TexCoord2 0 3); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) - texCoord2f (TexCoord2 3 3); vertex3f (Vertex3 0.0 1.0 0.0 ) - texCoord2f (TexCoord2 3 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) - - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) - texCoord2f (TexCoord2 0 3); vertex3f (Vertex3 1.0 1.0 0.0 ) - texCoord2f (TexCoord2 3 3); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) - texCoord2f (TexCoord2 3 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) - flush - texture Texture2D $= Disabled - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 60 (fromIntegral w / fromIntegral h) 1 30 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-3.6 :: GLfloat)) - -keyboard :: KeyboardMouseCallback -keyboard (Char 's' ) Down _ _ = setClamping S Clamp -keyboard (Char 'S' ) Down _ _ = setClamping S Repeat -keyboard (Char 't' ) Down _ _ = setClamping T Clamp -keyboard (Char 'T' ) Down _ _ = setClamping T Repeat -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -setClamping :: TextureCoordName -> Clamping -> IO () -setClamping coord clamp = do - textureWrapMode Texture2D coord $= (Repeated, clamp); - postRedisplay Nothing - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - _ <- createWindow progName - mbTexName <- myInit - displayCallback $= display mbTexName - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop +{- + Wrap.hs (adapted from wrap.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program texture maps a checkerboard image onto two rectangles. This + program demonstrates the wrapping modes, if the texture coordinates fall + outside 0.0 and 1.0. Interaction: Pressing the 's' and 'S' keys switch the + wrapping between clamping and repeating for the s parameter. The 't' and 'T' + keys control the wrapping for the t parameter. + + Texture objects are only used when GL_EXT_texture_object is supported. +-} + +import Control.Monad ( when ) +import Data.Maybe ( isJust ) +import Data.Bits ( (.&.) ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Create checkerboard image +checkImageSize :: TextureSize2D +checkImageSize = TextureSize2D 64 64 + +withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) + -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () +withCheckImage (TextureSize2D w h) n f act = + withArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] $ + act. PixelData RGBA UnsignedByte + +myInit :: IO (Maybe TextureObject) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + rowAlignment Unpack $= 1 + + exts <- get glExtensions + mbTexName <- if "GL_EXT_texture_object" `elem` exts + then fmap Just genObjectName + else return Nothing + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + withCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) $ + texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 + return mbTexName + +display :: Maybe TextureObject -> DisplayCallback +display mbTexName = do + clear [ ColorBuffer, DepthBuffer ] + texture Texture2D $= Enabled + textureFunction $= Decal + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + + -- resolve overloading, not needed in "real" programs + let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 3); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) + texCoord2f (TexCoord2 3 3); vertex3f (Vertex3 0.0 1.0 0.0 ) + texCoord2f (TexCoord2 3 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) + + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 3); vertex3f (Vertex3 1.0 1.0 0.0 ) + texCoord2f (TexCoord2 3 3); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) + texCoord2f (TexCoord2 3 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) + flush + texture Texture2D $= Disabled + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-3.6 :: GLfloat)) + +keyboard :: KeyboardMouseCallback +keyboard (Char 's' ) Down _ _ = setClamping S Clamp +keyboard (Char 'S' ) Down _ _ = setClamping S Repeat +keyboard (Char 't' ) Down _ _ = setClamping T Clamp +keyboard (Char 'T' ) Down _ _ = setClamping T Repeat +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +setClamping :: TextureCoordName -> Clamping -> IO () +setClamping coord clamp = do + textureWrapMode Texture2D coord $= (Repeated, clamp); + postRedisplay Nothing + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + mbTexName <- myInit + displayCallback $= display mbTexName + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook8/00-README b/examples/RedBook8/00-README new file mode 100644 --- /dev/null +++ b/examples/RedBook8/00-README @@ -0,0 +1,3 @@ +This directory contains various examples from the book "OpenGL Programming +Guide: The Official Guide to Learning OpenGL, Version 4.3", 8th ed., by +Shreiner/Sellers/Kessenich/Licea-Kane. diff --git a/examples/RedBook8/Chapter01/Makefile b/examples/RedBook8/Chapter01/Makefile new file mode 100644 --- /dev/null +++ b/examples/RedBook8/Chapter01/Makefile @@ -0,0 +1,2 @@ +HC_SEARCH_PATHS := ../common +include ../../examples.mk diff --git a/examples/RedBook8/Chapter01/Triangles.hs b/examples/RedBook8/Chapter01/Triangles.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook8/Chapter01/Triangles.hs @@ -0,0 +1,88 @@ +{- + Triangles.hs (adapted from triangles.cpp which is (c) The Red Book Authors.) + Copyright (c) Sven Panne 2013 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Our first OpenGL program. +-} + +import Control.Monad +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable +import Graphics.UI.GLUT +import Prelude hiding ( init ) +import System.IO +import LoadShaders + +-- TODO: Just for debugging, remove me later. +checkError :: String -> IO () +checkError functionName = get errors >>= mapM_ reportError + where reportError e = + hPutStrLn stderr (showError e ++ " detected in " ++ functionName) + showError (Error category message) = + "GL error " ++ show category ++ " (" ++ message ++ ")" + +bufferOffset :: Integral a => a -> Ptr b +bufferOffset = plusPtr nullPtr . fromIntegral + +data Descriptor = Descriptor VertexArrayObject ArrayIndex NumArrayIndices + +init :: IO Descriptor +init = do + triangles <- genObjectName + bindVertexArrayObject $= Just triangles + + let vertices = [ + Vertex2 (-0.90) (-0.90), -- Triangle 1 + Vertex2 0.85 (-0.90), + Vertex2 (-0.90) 0.85 , + Vertex2 0.90 (-0.85), -- Triangle 2 + Vertex2 0.90 0.90 , + Vertex2 (-0.85) 0.90 ] :: [Vertex2 GLfloat] + numVertices = length vertices + + arrayBuffer <- genObjectName + bindBuffer ArrayBuffer $= Just arrayBuffer + withArray vertices $ \ptr -> do + let size = fromIntegral (numVertices * sizeOf (head vertices)) + bufferData ArrayBuffer $= (size, ptr, StaticDraw) + + program <- loadShaders [ + ShaderInfo VertexShader (FileSource "triangles.vert"), + ShaderInfo FragmentShader (FileSource "triangles.frac")] + currentProgram $= Just program + + let firstIndex = 0 + vPosition = AttribLocation 0 + vertexAttribPointer vPosition $= + (ToFloat, VertexArrayDescriptor 2 Float 0 (bufferOffset firstIndex)) + vertexAttribArray vPosition $= Enabled + + checkError "init" + return $ Descriptor triangles firstIndex (fromIntegral numVertices) + +display :: Descriptor -> DisplayCallback +display (Descriptor triangles firstIndex numVertices) = do + clear [ ColorBuffer ] + bindVertexArrayObject $= Just triangles + drawArrays Triangles firstIndex numVertices + flush + checkError "display" + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ RGBAMode ] + initialWindowSize $= Size 512 512 + initialContextVersion $= (4, 3) + + -- TODO: Just for debugging, remove me later. + initialContextFlags $= [ DebugContext ] + + initialContextProfile $= [ CoreProfile ] + _ <- createWindow progName + descriptor <- init + displayCallback $= display descriptor + mainLoop diff --git a/examples/RedBook8/Chapter01/triangles.frac b/examples/RedBook8/Chapter01/triangles.frac new file mode 100644 --- /dev/null +++ b/examples/RedBook8/Chapter01/triangles.frac @@ -0,0 +1,8 @@ +#version 430 core + +out vec4 fColor; +void +main() +{ + fColor = vec4(0.0, 0.0, 1.0, 1.0); +} diff --git a/examples/RedBook8/Chapter01/triangles.vert b/examples/RedBook8/Chapter01/triangles.vert new file mode 100644 --- /dev/null +++ b/examples/RedBook8/Chapter01/triangles.vert @@ -0,0 +1,9 @@ +#version 430 core + +layout(location = 0) in vec4 vPosition; + +void +main() +{ + gl_Position = vPosition; +} diff --git a/examples/RedBook8/Makefile b/examples/RedBook8/Makefile new file mode 100644 --- /dev/null +++ b/examples/RedBook8/Makefile @@ -0,0 +1,2 @@ +SUBDIRS := $(wildcard Chapter*) +include ../examples.mk diff --git a/examples/RedBook8/common/LoadShaders.hs b/examples/RedBook8/common/LoadShaders.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook8/common/LoadShaders.hs @@ -0,0 +1,94 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : LoadShaders +-- Copyright : (c) Sven Panne 2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- Utilities for shader handling, adapted from LoadShaders.cpp which is (c) The +-- Red Book Authors. +-- +-------------------------------------------------------------------------------- + +module LoadShaders ( + ShaderSource(..), ShaderInfo(..), loadShaders +) where + +import Control.Exception +import Control.Monad +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Graphics.Rendering.OpenGL + +-------------------------------------------------------------------------------- + +-- | The source of the shader source code. + +data ShaderSource = + ByteStringSource B.ByteString + -- ^ The shader source code is directly given as a 'B.ByteString'. + | StringSource String + -- ^ The shader source code is directly given as a 'String'. + | FileSource FilePath + -- ^ The shader source code is located in the file at the given 'FilePath'. + deriving ( Eq, Ord, Show ) + +getSource :: ShaderSource -> IO B.ByteString +getSource (ByteStringSource bs) = return bs +getSource (StringSource str) = return $ packUtf8 str +getSource (FileSource path) = B.readFile path + +packUtf8 :: String -> B.ByteString +packUtf8 = TE.encodeUtf8 . T.pack + +-------------------------------------------------------------------------------- + +-- | A description of a shader: The type of the shader plus its source code. + +data ShaderInfo = ShaderInfo ShaderType ShaderSource + deriving ( Eq, Ord, Show ) + +-------------------------------------------------------------------------------- + +-- | Create a new program object from the given shaders, throwing an +-- 'IOException' if something goes wrong. + +loadShaders :: [ShaderInfo] -> IO Program +loadShaders infos = + createProgram `bracketOnError` deleteObjectName $ \program -> do + loadCompileAttach program infos + linkAndCheck program + return program + +linkAndCheck :: Program -> IO () +linkAndCheck = checked linkProgram linkStatus programInfoLog "link" + +loadCompileAttach :: Program -> [ShaderInfo] -> IO () +loadCompileAttach _ [] = return () +loadCompileAttach program (ShaderInfo shType source : infos) = + createShader shType `bracketOnError` deleteObjectName $ \shader -> do + src <- getSource source + shaderSourceBS shader $= src + compileAndCheck shader + attachShader program shader + loadCompileAttach program infos + +compileAndCheck :: Shader -> IO () +compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile" + +checked :: (t -> IO ()) + -> (t -> GettableStateVar Bool) + -> (t -> GettableStateVar String) + -> String + -> t + -> IO () +checked action getStatus getInfoLog message object = do + action object + ok <- get (getStatus object) + unless ok $ do + infoLog <- get (getInfoLog object) + fail (message ++ " log: " ++ infoLog) diff --git a/examples/RedBook8/common/Makefile b/examples/RedBook8/common/Makefile new file mode 100644 --- /dev/null +++ b/examples/RedBook8/common/Makefile @@ -0,0 +1,2 @@ +include ../../examples.mk +HC := $(HC) -c diff --git a/examples/examples.mk b/examples/examples.mk --- a/examples/examples.mk +++ b/examples/examples.mk @@ -1,37 +1,37 @@ -ALL_DIRS := $(SUBDIRS:%=all-%) -CLEAN_DIRS := $(SUBDIRS:%=clean-%) -HC := ghc -HC_FLAGS := -v0 -Wall -HC_PATH_FLAGS := $(HC_SEARCH_PATHS:%=-i%) -HS_SOURCES := $(wildcard *.hs) -HS_PROG_SOURCES := $(filter-out $(EXCLUDED_SOURCES), $(HS_SOURCES)) -HS_PROGS := $(HS_PROG_SOURCES:.hs=) - -.PHONY: all $(ALL_DIRS) all-common clean $(CLEAN_DIRS) foo - -all: $(ALL_DIRS) $(HS_PROGS) - -$(ALL_DIRS): all-common - $(MAKE) -C $(@:all-%=%) all - -all-common: -ifneq ($(wildcard common),) - $(MAKE) -C common all -endif - -clean: $(CLEAN_DIRS) -ifneq ($(wildcard common),) - $(MAKE) -C common clean -endif -ifneq ($(HS_SOURCES),) - $(RM) $(HS_SOURCES:.hs=.hi) $(HS_SOURCES:.hs=.o) $(HS_PROG_SOURCES:.hs=.exe) $(HS_PROGS) $(wildcard *~) -endif - -$(CLEAN_DIRS): - $(MAKE) -C $(@:clean-%=%) clean - -$(HS_PROGS): %: %.hs - $(HC) $(HC_FLAGS) $(HC_PATH_FLAGS) $(EXTRA_HC_FLAGS) $< - -%.o: %.hs - $(HC) $(HC_FLAGS) $(HC_PATH_FLAGS) $(EXTRA_HC_FLAGS) $< +ALL_DIRS := $(SUBDIRS:%=all-%) +CLEAN_DIRS := $(SUBDIRS:%=clean-%) +HC := ghc +HC_FLAGS := -v0 -Wall +HC_PATH_FLAGS := $(HC_SEARCH_PATHS:%=-i%) +HS_SOURCES := $(wildcard *.hs) +HS_PROG_SOURCES := $(filter-out $(EXCLUDED_SOURCES), $(HS_SOURCES)) +HS_PROGS := $(HS_PROG_SOURCES:.hs=) + +.PHONY: all $(ALL_DIRS) all-common clean $(CLEAN_DIRS) foo + +all: $(ALL_DIRS) $(HS_PROGS) + +$(ALL_DIRS): all-common + $(MAKE) -C $(@:all-%=%) all + +all-common: +ifneq ($(wildcard common),) + $(MAKE) -C common all +endif + +clean: $(CLEAN_DIRS) +ifneq ($(wildcard common),) + $(MAKE) -C common clean +endif +ifneq ($(HS_SOURCES),) + $(RM) $(HS_SOURCES:.hs=.hi) $(HS_SOURCES:.hs=.o) $(HS_PROG_SOURCES:.hs=.exe) $(HS_PROGS) $(wildcard *~) +endif + +$(CLEAN_DIRS): + $(MAKE) -C $(@:clean-%=%) clean + +$(HS_PROGS): %: %.hs + $(HC) $(HC_FLAGS) $(HC_PATH_FLAGS) $(EXTRA_HC_FLAGS) $< + +%.o: %.hs + $(HC) $(HC_FLAGS) $(HC_PATH_FLAGS) $(EXTRA_HC_FLAGS) $< diff --git a/include/HsGLUTExt.h b/include/HsGLUTExt.h --- a/include/HsGLUTExt.h +++ b/include/HsGLUTExt.h @@ -1,33 +1,33 @@ -/* ----------------------------------------------------------------------------- - * - * Module : GLUT extension support for Graphics.UI.GLUT - * Copyright : (c) Sven Panne 2002-2013 - * License : BSD3 - * - * Maintainer : Sven Panne - * Stability : stable - * Portability : portable - * - * This header should only define preprocessor macros! - * - * -------------------------------------------------------------------------- */ - -#ifndef HSGLUTEXT_H -#define HSGLUTEXT_H - -/* NOTE: The macro must immediately start with the foreign declaration, - otherwise the magic mangler (hack_foreign) in the Hugs build system - doesn't recognize it. */ -#define API_ENTRY_INTERNAL(_entry,_ty,_safety) \ -foreign import CALLCONV _safety "dynamic" dyn_/**/_entry :: Graphics.UI.GLUT.Raw.APIEntry.Invoker (_ty) ; \ -_entry :: (_ty) ; \ -_entry = dyn_/**/_entry ptr_/**/_entry ; \ -ptr_/**/_entry :: FunPtr a ; \ -ptr_/**/_entry = unsafePerformIO (Graphics.UI.GLUT.Raw.APIEntry.getAPIEntry "_entry") ; \ -{-# NOINLINE ptr_/**/_entry #-} - -#define API_ENTRY(_entry,_ty) API_ENTRY_INTERNAL(_entry,_ty,unsafe) - -#define API_ENTRY_SAFE(_entry,_ty) API_ENTRY_INTERNAL(_entry,_ty,safe) - -#endif +/* ----------------------------------------------------------------------------- + * + * Module : GLUT extension support for Graphics.UI.GLUT + * Copyright : (c) Sven Panne 2002-2013 + * License : BSD3 + * + * Maintainer : Sven Panne + * Stability : stable + * Portability : portable + * + * This header should only define preprocessor macros! + * + * -------------------------------------------------------------------------- */ + +#ifndef HSGLUTEXT_H +#define HSGLUTEXT_H + +/* NOTE: The macro must immediately start with the foreign declaration, + otherwise the magic mangler (hack_foreign) in the Hugs build system + doesn't recognize it. */ +#define API_ENTRY_INTERNAL(_entry,_ty,_safety) \ +foreign import CALLCONV _safety "dynamic" dyn_/**/_entry :: Graphics.UI.GLUT.Raw.APIEntry.Invoker (_ty) ; \ +_entry :: (_ty) ; \ +_entry = dyn_/**/_entry ptr_/**/_entry ; \ +ptr_/**/_entry :: FunPtr a ; \ +ptr_/**/_entry = unsafePerformIO (Graphics.UI.GLUT.Raw.APIEntry.getAPIEntry "_entry") ; \ +{-# NOINLINE ptr_/**/_entry #-} + +#define API_ENTRY(_entry,_ty) API_ENTRY_INTERNAL(_entry,_ty,unsafe) + +#define API_ENTRY_SAFE(_entry,_ty) API_ENTRY_INTERNAL(_entry,_ty,safe) + +#endif