diff --git a/GLUT.cabal b/GLUT.cabal --- a/GLUT.cabal +++ b/GLUT.cabal @@ -1,19 +1,20 @@ name: GLUT -version: 2.5.1.1 +version: 2.6.0.0 +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: + . +homepage: http://www.haskell.org/haskellwiki/Opengl +bug-reports: https://github.com/haskell-opengl/GLUT/issues license: BSD3 license-file: LICENSE +author: Sven Panne 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 +cabal-version: >=1.10 extra-source-files: README.md examples/00-README @@ -138,58 +139,61 @@ include/HsGLUTExt.h flag UseNativeWindowsLibraries - description: - When compiling under Windows, use the native libraries instead of e.g. the - ones coming with Cygwin. + 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 - build-depends: base >= 3 && < 5, array >= 0.3, containers >= 0.3, 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 + 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 + c-sources: + cbits/HsGLUT.c + hs-source-dirs: src + include-dirs: include + build-depends: base >= 3 && < 5, array >= 0.3, containers >= 0.3, OpenGL >= 2.8.0.0, OpenGLRaw >= 1.3.0.0 + default-language: Haskell2010 + other-extensions: CPP + ghc-options: -Wall -O2 + if os(windows) && flag(UseNativeWindowsLibraries) + if arch(i386) + cpp-options: "-DCALLCONV=stdcall" + else cpp-options: "-DCALLCONV=ccall" - cc-options: "-DUSE_DLSYM" - if os(darwin) - frameworks: GLUT - else - extra-libraries: glut + 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 + type: git + location: https://github.com/haskell-opengl/GLUT.git diff --git a/Graphics/UI/GLUT.hs b/Graphics/UI/GLUT.hs deleted file mode 100644 --- a/Graphics/UI/GLUT.hs +++ /dev/null @@ -1,386 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 deleted file mode 100644 --- a/Graphics/UI/GLUT/Begin.hs +++ /dev/null @@ -1,102 +0,0 @@ --------------------------------------------------------------------------------- --- | --- 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 deleted file mode 100644 --- a/Graphics/UI/GLUT/Callbacks.hs +++ /dev/null @@ -1,47 +0,0 @@ --------------------------------------------------------------------------------- --- | --- 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 deleted file mode 100644 --- a/Graphics/UI/GLUT/Callbacks/Global.hs +++ /dev/null @@ -1,114 +0,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 deleted file mode 100644 --- a/Graphics/UI/GLUT/Callbacks/Registration.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# 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 - -- freeglut-only callback types - | CloseCB | MouseWheelCB | PositionCB - | MultiEntryCB | MultiMotionCB | MultiButtonCB - | MultiPassiveCB | InitContextCB | AppStatusCB - 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 deleted file mode 100644 --- a/Graphics/UI/GLUT/Callbacks/Window.hs +++ /dev/null @@ -1,991 +0,0 @@ --------------------------------------------------------------------------------- --- | --- 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, - - -- * Position callback - PositionCallback, positionCallback, - - -- * Callbacks for visibility changes - Visibility(..), VisibilityCallback, visibilityCallback, - WindowState(..), WindowStateCallback, windowStateCallback, - - -- * Window close callback - CloseCallback, closeCallback, - - -- * Life cycle callbacks for mobile platforms - InitContextCallback, initContextCallback, - AppStatus(..), AppStatusCallback, appStatusCallback, - - -- * 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, - - -- * Multi-touch support - TouchID, - MultiMouseCallback, multiMouseCallback, - MultiCrossingCallback, multiCrossingCallback, - MultiMotionCallback, multiMotionCallback, multiPassiveMotionCallback - -) where - -import Data.Bits hiding ( shift ) -import Data.Char -import Data.Maybe -import Foreign.C.Types -import Graphics.Rendering.OpenGL -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)) - --------------------------------------------------------------------------------- - --- | A position callback - -type PositionCallback = Position -> IO () - --- | (/freeglut only/) Controls the position callback for the /current window./ --- The position callback for a window is called when the position of a window --- changes. - -positionCallback :: SettableStateVar (Maybe PositionCallback) -positionCallback = makeSettableStateVar $ - setCallback PositionCB glutPositionFunc (makePositionFunc . unmarshal) - where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - --- | 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 - --------------------------------------------------------------------------------- - --- | A window close callback - -type CloseCallback = IO () - --- | Controls the window close callback for the /current window/. - -closeCallback :: SettableStateVar (Maybe CloseCallback) -closeCallback = makeSettableStateVar $ - setCallback CloseCB glutCloseFunc makeCloseFunc - --------------------------------------------------------------------------------- - --- | An initialize context callback - -type InitContextCallback = IO () - --- | (/freeglut only/) Controls the initialize context callback for the /current --- window/. - -initContextCallback :: SettableStateVar (Maybe InitContextCallback) -initContextCallback = makeSettableStateVar $ - setCallback InitContextCB glutInitContextFunc makeInitContextFunc - --------------------------------------------------------------------------------- - --- | The application status of the /current window/ - -data AppStatus - = AppStatusPause - | AppStatusResume - deriving ( Eq, Ord, Show ) - -unmarshalAppStatus :: CInt -> AppStatus -unmarshalAppStatus x - | x == glut_APPSTATUS_PAUSE = AppStatusPause - | x == glut_APPSTATUS_RESUME = AppStatusResume - | otherwise = error ("unmarshalAppStatus: illegal value " ++ show x) - --------------------------------------------------------------------------------- - --- | An application status callback - -type AppStatusCallback = AppStatus -> IO () - --- | Controls the application status callback for the /current window./ - -appStatusCallback :: SettableStateVar (Maybe AppStatusCallback) -appStatusCallback = makeSettableStateVar $ - setCallback AppStatusCB glutAppStatusFunc - (makeAppStatusFunc . unmarshal) - where unmarshal cb = cb . unmarshalAppStatus - --------------------------------------------------------------------------------- - --- | 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 - | KeyShiftL - | KeyShiftR - | KeyCtrlL - | KeyCtrlR - | KeyAltL - | KeyAltR - | KeyUnknown Int -- ^ You should actually never encounter this value, it is - -- just here as a safeguard against future changes in the - -- native GLUT library. - 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 - | x == glut_KEY_SHIFT_L = KeyShiftL - | x == glut_KEY_SHIFT_R = KeyShiftR - | x == glut_KEY_CTRL_L = KeyCtrlL - | x == glut_KEY_CTRL_R = KeyCtrlR - | x == glut_KEY_ALT_L = KeyAltL - | x == glut_KEY_ALT_R = KeyAltR - | 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)) - --------------------------------------------------------------------------------- - --- | A description where the multi-touch event is coming from, the freeglut --- specs are very vague about the actual semantics. It contains the device ID --- and\/or the cursor\/finger ID. - -type TouchID = Int - --- | A multi-touch variant of 'MouseCallback'. - -type MultiMouseCallback = TouchID -> MouseCallback - --- | (/freeglut only/) A multi-touch variant of 'mouseCallback'. - -multiMouseCallback :: SettableStateVar (Maybe MultiMouseCallback) -multiMouseCallback = makeSettableStateVar $ - setCallback MultiButtonCB glutMultiButtonFunc (makeMultiButtonFunc . unmarshal) - where unmarshal cb d x y b s = cb (fromIntegral d) - (unmarshalMouseButton b) - (unmarshalKeyState s) - (Position (fromIntegral x) (fromIntegral y)) - --- | A multi-touch variant of 'CrossingCallback'. - -type MultiCrossingCallback = TouchID -> CrossingCallback - --- | (/freeglut only/) A multi-touch variant of 'crossingCallback'. - -multiCrossingCallback :: SettableStateVar (Maybe MultiCrossingCallback) -multiCrossingCallback = makeSettableStateVar $ - setCallback MultiEntryCB glutMultiEntryFunc (makeMultiEntryFunc . unmarshal) - where unmarshal cb d c = cb (fromIntegral d) (unmarshalCrossing c) - --- | A multi-touch variant of 'MotionCallback'. - -type MultiMotionCallback = TouchID -> MotionCallback - --- | (/freeglut only/) A multi-touch variant of 'motionCallback'. - -multiMotionCallback :: SettableStateVar (Maybe MultiMotionCallback) -multiMotionCallback = makeSettableStateVar $ - setCallback MultiMotionCB glutMultiMotionFunc (makeMultiMotionFunc . unmarshal) - where unmarshal cb d x y = - cb (fromIntegral d) (Position (fromIntegral x) (fromIntegral y)) - --- | (/freeglut only/) A multi-touch variant of 'passiveMotionCallback'. - -multiPassiveMotionCallback :: SettableStateVar (Maybe MultiMotionCallback) -multiPassiveMotionCallback = makeSettableStateVar $ - setCallback MultiPassiveCB glutMultiPassiveFunc (makeMultiPassiveFunc . unmarshal) - where unmarshal cb d x y = - cb (fromIntegral d) (Position (fromIntegral x) (fromIntegral y)) diff --git a/Graphics/UI/GLUT/Colormap.hs b/Graphics/UI/GLUT/Colormap.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Colormap.hs +++ /dev/null @@ -1,110 +0,0 @@ --------------------------------------------------------------------------------- --- | --- 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 deleted file mode 100644 --- a/Graphics/UI/GLUT/Debugging.hs +++ /dev/null @@ -1,37 +0,0 @@ --------------------------------------------------------------------------------- --- | --- 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 deleted file mode 100644 --- a/Graphics/UI/GLUT/DeviceControl.hs +++ /dev/null @@ -1,122 +0,0 @@ --------------------------------------------------------------------------------- --- | --- 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 deleted file mode 100644 --- a/Graphics/UI/GLUT/Fonts.hs +++ /dev/null @@ -1,120 +0,0 @@ --------------------------------------------------------------------------------- --- | --- 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 -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 - --------------------------------------------------------------------------------- - -bitmapString :: BitmapFont -> String -> IO () -bitmapString f s = do - i <- marshalBitmapFont 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 <- marshalStrokeFont 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 <- marshalBitmapFont 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 <- marshalStrokeFont f - fmap fromIntegral $ withCString s (glutStrokeLength i . castPtr) - --------------------------------------------------------------------------------- - -bitmapHeight :: BitmapFont -- ^ Bitmap font to use. - -> IO GLfloat -- ^ Height in pixels. -bitmapHeight f = fmap fromIntegral $ glutBitmapHeight =<< marshalBitmapFont f - --------------------------------------------------------------------------------- - -strokeHeight :: StrokeFont -- ^ Stroke font to use. - -> IO GLfloat -- ^ Height in units. -strokeHeight f = glutStrokeHeight =<< marshalStrokeFont f diff --git a/Graphics/UI/GLUT/GameMode.hs b/Graphics/UI/GLUT/GameMode.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/GameMode.hs +++ /dev/null @@ -1,191 +0,0 @@ --------------------------------------------------------------------------------- --- | --- 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 deleted file mode 100644 --- a/Graphics/UI/GLUT/Initialization.hs +++ /dev/null @@ -1,773 +0,0 @@ --------------------------------------------------------------------------------- --- | --- 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 deleted file mode 100644 --- a/Graphics/UI/GLUT/Menu.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# 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 -import Control.Monad -import Data.Map ( Map ) -import Foreign.C.String -import Foreign.C.Types -import Foreign.Ptr -import Graphics.Rendering.OpenGL -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, possibly with an associated font. -data Menu - = Menu [MenuItem] - | MenuWithFont BitmapFont [MenuItem] - -menuFont :: Menu -> Maybe BitmapFont -menuFont (Menu _) = Nothing -menuFont (MenuWithFont font _) = Just font - -menuItems :: Menu -> [MenuItem] -menuItems (Menu items) = items -menuItems (MenuWithFont _ items) = items - --- | 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 = do - win <- getCurrentWindow "attachMenu" - let hook = MenuHook win mouseButton - detachMenu hook - unless (null (menuItems menu)) $ 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 = do - let items = menuItems menu - callbackArray = listArray (1, length items) (map makeCallback items) - cb <- makeMenuFunc (\i -> callbackArray ! (fromIntegral i)) - menuID <- glutCreateMenu cb - maybe (return ()) (setMenuFont menuID) (menuFont menu) - 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 - --------------------------------------------------------------------------------- - -setMenuFont :: MenuID -> BitmapFont -> IO () -setMenuFont menuID font = glutSetMenuFont menuID =<< marshalBitmapFont font diff --git a/Graphics/UI/GLUT/Objects.hs b/Graphics/UI/GLUT/Objects.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Objects.hs +++ /dev/null @@ -1,180 +0,0 @@ --------------------------------------------------------------------------------- --- | --- 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 solid teapot, teacup --- and teaspoon). If VBOs should be used instead of the fixed function pipeline, --- specify at least one of the attribute locations --- 'Graphics.UI.GLUT.State.vertexAttribCoord3' or --- 'Graphics.UI.GLUT.State.vertexAttribNormal'. --- --------------------------------------------------------------------------------- - -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 -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 teaset modeled by Martin Newell in 1975. Both surface normals --- and texture coordinates for the teaset are generated. --- --- * 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 teacup with a given relative size. - Teacup Height - | -- |(/freeglut only/) A teaspoon with a given relative size. - Teaspoon 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) = glutSolidCube h -renderObject Wireframe (Cube h) = glutWireCube h -renderObject Solid Dodecahedron = glutSolidDodecahedron -renderObject Wireframe Dodecahedron = glutWireDodecahedron -renderObject Solid Icosahedron = glutSolidIcosahedron -renderObject Wireframe Icosahedron = glutWireIcosahedron -renderObject Solid Octahedron = glutSolidOctahedron -renderObject Wireframe Octahedron = glutWireOctahedron -renderObject Solid Tetrahedron = glutSolidTetrahedron -renderObject Wireframe Tetrahedron = glutWireTetrahedron -renderObject Solid RhombicDodecahedron = glutSolidRhombicDodecahedron -renderObject Wireframe RhombicDodecahedron = glutWireRhombicDodecahedron -renderObject Solid (Sphere' r s t) = glutSolidSphere r s t -renderObject Wireframe (Sphere' r s t) = glutWireSphere r s t -renderObject Solid (Cone r h s t) = glutSolidCone r h s t -renderObject Wireframe (Cone r h s t) = glutWireCone 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) = glutSolidTorus i o s r -renderObject Wireframe (Torus i o s r) = glutWireTorus i o s r -renderObject Solid (Teapot h) = glutSolidTeapot h -renderObject Wireframe (Teapot h) = glutWireTeapot h -renderObject Solid (Teacup h) = glutSolidTeacup h -renderObject Wireframe (Teacup h) = glutWireTeacup h -renderObject Solid (Teaspoon h) = glutSolidTeaspoon h -renderObject Wireframe (Teaspoon h) = glutWireTeaspoon h -renderObject Solid (SierpinskiSponge n) = solidSierpinskiSponge n -renderObject Wireframe (SierpinskiSponge n) = wireSierpinskiSponge n - --------------------------------------------------------------------------------- - -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 deleted file mode 100644 --- a/Graphics/UI/GLUT/Overlay.hs +++ /dev/null @@ -1,168 +0,0 @@ --------------------------------------------------------------------------------- --- | --- 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 deleted file mode 100644 --- a/Graphics/UI/GLUT/QueryUtils.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Graphics/UI/GLUT/Raw.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Graphics/UI/GLUT/Raw/APIEntry.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Graphics/UI/GLUT/Raw/Callbacks.hs +++ /dev/null @@ -1,243 +0,0 @@ -{-# 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 ( - AppStatusFunc, makeAppStatusFunc, - ButtonBoxFunc, makeButtonBoxFunc, - CloseFunc, makeCloseFunc, - DialsFunc, makeDialsFunc, - DisplayFunc, makeDisplayFunc, - EntryFunc, makeEntryFunc, - IdleFunc, makeIdleFunc, - InitContextFunc, makeInitContextFunc, - JoystickFunc, makeJoystickFunc, - KeyboardFunc, makeKeyboardFunc, - KeyboardUpFunc, makeKeyboardUpFunc, - MenuDestroyFunc, makeMenuDestroyFunc, - MenuFunc, makeMenuFunc, - MenuStateFunc, makeMenuStateFunc, - MenuStatusFunc, makeMenuStatusFunc, - MotionFunc, makeMotionFunc, - MouseFunc, makeMouseFunc, - MouseWheelFunc, makeMouseWheelFunc, - MultiButtonFunc, makeMultiButtonFunc, - MultiEntryFunc, makeMultiEntryFunc, - MultiMotionFunc, makeMultiMotionFunc, - MultiPassiveFunc, makeMultiPassiveFunc, - OverlayDisplayFunc, makeOverlayDisplayFunc, - PassiveMotionFunc, makePassiveMotionFunc, - PositionFunc, makePositionFunc, - 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 AppStatusFunc = CInt -> IO () - -foreign import ccall "wrapper" - makeAppStatusFunc :: AppStatusFunc -> IO (FunPtr AppStatusFunc) - -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 InitContextFunc = IO () - -foreign import ccall "wrapper" - makeInitContextFunc :: InitContextFunc -> IO (FunPtr InitContextFunc) - -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 MenuFunc = CInt -> IO () - -foreign import ccall "wrapper" - makeMenuFunc :: MenuFunc -> IO (FunPtr MenuFunc) - -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 MultiButtonFunc = CInt -> CInt -> CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeMultiButtonFunc :: MultiButtonFunc -> IO (FunPtr MultiButtonFunc) - -type MultiEntryFunc = CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeMultiEntryFunc :: MultiEntryFunc -> IO (FunPtr MultiEntryFunc) - -type MultiMotionFunc = CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeMultiMotionFunc :: MultiMotionFunc -> IO (FunPtr MultiMotionFunc) - -type MultiPassiveFunc = CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeMultiPassiveFunc :: MultiPassiveFunc -> IO (FunPtr MultiPassiveFunc) - -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 PositionFunc = CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makePositionFunc :: PositionFunc -> IO (FunPtr PositionFunc) - -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 deleted file mode 100644 --- a/Graphics/UI/GLUT/Raw/Fonts.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# 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 ( - BitmapFont(..), GLUTbitmapFont, marshalBitmapFont, - StrokeFont(..), GLUTstrokeFont, marshalStrokeFont -) where - -import Foreign.C.Types -import Foreign.Ptr - --------------------------------------------------------------------------------- - --- | 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 () - -marshalBitmapFont :: BitmapFont -> IO GLUTbitmapFont -marshalBitmapFont 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 - - -foreign import ccall unsafe "hs_GLUT_marshalBitmapFont" - hs_GLUT_marshalBitmapFont :: CInt -> IO (Ptr a) - --------------------------------------------------------------------------------- - --- | 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 () - -marshalStrokeFont :: StrokeFont -> IO GLUTstrokeFont -marshalStrokeFont x = case x of - Roman -> hs_GLUT_marshalStrokeFont 0 - MonoRoman -> hs_GLUT_marshalStrokeFont 1 - -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 deleted file mode 100644 --- a/Graphics/UI/GLUT/Raw/Functions.hs +++ /dev/null @@ -1,343 +0,0 @@ -{-# 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 ( - glutAddMenuEntry, - glutAddSubMenu, - glutAppStatusFunc, - glutAttachMenu, - glutBitmapCharacter, - glutBitmapHeight, - glutBitmapLength, - glutBitmapString, - glutBitmapWidth, - glutButtonBoxFunc, - glutChangeToMenuEntry, - glutChangeToSubMenu, - glutCloseFunc, - glutCopyColormap, - glutCreateMenu, - glutCreateSubWindow, - glutCreateWindow, - glutDestroyMenu, - glutDestroyWindow, - glutDetachMenu, - glutDeviceGet, - glutDialsFunc, - glutDisplayFunc, - glutEnterGameMode, - glutEntryFunc, - glutEstablishOverlay, - glutExit, - glutExtensionSupported, - glutForceJoystickFunc, - glutFullScreen, - glutFullScreenToggle, - glutGameModeGet, - glutGameModeString, - glutGet, - glutGetColor, - glutGetMenu, - glutGetMenuData, - glutGetModeValues, - glutGetModifiers, - glutGetProcAddress, - glutGetWindow, - glutGetWindowData, - glutHideOverlay, - glutHideWindow, - glutIconifyWindow, - glutIdleFunc, - glutIgnoreKeyRepeat, - glutInit, - glutInitContextFlags, - glutInitContextFunc, - glutInitContextProfile, - glutInitContextVersion, - glutInitDisplayMode, - glutInitDisplayString, - glutInitWindowPosition, - glutInitWindowSize, - glutJoystickFunc, - glutKeyboardFunc, - glutKeyboardUpFunc, - glutLayerGet, - glutLeaveFullScreen, - glutLeaveGameMode, - glutLeaveMainLoop, - glutMainLoop, - glutMainLoopEvent, - glutMenuDestroyFunc, - glutMenuStateFunc, - glutMenuStatusFunc, - glutMotionFunc, - glutMouseFunc, - glutMouseWheelFunc, - glutMultiButtonFunc, - glutMultiEntryFunc, - glutMultiMotionFunc, - glutMultiPassiveFunc, - glutOverlayDisplayFunc, - glutPassiveMotionFunc, - glutPopWindow, - glutPositionFunc, - glutPositionWindow, - glutPostOverlayRedisplay, - glutPostRedisplay, - glutPostWindowOverlayRedisplay, - glutPostWindowRedisplay, - glutPushWindow, - glutRemoveMenuItem, - glutRemoveOverlay, - glutReportErrors, - glutReshapeFunc, - glutReshapeWindow, - glutSetColor, - glutSetCursor, - glutSetIconTitle, - glutSetKeyRepeat, - glutSetMenu, - glutSetMenuData, - glutSetMenuFont, - glutSetOption, - glutSetVertexAttribCoord3, - glutSetVertexAttribNormal, - glutSetVertexAttribTexCoord2, - glutSetWindow, - glutSetWindowData, - glutSetWindowTitle, - glutSetupVideoResizing, - glutShowOverlay, - glutShowWindow, - glutSolidCone, - glutSolidCube, - glutSolidCylinder, - glutSolidDodecahedron, - glutSolidIcosahedron, - glutSolidOctahedron, - glutSolidRhombicDodecahedron, - glutSolidSierpinskiSponge, - glutSolidSphere, - glutSolidTeacup, - glutSolidTeapot, - glutSolidTeaspoon, - glutSolidTetrahedron, - glutSolidTorus, - glutSpaceballButtonFunc, - glutSpaceballMotionFunc, - glutSpaceballRotateFunc, - glutSpecialFunc, - glutSpecialUpFunc, - glutStopVideoResizing, - glutStrokeCharacter, - glutStrokeHeight, - glutStrokeLength, - glutStrokeString, - glutStrokeWidth, - glutSwapBuffers, - glutTabletButtonFunc, - glutTabletMotionFunc, - glutTimerFunc, - glutUseLayer, - glutVideoPan, - glutVideoResize, - glutVideoResizeGet, - glutVisibilityFunc, - glutWMCloseFunc, - glutWarpPointer, - glutWindowStatusFunc, - glutWireCone, - glutWireCube, - glutWireCylinder, - glutWireDodecahedron, - glutWireIcosahedron, - glutWireOctahedron, - glutWireRhombicDodecahedron, - glutWireSierpinskiSponge, - glutWireSphere, - glutWireTeacup, - glutWireTeapot, - glutWireTeaspoon, - glutWireTetrahedron, - glutWireTorus -) 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(dyn_glutAddMenuEntry,ptr_glutAddMenuEntry,"glutAddMenuEntry",glutAddMenuEntry,Ptr CChar -> CInt -> IO ()) -API_ENTRY(dyn_glutAddSubMenu,ptr_glutAddSubMenu,"glutAddSubMenu",glutAddSubMenu,Ptr CChar -> CInt -> IO ()) -API_ENTRY(dyn_glutAppStatusFunc,ptr_glutAppStatusFunc,"glutAppStatusFunc",glutAppStatusFunc,FunPtr AppStatusFunc -> IO ()) -API_ENTRY(dyn_glutAttachMenu,ptr_glutAttachMenu,"glutAttachMenu",glutAttachMenu,CInt -> IO ()) -API_ENTRY(dyn_glutBitmapCharacter,ptr_glutBitmapCharacter,"glutBitmapCharacter",glutBitmapCharacter,Ptr a -> CInt -> IO ()) -API_ENTRY(dyn_glutBitmapHeight,ptr_glutBitmapHeight,"glutBitmapHeight",glutBitmapHeight,Ptr a -> IO CInt) -API_ENTRY(dyn_glutBitmapLength,ptr_glutBitmapLength,"glutBitmapLength",glutBitmapLength,Ptr a -> Ptr CUChar -> IO CInt) -API_ENTRY(dyn_glutBitmapString,ptr_glutBitmapString,"glutBitmapString",glutBitmapString,Ptr a -> Ptr CUChar -> IO ()) -API_ENTRY(dyn_glutBitmapWidth,ptr_glutBitmapWidth,"glutBitmapWidth",glutBitmapWidth,Ptr a -> CInt -> IO CInt) -API_ENTRY(dyn_glutButtonBoxFunc,ptr_glutButtonBoxFunc,"glutButtonBoxFunc",glutButtonBoxFunc,FunPtr ButtonBoxFunc -> IO ()) -API_ENTRY(dyn_glutChangeToMenuEntry,ptr_glutChangeToMenuEntry,"glutChangeToMenuEntry",glutChangeToMenuEntry,CInt -> Ptr CChar -> CInt -> IO ()) -API_ENTRY(dyn_glutChangeToSubMenu,ptr_glutChangeToSubMenu,"glutChangeToSubMenu",glutChangeToSubMenu,CInt -> Ptr CChar -> CInt -> IO ()) -API_ENTRY(dyn_glutCloseFunc,ptr_glutCloseFunc,"glutCloseFunc",glutCloseFunc,FunPtr CloseFunc -> IO ()) -API_ENTRY(dyn_glutCopyColormap,ptr_glutCopyColormap,"glutCopyColormap",glutCopyColormap,CInt -> IO ()) -API_ENTRY(dyn_glutCreateMenu,ptr_glutCreateMenu,"glutCreateMenu",glutCreateMenu,FunPtr MenuFunc -> IO CInt) -API_ENTRY(dyn_glutCreateSubWindow,ptr_glutCreateSubWindow,"glutCreateSubWindow",glutCreateSubWindow,CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt) -API_ENTRY(dyn_glutCreateWindow,ptr_glutCreateWindow,"glutCreateWindow",glutCreateWindow,Ptr CChar -> IO CInt) -API_ENTRY(dyn_glutDestroyMenu,ptr_glutDestroyMenu,"glutDestroyMenu",glutDestroyMenu,CInt -> IO ()) -API_ENTRY(dyn_glutDestroyWindow,ptr_glutDestroyWindow,"glutDestroyWindow",glutDestroyWindow,CInt -> IO ()) -API_ENTRY(dyn_glutDetachMenu,ptr_glutDetachMenu,"glutDetachMenu",glutDetachMenu,CInt -> IO ()) -API_ENTRY(dyn_glutDeviceGet,ptr_glutDeviceGet,"glutDeviceGet",glutDeviceGet,GLenum -> IO CInt) -API_ENTRY(dyn_glutDialsFunc,ptr_glutDialsFunc,"glutDialsFunc",glutDialsFunc,FunPtr DialsFunc -> IO ()) -API_ENTRY(dyn_glutDisplayFunc,ptr_glutDisplayFunc,"glutDisplayFunc",glutDisplayFunc,FunPtr DisplayFunc -> IO ()) -API_ENTRY(dyn_glutEnterGameMode,ptr_glutEnterGameMode,"glutEnterGameMode",glutEnterGameMode,IO CInt) -API_ENTRY(dyn_glutEntryFunc,ptr_glutEntryFunc,"glutEntryFunc",glutEntryFunc,FunPtr EntryFunc -> IO ()) -API_ENTRY_SAFE(dyn_glutEstablishOverlay,ptr_glutEstablishOverlay,"glutEstablishOverlay",glutEstablishOverlay,IO ()) -API_ENTRY(dyn_glutExit,ptr_glutExit,"glutExit",glutExit,IO ()) -API_ENTRY(dyn_glutExtensionSupported,ptr_glutExtensionSupported,"glutExtensionSupported",glutExtensionSupported,Ptr CChar -> IO CInt) -API_ENTRY(dyn_glutForceJoystickFunc,ptr_glutForceJoystickFunc,"glutForceJoystickFunc",glutForceJoystickFunc,IO ()) -API_ENTRY(dyn_glutFullScreen,ptr_glutFullScreen,"glutFullScreen",glutFullScreen,IO ()) -API_ENTRY(dyn_glutFullScreenToggle,ptr_glutFullScreenToggle,"glutFullScreenToggle",glutFullScreenToggle,IO ()) -API_ENTRY(dyn_glutGameModeGet,ptr_glutGameModeGet,"glutGameModeGet",glutGameModeGet,GLenum -> IO CInt) -API_ENTRY(dyn_glutGameModeString,ptr_glutGameModeString,"glutGameModeString",glutGameModeString,Ptr CChar -> IO ()) -API_ENTRY(dyn_glutGet,ptr_glutGet,"glutGet",glutGet,GLenum -> IO CInt) -API_ENTRY(dyn_glutGetColor,ptr_glutGetColor,"glutGetColor",glutGetColor,CInt -> CInt -> IO GLfloat) -API_ENTRY(dyn_glutGetMenu,ptr_glutGetMenu,"glutGetMenu",glutGetMenu,IO CInt) -API_ENTRY(dyn_glutGetMenuData,ptr_glutGetMenuData,"glutGetMenuData",glutGetMenuData,IO (Ptr a)) -API_ENTRY(dyn_glutGetModeValues,ptr_glutGetModeValues,"glutGetModeValues",glutGetModeValues,GLenum -> Ptr CInt -> IO (Ptr CInt)) -API_ENTRY(dyn_glutGetModifiers,ptr_glutGetModifiers,"glutGetModifiers",glutGetModifiers,IO CInt) -API_ENTRY(dyn_glutGetProcAddress,ptr_glutGetProcAddress,"glutGetProcAddress",glutGetProcAddress,Ptr CChar -> IO (FunPtr a)) -API_ENTRY(dyn_glutGetWindow,ptr_glutGetWindow,"glutGetWindow",glutGetWindow,IO CInt) -API_ENTRY(dyn_glutGetWindowData,ptr_glutGetWindowData,"glutGetWindowData",glutGetWindowData,IO (Ptr a)) -API_ENTRY_SAFE(dyn_glutHideOverlay,ptr_glutHideOverlay,"glutHideOverlay",glutHideOverlay,IO ()) -API_ENTRY(dyn_glutHideWindow,ptr_glutHideWindow,"glutHideWindow",glutHideWindow,IO ()) -API_ENTRY(dyn_glutIconifyWindow,ptr_glutIconifyWindow,"glutIconifyWindow",glutIconifyWindow,IO ()) -API_ENTRY(dyn_glutIdleFunc,ptr_glutIdleFunc,"glutIdleFunc",glutIdleFunc,FunPtr IdleFunc -> IO ()) -API_ENTRY(dyn_glutIgnoreKeyRepeat,ptr_glutIgnoreKeyRepeat,"glutIgnoreKeyRepeat",glutIgnoreKeyRepeat,CInt -> IO ()) -API_ENTRY(dyn_glutInit,ptr_glutInit,"glutInit",glutInit,Ptr CInt -> Ptr (Ptr CChar) -> IO ()) -API_ENTRY(dyn_glutInitContextFlags,ptr_glutInitContextFlags,"glutInitContextFlags",glutInitContextFlags,CInt -> IO ()) -API_ENTRY(dyn_glutInitContextFunc,ptr_glutInitContextFunc,"glutInitContextFunc",glutInitContextFunc,FunPtr InitContextFunc -> IO ()) -API_ENTRY(dyn_glutInitContextProfile,ptr_glutInitContextProfile,"glutInitContextProfile",glutInitContextProfile,CInt -> IO ()) -API_ENTRY(dyn_glutInitContextVersion,ptr_glutInitContextVersion,"glutInitContextVersion",glutInitContextVersion,CInt -> CInt -> IO ()) -API_ENTRY(dyn_glutInitDisplayMode,ptr_glutInitDisplayMode,"glutInitDisplayMode",glutInitDisplayMode,CUInt -> IO ()) -API_ENTRY(dyn_glutInitDisplayString,ptr_glutInitDisplayString,"glutInitDisplayString",glutInitDisplayString,Ptr CChar -> IO ()) -API_ENTRY(dyn_glutInitWindowPosition,ptr_glutInitWindowPosition,"glutInitWindowPosition",glutInitWindowPosition,CInt -> CInt -> IO ()) -API_ENTRY(dyn_glutInitWindowSize,ptr_glutInitWindowSize,"glutInitWindowSize",glutInitWindowSize,CInt -> CInt -> IO ()) -API_ENTRY(dyn_glutJoystickFunc,ptr_glutJoystickFunc,"glutJoystickFunc",glutJoystickFunc,FunPtr JoystickFunc -> CInt -> IO ()) -API_ENTRY(dyn_glutKeyboardFunc,ptr_glutKeyboardFunc,"glutKeyboardFunc",glutKeyboardFunc,FunPtr KeyboardFunc -> IO ()) -API_ENTRY(dyn_glutKeyboardUpFunc,ptr_glutKeyboardUpFunc,"glutKeyboardUpFunc",glutKeyboardUpFunc,FunPtr KeyboardUpFunc -> IO ()) -API_ENTRY(dyn_glutLayerGet,ptr_glutLayerGet,"glutLayerGet",glutLayerGet,GLenum -> IO CInt) -API_ENTRY(dyn_glutLeaveFullScreen,ptr_glutLeaveFullScreen,"glutLeaveFullScreen",glutLeaveFullScreen,IO ()) -API_ENTRY(dyn_glutLeaveGameMode,ptr_glutLeaveGameMode,"glutLeaveGameMode",glutLeaveGameMode,IO ()) -API_ENTRY_SAFE(dyn_glutLeaveMainLoop,ptr_glutLeaveMainLoop,"glutLeaveMainLoop",glutLeaveMainLoop,IO ()) -API_ENTRY_SAFE(dyn_glutMainLoop,ptr_glutMainLoop,"glutMainLoop",glutMainLoop,IO ()) -API_ENTRY_SAFE(dyn_glutMainLoopEvent,ptr_glutMainLoopEvent,"glutMainLoopEvent",glutMainLoopEvent,IO ()) -API_ENTRY(dyn_glutMenuDestroyFunc,ptr_glutMenuDestroyFunc,"glutMenuDestroyFunc",glutMenuDestroyFunc,FunPtr MenuDestroyFunc -> IO ()) -API_ENTRY(dyn_glutMenuStateFunc,ptr_glutMenuStateFunc,"glutMenuStateFunc",glutMenuStateFunc,FunPtr MenuStateFunc -> IO ()) -API_ENTRY(dyn_glutMenuStatusFunc,ptr_glutMenuStatusFunc,"glutMenuStatusFunc",glutMenuStatusFunc,FunPtr MenuStatusFunc -> IO ()) -API_ENTRY(dyn_glutMotionFunc,ptr_glutMotionFunc,"glutMotionFunc",glutMotionFunc,FunPtr MotionFunc -> IO ()) -API_ENTRY(dyn_glutMouseFunc,ptr_glutMouseFunc,"glutMouseFunc",glutMouseFunc,FunPtr MouseFunc -> IO ()) -API_ENTRY(dyn_glutMouseWheelFunc,ptr_glutMouseWheelFunc,"glutMouseWheelFunc",glutMouseWheelFunc,FunPtr MouseWheelFunc -> IO ()) -API_ENTRY(dyn_glutMultiButtonFunc,ptr_glutMultiButtonFunc,"glutMultiButtonFunc",glutMultiButtonFunc,FunPtr MultiButtonFunc -> IO ()) -API_ENTRY(dyn_glutMultiEntryFunc,ptr_glutMultiEntryFunc,"glutMultiEntryFunc",glutMultiEntryFunc,FunPtr MultiEntryFunc -> IO ()) -API_ENTRY(dyn_glutMultiMotionFunc,ptr_glutMultiMotionFunc,"glutMultiMotionFunc",glutMultiMotionFunc,FunPtr MultiMotionFunc -> IO ()) -API_ENTRY(dyn_glutMultiPassiveFunc,ptr_glutMultiPassiveFunc,"glutMultiPassiveFunc",glutMultiPassiveFunc,FunPtr MultiPassiveFunc -> IO ()) -API_ENTRY(dyn_glutOverlayDisplayFunc,ptr_glutOverlayDisplayFunc,"glutOverlayDisplayFunc",glutOverlayDisplayFunc,FunPtr OverlayDisplayFunc -> IO ()) -API_ENTRY(dyn_glutPassiveMotionFunc,ptr_glutPassiveMotionFunc,"glutPassiveMotionFunc",glutPassiveMotionFunc,FunPtr PassiveMotionFunc -> IO ()) -API_ENTRY(dyn_glutPopWindow,ptr_glutPopWindow,"glutPopWindow",glutPopWindow,IO ()) -API_ENTRY(dyn_glutPositionFunc,ptr_glutPositionFunc,"glutPositionFunc",glutPositionFunc,FunPtr PositionFunc -> IO ()) -API_ENTRY(dyn_glutPositionWindow,ptr_glutPositionWindow,"glutPositionWindow",glutPositionWindow,CInt -> CInt -> IO ()) -API_ENTRY_SAFE(dyn_glutPostOverlayRedisplay,ptr_glutPostOverlayRedisplay,"glutPostOverlayRedisplay",glutPostOverlayRedisplay,IO ()) -API_ENTRY(dyn_glutPostRedisplay,ptr_glutPostRedisplay,"glutPostRedisplay",glutPostRedisplay,IO ()) -API_ENTRY_SAFE(dyn_glutPostWindowOverlayRedisplay,ptr_glutPostWindowOverlayRedisplay,"glutPostWindowOverlayRedisplay",glutPostWindowOverlayRedisplay,CInt -> IO ()) -API_ENTRY(dyn_glutPostWindowRedisplay,ptr_glutPostWindowRedisplay,"glutPostWindowRedisplay",glutPostWindowRedisplay,CInt -> IO ()) -API_ENTRY(dyn_glutPushWindow,ptr_glutPushWindow,"glutPushWindow",glutPushWindow,IO ()) -API_ENTRY(dyn_glutRemoveMenuItem,ptr_glutRemoveMenuItem,"glutRemoveMenuItem",glutRemoveMenuItem,CInt -> IO ()) -API_ENTRY_SAFE(dyn_glutRemoveOverlay,ptr_glutRemoveOverlay,"glutRemoveOverlay",glutRemoveOverlay,IO ()) -API_ENTRY(dyn_glutReportErrors,ptr_glutReportErrors,"glutReportErrors",glutReportErrors,IO ()) -API_ENTRY(dyn_glutReshapeFunc,ptr_glutReshapeFunc,"glutReshapeFunc",glutReshapeFunc,FunPtr ReshapeFunc -> IO ()) -API_ENTRY(dyn_glutReshapeWindow,ptr_glutReshapeWindow,"glutReshapeWindow",glutReshapeWindow,CInt -> CInt -> IO ()) -API_ENTRY(dyn_glutSetColor,ptr_glutSetColor,"glutSetColor",glutSetColor,CInt -> GLfloat -> GLfloat -> GLfloat -> IO ()) -API_ENTRY(dyn_glutSetCursor,ptr_glutSetCursor,"glutSetCursor",glutSetCursor,CInt -> IO ()) -API_ENTRY(dyn_glutSetIconTitle,ptr_glutSetIconTitle,"glutSetIconTitle",glutSetIconTitle,Ptr CChar -> IO ()) -API_ENTRY(dyn_glutSetKeyRepeat,ptr_glutSetKeyRepeat,"glutSetKeyRepeat",glutSetKeyRepeat,CInt -> IO ()) -API_ENTRY(dyn_glutSetMenu,ptr_glutSetMenu,"glutSetMenu",glutSetMenu,CInt -> IO ()) -API_ENTRY(dyn_glutSetMenuData,ptr_glutSetMenuData,"glutSetMenuData",glutSetMenuData,Ptr a -> IO ()) -API_ENTRY(dyn_glutSetMenuFont,ptr_glutSetMenuFont,"glutSetMenuFont",glutSetMenuFont,GLint -> Ptr a -> IO ()) -API_ENTRY(dyn_glutSetOption,ptr_glutSetOption,"glutSetOption",glutSetOption,GLenum -> CInt -> IO ()) -API_ENTRY(dyn_glutSetVertexAttribCoord3,ptr_glutSetVertexAttribCoord3,"glutSetVertexAttribCoord3",glutSetVertexAttribCoord3,GLint -> IO ()) -API_ENTRY(dyn_glutSetVertexAttribNormal,ptr_glutSetVertexAttribNormal,"glutSetVertexAttribNormal",glutSetVertexAttribNormal,GLint -> IO ()) -API_ENTRY(dyn_glutSetVertexAttribTexCoord2,ptr_glutSetVertexAttribTexCoord2,"glutSetVertexAttribTexCoord2",glutSetVertexAttribTexCoord2,GLint -> IO ()) -API_ENTRY(dyn_glutSetWindow,ptr_glutSetWindow,"glutSetWindow",glutSetWindow,CInt -> IO ()) -API_ENTRY(dyn_glutSetWindowData,ptr_glutSetWindowData,"glutSetWindowData",glutSetWindowData,Ptr a -> IO ()) -API_ENTRY(dyn_glutSetWindowTitle,ptr_glutSetWindowTitle,"glutSetWindowTitle",glutSetWindowTitle,Ptr CChar -> IO ()) -API_ENTRY(dyn_glutSetupVideoResizing,ptr_glutSetupVideoResizing,"glutSetupVideoResizing",glutSetupVideoResizing,IO ()) -API_ENTRY_SAFE(dyn_glutShowOverlay,ptr_glutShowOverlay,"glutShowOverlay",glutShowOverlay,IO ()) -API_ENTRY(dyn_glutShowWindow,ptr_glutShowWindow,"glutShowWindow",glutShowWindow,IO ()) -API_ENTRY(dyn_glutSolidCone,ptr_glutSolidCone,"glutSolidCone",glutSolidCone,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(dyn_glutSolidCube,ptr_glutSolidCube,"glutSolidCube",glutSolidCube,GLdouble -> IO ()) -API_ENTRY(dyn_glutSolidCylinder,ptr_glutSolidCylinder,"glutSolidCylinder",glutSolidCylinder,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(dyn_glutSolidDodecahedron,ptr_glutSolidDodecahedron,"glutSolidDodecahedron",glutSolidDodecahedron,IO ()) -API_ENTRY(dyn_glutSolidIcosahedron,ptr_glutSolidIcosahedron,"glutSolidIcosahedron",glutSolidIcosahedron,IO ()) -API_ENTRY(dyn_glutSolidOctahedron,ptr_glutSolidOctahedron,"glutSolidOctahedron",glutSolidOctahedron,IO ()) -API_ENTRY(dyn_glutSolidRhombicDodecahedron,ptr_glutSolidRhombicDodecahedron,"glutSolidRhombicDodecahedron",glutSolidRhombicDodecahedron,IO ()) -API_ENTRY(dyn_glutSolidSierpinskiSponge,ptr_glutSolidSierpinskiSponge,"glutSolidSierpinskiSponge",glutSolidSierpinskiSponge,CInt -> Ptr GLdouble -> GLdouble -> IO ()) -API_ENTRY(dyn_glutSolidSphere,ptr_glutSolidSphere,"glutSolidSphere",glutSolidSphere,GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(dyn_glutSolidTeacup,ptr_glutSolidTeacup,"glutSolidTeacup",glutSolidTeacup,GLdouble -> IO ()) -API_ENTRY(dyn_glutSolidTeapot,ptr_glutSolidTeapot,"glutSolidTeapot",glutSolidTeapot,GLdouble -> IO ()) -API_ENTRY(dyn_glutSolidTeaspoon,ptr_glutSolidTeaspoon,"glutSolidTeaspoon",glutSolidTeaspoon,GLdouble -> IO ()) -API_ENTRY(dyn_glutSolidTetrahedron,ptr_glutSolidTetrahedron,"glutSolidTetrahedron",glutSolidTetrahedron,IO ()) -API_ENTRY(dyn_glutSolidTorus,ptr_glutSolidTorus,"glutSolidTorus",glutSolidTorus,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(dyn_glutSpaceballButtonFunc,ptr_glutSpaceballButtonFunc,"glutSpaceballButtonFunc",glutSpaceballButtonFunc,FunPtr SpaceballButtonFunc -> IO ()) -API_ENTRY(dyn_glutSpaceballMotionFunc,ptr_glutSpaceballMotionFunc,"glutSpaceballMotionFunc",glutSpaceballMotionFunc,FunPtr SpaceballMotionFunc -> IO ()) -API_ENTRY(dyn_glutSpaceballRotateFunc,ptr_glutSpaceballRotateFunc,"glutSpaceballRotateFunc",glutSpaceballRotateFunc,FunPtr SpaceballRotateFunc -> IO ()) -API_ENTRY(dyn_glutSpecialFunc,ptr_glutSpecialFunc,"glutSpecialFunc",glutSpecialFunc,FunPtr SpecialFunc -> IO ()) -API_ENTRY(dyn_glutSpecialUpFunc,ptr_glutSpecialUpFunc,"glutSpecialUpFunc",glutSpecialUpFunc,FunPtr SpecialUpFunc -> IO ()) -API_ENTRY(dyn_glutStopVideoResizing,ptr_glutStopVideoResizing,"glutStopVideoResizing",glutStopVideoResizing,IO ()) -API_ENTRY(dyn_glutStrokeCharacter,ptr_glutStrokeCharacter,"glutStrokeCharacter",glutStrokeCharacter,Ptr a -> CInt -> IO ()) -API_ENTRY(dyn_glutStrokeHeight,ptr_glutStrokeHeight,"glutStrokeHeight",glutStrokeHeight,Ptr a -> IO GLfloat) -API_ENTRY(dyn_glutStrokeLength,ptr_glutStrokeLength,"glutStrokeLength",glutStrokeLength,Ptr a -> Ptr CUChar -> IO CInt) -API_ENTRY(dyn_glutStrokeString,ptr_glutStrokeString,"glutStrokeString",glutStrokeString,Ptr a -> Ptr CUChar -> IO ()) -API_ENTRY(dyn_glutStrokeWidth,ptr_glutStrokeWidth,"glutStrokeWidth",glutStrokeWidth,Ptr a -> CInt -> IO CInt) -API_ENTRY(dyn_glutSwapBuffers,ptr_glutSwapBuffers,"glutSwapBuffers",glutSwapBuffers,IO ()) -API_ENTRY(dyn_glutTabletButtonFunc,ptr_glutTabletButtonFunc,"glutTabletButtonFunc",glutTabletButtonFunc,FunPtr TabletButtonFunc -> IO ()) -API_ENTRY(dyn_glutTabletMotionFunc,ptr_glutTabletMotionFunc,"glutTabletMotionFunc",glutTabletMotionFunc,FunPtr TabletMotionFunc -> IO ()) -API_ENTRY(dyn_glutTimerFunc,ptr_glutTimerFunc,"glutTimerFunc",glutTimerFunc,CUInt -> FunPtr TimerFunc -> CInt -> IO ()) -API_ENTRY_SAFE(dyn_glutUseLayer,ptr_glutUseLayer,"glutUseLayer",glutUseLayer,GLenum -> IO ()) -API_ENTRY(dyn_glutVideoPan,ptr_glutVideoPan,"glutVideoPan",glutVideoPan,CInt -> CInt -> CInt -> CInt -> IO ()) -API_ENTRY(dyn_glutVideoResize,ptr_glutVideoResize,"glutVideoResize",glutVideoResize,CInt -> CInt -> CInt -> CInt -> IO ()) -API_ENTRY(dyn_glutVideoResizeGet,ptr_glutVideoResizeGet,"glutVideoResizeGet",glutVideoResizeGet,GLenum -> IO CInt) -API_ENTRY(dyn_glutVisibilityFunc,ptr_glutVisibilityFunc,"glutVisibilityFunc",glutVisibilityFunc,FunPtr VisibilityFunc -> IO ()) -API_ENTRY(dyn_glutWMCloseFunc,ptr_glutWMCloseFunc,"glutWMCloseFunc",glutWMCloseFunc,FunPtr WMCloseFunc -> IO ()) -API_ENTRY(dyn_glutWarpPointer,ptr_glutWarpPointer,"glutWarpPointer",glutWarpPointer,CInt -> CInt -> IO ()) -API_ENTRY(dyn_glutWindowStatusFunc,ptr_glutWindowStatusFunc,"glutWindowStatusFunc",glutWindowStatusFunc,FunPtr WindowStatusFunc -> IO ()) -API_ENTRY(dyn_glutWireCone,ptr_glutWireCone,"glutWireCone",glutWireCone,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(dyn_glutWireCube,ptr_glutWireCube,"glutWireCube",glutWireCube,GLdouble -> IO ()) -API_ENTRY(dyn_glutWireCylinder,ptr_glutWireCylinder,"glutWireCylinder",glutWireCylinder,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(dyn_glutWireDodecahedron,ptr_glutWireDodecahedron,"glutWireDodecahedron",glutWireDodecahedron,IO ()) -API_ENTRY(dyn_glutWireIcosahedron,ptr_glutWireIcosahedron,"glutWireIcosahedron",glutWireIcosahedron,IO ()) -API_ENTRY(dyn_glutWireOctahedron,ptr_glutWireOctahedron,"glutWireOctahedron",glutWireOctahedron,IO ()) -API_ENTRY(dyn_glutWireRhombicDodecahedron,ptr_glutWireRhombicDodecahedron,"glutWireRhombicDodecahedron",glutWireRhombicDodecahedron,IO ()) -API_ENTRY(dyn_glutWireSierpinskiSponge,ptr_glutWireSierpinskiSponge,"glutWireSierpinskiSponge",glutWireSierpinskiSponge,CInt -> Ptr GLdouble -> GLdouble -> IO ()) -API_ENTRY(dyn_glutWireSphere,ptr_glutWireSphere,"glutWireSphere",glutWireSphere,GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(dyn_glutWireTeacup,ptr_glutWireTeacup,"glutWireTeacup",glutWireTeacup,GLdouble -> IO ()) -API_ENTRY(dyn_glutWireTeapot,ptr_glutWireTeapot,"glutWireTeapot",glutWireTeapot,GLdouble -> IO ()) -API_ENTRY(dyn_glutWireTeaspoon,ptr_glutWireTeaspoon,"glutWireTeaspoon",glutWireTeaspoon,GLdouble -> IO ()) -API_ENTRY(dyn_glutWireTetrahedron,ptr_glutWireTetrahedron,"glutWireTetrahedron",glutWireTetrahedron,IO ()) -API_ENTRY(dyn_glutWireTorus,ptr_glutWireTorus,"glutWireTorus",glutWireTorus,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) diff --git a/Graphics/UI/GLUT/Raw/Tokens.hs b/Graphics/UI/GLUT/Raw/Tokens.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Raw/Tokens.hs +++ /dev/null @@ -1,643 +0,0 @@ -{-# 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_APPSTATUS_PAUSE :: CInt -glut_APPSTATUS_PAUSE = 0x0001 - -glut_APPSTATUS_RESUME :: CInt -glut_APPSTATUS_RESUME = 0x0002 - -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_GEOMETRY_VISUALIZE_NORMALS :: GLenum -glut_GEOMETRY_VISUALIZE_NORMALS = 0x0205 - -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_ALT_L :: CInt -glut_KEY_ALT_L = 0x0074 - -glut_KEY_ALT_R :: CInt -glut_KEY_ALT_R = 0x0075 - -glut_KEY_BEGIN :: CInt -glut_KEY_BEGIN = 0x006E - -glut_KEY_CTRL_L :: CInt -glut_KEY_CTRL_L = 0x0072 - -glut_KEY_CTRL_R :: CInt -glut_KEY_CTRL_R = 0x0073 - -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_SHIFT_L :: CInt -glut_KEY_SHIFT_L = 0x0070 - -glut_KEY_SHIFT_R :: CInt -glut_KEY_SHIFT_R = 0x0071 - -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_SKIP_STALE_MOTION_EVENTS :: GLenum -glut_SKIP_STALE_MOTION_EVENTS = 0x0204 - -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 deleted file mode 100644 --- a/Graphics/UI/GLUT/State.hs +++ /dev/null @@ -1,446 +0,0 @@ --------------------------------------------------------------------------------- --- | --- 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, skipStaleMotionEvents, - - -- * State of the /current window/ - - -- ** Framebuffer state - rgba, - BufferDepth, rgbaBufferDepths, colorBufferDepth, - doubleBuffered, stereo, - accumBufferDepths, depthBufferDepth, stencilBufferDepth, - SampleCount, sampleCount, formatID, - - -- ** Full screen state - fullScreenMode, - - -- ** Object rendering state - geometryVisualizeNormals, - - -- ** Vertex attribute state - vertexAttribCoord3, vertexAttribNormal, vertexAttribTexCoord2, - - -- ** Layer state - 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 -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 - --------------------------------------------------------------------------------- - --- | (/freeglut only/) Controls if vectors representing the normals should be --- drawn, too, when objects are drawn. - -geometryVisualizeNormals :: StateVar Bool -geometryVisualizeNormals = - makeStateVar - (simpleGet i2b glut_GEOMETRY_VISUALIZE_NORMALS) - (glutSetOption glut_GEOMETRY_VISUALIZE_NORMALS . b2i) - - --------------------------------------------------------------------------------- - --- | (/freeglut only/) If 'vertexAttribCoord3' and 'vertexAttribNormal' both --- contain 'Nothing', the fixed function pipeline is used to draw --- objects. Otherwise VBOs are used and the coordinates are passed via 'Just' --- this attribute location (for a vec3). - -vertexAttribCoord3 :: SettableStateVar (Maybe AttribLocation) -vertexAttribCoord3 = setVertexAttribWith glutSetVertexAttribCoord3 - -setVertexAttribWith :: (GLint -> IO ()) -> SettableStateVar (Maybe AttribLocation) -setVertexAttribWith f = makeSettableStateVar $ f . getLocation - where getLocation = maybe (-1) (\(AttribLocation l) -> fromIntegral l) - --- | (/freeglut only/) If 'vertexAttribCoord3' and 'vertexAttribNormal' both --- contain 'Nothing', the fixed function pipeline is used to draw --- objects. Otherwise VBOs are used and the normals are passed via 'Just' this --- attribute location (for a vec3). - -vertexAttribNormal :: SettableStateVar (Maybe AttribLocation) -vertexAttribNormal = setVertexAttribWith glutSetVertexAttribNormal - --- | (/freeglut only/) If VBOs are used to draw objects (controlled via --- 'vertexAttribCoord3' and 'vertexAttribNormal'), the texture coordinates are --- passed via 'Just' this attribute location (for a vec2). - -vertexAttribTexCoord2 :: SettableStateVar (Maybe AttribLocation) -vertexAttribTexCoord2 = setVertexAttribWith glutSetVertexAttribTexCoord2 - --------------------------------------------------------------------------------- - --- | 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 (un-)marshalers - -i2b :: CInt -> Bool -i2b = (/= 0) - -b2i :: Bool -> CInt -b2i False = 0 -b2i True = 1 - --------------------------------------------------------------------------------- - -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 on X11 only/) Controls if all but the last motion event should --- be discarded. - -skipStaleMotionEvents :: StateVar Bool -skipStaleMotionEvents = - makeStateVar - (simpleGet i2b glut_SKIP_STALE_MOTION_EVENTS) - (glutSetOption glut_SKIP_STALE_MOTION_EVENTS . b2i) - ------------------------------------------------------------------------------ - --- | (/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 deleted file mode 100644 --- a/Graphics/UI/GLUT/Types.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Graphics/UI/GLUT/Window.hs +++ /dev/null @@ -1,502 +0,0 @@ --------------------------------------------------------------------------------- --- | --- 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, leaveFullScreen, - - -- * 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 - --------------------------------------------------------------------------------- - --- | (/freeglut only/) If we are in full screen mode, resize the current window --- back to its original size. - -leaveFullScreen :: IO () -leaveFullScreen = glutLeaveFullScreen - --------------------------------------------------------------------------------- - --- $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) +[![Hackage](https://img.shields.io/hackage/v/GLUT.svg)](https://hackage.haskell.org/package/GLUT) [![Build Status](https://travis-ci.org/haskell-opengl/GLUT.png)](https://travis-ci.org/haskell-opengl/GLUT) 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 @@ -252,7 +252,7 @@ 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) diff --git a/examples/Misc/ColorTriangle/color_triangles.frac b/examples/Misc/ColorTriangle/color_triangles.frac --- a/examples/Misc/ColorTriangle/color_triangles.frac +++ b/examples/Misc/ColorTriangle/color_triangles.frac @@ -1,6 +1,6 @@ #version 430 core -in vec4 color; +in vec4 color; out vec4 fColor; void 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 @@ -8,7 +8,7 @@ import Prelude hiding ( sum ) import Control.Applicative import Control.Exception ( IOException, catch ) -import Control.Monad +import Control.Monad ( when, unless ) import qualified Data.ByteString as B import Data.Foldable ( Foldable, sum ) import Data.IORef diff --git a/examples/RedBook4/AccPersp.hs b/examples/RedBook4/AccPersp.hs --- a/examples/RedBook4/AccPersp.hs +++ b/examples/RedBook4/AccPersp.hs @@ -40,13 +40,13 @@ 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 diff --git a/examples/RedBook4/DOF.hs b/examples/RedBook4/DOF.hs --- a/examples/RedBook4/DOF.hs +++ b/examples/RedBook4/DOF.hs @@ -42,13 +42,13 @@ 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 diff --git a/src/Graphics/UI/GLUT.hs b/src/Graphics/UI/GLUT.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT.hs @@ -0,0 +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. diff --git a/src/Graphics/UI/GLUT/Begin.hs b/src/Graphics/UI/GLUT/Begin.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Begin.hs @@ -0,0 +1,98 @@ +-------------------------------------------------------------------------------- +-- | +-- 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 + deriving ( Eq, Ord, Show ) + +marshalActionOnWindowClose :: ActionOnWindowClose -> CInt +marshalActionOnWindowClose x = case x of + Exit -> glut_ACTION_EXIT + MainLoopReturns -> glut_ACTION_GLUTMAINLOOP_RETURNS + ContinueExecution -> 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/src/Graphics/UI/GLUT/Callbacks.hs b/src/Graphics/UI/GLUT/Callbacks.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Callbacks.hs @@ -0,0 +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 diff --git a/src/Graphics/UI/GLUT/Callbacks/Global.hs b/src/Graphics/UI/GLUT/Callbacks/Global.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Callbacks/Global.hs @@ -0,0 +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 diff --git a/src/Graphics/UI/GLUT/Callbacks/Registration.hs b/src/Graphics/UI/GLUT/Callbacks/Registration.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Callbacks/Registration.hs @@ -0,0 +1,162 @@ +{-# 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 + -- freeglut-only callback types + | CloseCB | MouseWheelCB | PositionCB + | MultiEntryCB | MultiMotionCB | MultiButtonCB + | MultiPassiveCB | InitContextCB | AppStatusCB + 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/src/Graphics/UI/GLUT/Callbacks/Window.hs b/src/Graphics/UI/GLUT/Callbacks/Window.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Callbacks/Window.hs @@ -0,0 +1,991 @@ +-------------------------------------------------------------------------------- +-- | +-- 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, + + -- * Position callback + PositionCallback, positionCallback, + + -- * Callbacks for visibility changes + Visibility(..), VisibilityCallback, visibilityCallback, + WindowState(..), WindowStateCallback, windowStateCallback, + + -- * Window close callback + CloseCallback, closeCallback, + + -- * Life cycle callbacks for mobile platforms + InitContextCallback, initContextCallback, + AppStatus(..), AppStatusCallback, appStatusCallback, + + -- * 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, + + -- * Multi-touch support + TouchID, + MultiMouseCallback, multiMouseCallback, + MultiCrossingCallback, multiCrossingCallback, + MultiMotionCallback, multiMotionCallback, multiPassiveMotionCallback + +) where + +import Data.Bits hiding ( shift ) +import Data.Char +import Data.Maybe +import Foreign.C.Types +import Graphics.Rendering.OpenGL +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)) + +-------------------------------------------------------------------------------- + +-- | A position callback + +type PositionCallback = Position -> IO () + +-- | (/freeglut only/) Controls the position callback for the /current window./ +-- The position callback for a window is called when the position of a window +-- changes. + +positionCallback :: SettableStateVar (Maybe PositionCallback) +positionCallback = makeSettableStateVar $ + setCallback PositionCB glutPositionFunc (makePositionFunc . unmarshal) + where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y)) + +-------------------------------------------------------------------------------- + +-- | 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 + +-------------------------------------------------------------------------------- + +-- | A window close callback + +type CloseCallback = IO () + +-- | Controls the window close callback for the /current window/. + +closeCallback :: SettableStateVar (Maybe CloseCallback) +closeCallback = makeSettableStateVar $ + setCallback CloseCB glutCloseFunc makeCloseFunc + +-------------------------------------------------------------------------------- + +-- | An initialize context callback + +type InitContextCallback = IO () + +-- | (/freeglut only/) Controls the initialize context callback for the /current +-- window/. + +initContextCallback :: SettableStateVar (Maybe InitContextCallback) +initContextCallback = makeSettableStateVar $ + setCallback InitContextCB glutInitContextFunc makeInitContextFunc + +-------------------------------------------------------------------------------- + +-- | The application status of the /current window/ + +data AppStatus + = AppStatusPause + | AppStatusResume + deriving ( Eq, Ord, Show ) + +unmarshalAppStatus :: CInt -> AppStatus +unmarshalAppStatus x + | x == glut_APPSTATUS_PAUSE = AppStatusPause + | x == glut_APPSTATUS_RESUME = AppStatusResume + | otherwise = error ("unmarshalAppStatus: illegal value " ++ show x) + +-------------------------------------------------------------------------------- + +-- | An application status callback + +type AppStatusCallback = AppStatus -> IO () + +-- | Controls the application status callback for the /current window./ + +appStatusCallback :: SettableStateVar (Maybe AppStatusCallback) +appStatusCallback = makeSettableStateVar $ + setCallback AppStatusCB glutAppStatusFunc + (makeAppStatusFunc . unmarshal) + where unmarshal cb = cb . unmarshalAppStatus + +-------------------------------------------------------------------------------- + +-- | 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 + | KeyShiftL + | KeyShiftR + | KeyCtrlL + | KeyCtrlR + | KeyAltL + | KeyAltR + | KeyUnknown Int -- ^ You should actually never encounter this value, it is + -- just here as a safeguard against future changes in the + -- native GLUT library. + 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 + | x == glut_KEY_SHIFT_L = KeyShiftL + | x == glut_KEY_SHIFT_R = KeyShiftR + | x == glut_KEY_CTRL_L = KeyCtrlL + | x == glut_KEY_CTRL_R = KeyCtrlR + | x == glut_KEY_ALT_L = KeyAltL + | x == glut_KEY_ALT_R = KeyAltR + | 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)) + +-------------------------------------------------------------------------------- + +-- | A description where the multi-touch event is coming from, the freeglut +-- specs are very vague about the actual semantics. It contains the device ID +-- and\/or the cursor\/finger ID. + +type TouchID = Int + +-- | A multi-touch variant of 'MouseCallback'. + +type MultiMouseCallback = TouchID -> MouseCallback + +-- | (/freeglut only/) A multi-touch variant of 'mouseCallback'. + +multiMouseCallback :: SettableStateVar (Maybe MultiMouseCallback) +multiMouseCallback = makeSettableStateVar $ + setCallback MultiButtonCB glutMultiButtonFunc (makeMultiButtonFunc . unmarshal) + where unmarshal cb d x y b s = cb (fromIntegral d) + (unmarshalMouseButton b) + (unmarshalKeyState s) + (Position (fromIntegral x) (fromIntegral y)) + +-- | A multi-touch variant of 'CrossingCallback'. + +type MultiCrossingCallback = TouchID -> CrossingCallback + +-- | (/freeglut only/) A multi-touch variant of 'crossingCallback'. + +multiCrossingCallback :: SettableStateVar (Maybe MultiCrossingCallback) +multiCrossingCallback = makeSettableStateVar $ + setCallback MultiEntryCB glutMultiEntryFunc (makeMultiEntryFunc . unmarshal) + where unmarshal cb d c = cb (fromIntegral d) (unmarshalCrossing c) + +-- | A multi-touch variant of 'MotionCallback'. + +type MultiMotionCallback = TouchID -> MotionCallback + +-- | (/freeglut only/) A multi-touch variant of 'motionCallback'. + +multiMotionCallback :: SettableStateVar (Maybe MultiMotionCallback) +multiMotionCallback = makeSettableStateVar $ + setCallback MultiMotionCB glutMultiMotionFunc (makeMultiMotionFunc . unmarshal) + where unmarshal cb d x y = + cb (fromIntegral d) (Position (fromIntegral x) (fromIntegral y)) + +-- | (/freeglut only/) A multi-touch variant of 'passiveMotionCallback'. + +multiPassiveMotionCallback :: SettableStateVar (Maybe MultiMotionCallback) +multiPassiveMotionCallback = makeSettableStateVar $ + setCallback MultiPassiveCB glutMultiPassiveFunc (makeMultiPassiveFunc . unmarshal) + where unmarshal cb d x y = + cb (fromIntegral d) (Position (fromIntegral x) (fromIntegral y)) diff --git a/src/Graphics/UI/GLUT/Colormap.hs b/src/Graphics/UI/GLUT/Colormap.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Colormap.hs @@ -0,0 +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 diff --git a/src/Graphics/UI/GLUT/Debugging.hs b/src/Graphics/UI/GLUT/Debugging.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Debugging.hs @@ -0,0 +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) diff --git a/src/Graphics/UI/GLUT/DeviceControl.hs b/src/Graphics/UI/GLUT/DeviceControl.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/DeviceControl.hs @@ -0,0 +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 diff --git a/src/Graphics/UI/GLUT/Fonts.hs b/src/Graphics/UI/GLUT/Fonts.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Fonts.hs @@ -0,0 +1,120 @@ +-------------------------------------------------------------------------------- +-- | +-- 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 +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 + +-------------------------------------------------------------------------------- + +bitmapString :: BitmapFont -> String -> IO () +bitmapString f s = do + i <- marshalBitmapFont 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 <- marshalStrokeFont 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 <- marshalBitmapFont 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 <- marshalStrokeFont f + fmap fromIntegral $ withCString s (glutStrokeLength i . castPtr) + +-------------------------------------------------------------------------------- + +bitmapHeight :: BitmapFont -- ^ Bitmap font to use. + -> IO GLfloat -- ^ Height in pixels. +bitmapHeight f = fmap fromIntegral $ glutBitmapHeight =<< marshalBitmapFont f + +-------------------------------------------------------------------------------- + +strokeHeight :: StrokeFont -- ^ Stroke font to use. + -> IO GLfloat -- ^ Height in units. +strokeHeight f = glutStrokeHeight =<< marshalStrokeFont f diff --git a/src/Graphics/UI/GLUT/GameMode.hs b/src/Graphics/UI/GLUT/GameMode.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/GameMode.hs @@ -0,0 +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 diff --git a/src/Graphics/UI/GLUT/Initialization.hs b/src/Graphics/UI/GLUT/Initialization.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Initialization.hs @@ -0,0 +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 diff --git a/src/Graphics/UI/GLUT/Menu.hs b/src/Graphics/UI/GLUT/Menu.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Menu.hs @@ -0,0 +1,262 @@ +{-# 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 +import Control.Monad +import Data.Map ( Map ) +import Foreign.C.String +import Foreign.C.Types +import Foreign.Ptr +import Graphics.Rendering.OpenGL +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, possibly with an associated font. +data Menu + = Menu [MenuItem] + | MenuWithFont BitmapFont [MenuItem] + +menuFont :: Menu -> Maybe BitmapFont +menuFont (Menu _) = Nothing +menuFont (MenuWithFont font _) = Just font + +menuItems :: Menu -> [MenuItem] +menuItems (Menu items) = items +menuItems (MenuWithFont _ items) = items + +-- | 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 = do + win <- getCurrentWindow "attachMenu" + let hook = MenuHook win mouseButton + detachMenu hook + unless (null (menuItems menu)) $ 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 = do + let items = menuItems menu + callbackArray = listArray (1, length items) (map makeCallback items) + cb <- makeMenuFunc (\i -> callbackArray ! (fromIntegral i)) + menuID <- glutCreateMenu cb + maybe (return ()) (setMenuFont menuID) (menuFont menu) + 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 + +-------------------------------------------------------------------------------- + +setMenuFont :: MenuID -> BitmapFont -> IO () +setMenuFont menuID font = glutSetMenuFont menuID =<< marshalBitmapFont font diff --git a/src/Graphics/UI/GLUT/Objects.hs b/src/Graphics/UI/GLUT/Objects.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Objects.hs @@ -0,0 +1,180 @@ +-------------------------------------------------------------------------------- +-- | +-- 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 solid teapot, teacup +-- and teaspoon). If VBOs should be used instead of the fixed function pipeline, +-- specify at least one of the attribute locations +-- 'Graphics.UI.GLUT.State.vertexAttribCoord3' or +-- 'Graphics.UI.GLUT.State.vertexAttribNormal'. +-- +-------------------------------------------------------------------------------- + +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 +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 teaset modeled by Martin Newell in 1975. Both surface normals +-- and texture coordinates for the teaset are generated. +-- +-- * 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 teacup with a given relative size. + Teacup Height + | -- |(/freeglut only/) A teaspoon with a given relative size. + Teaspoon 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) = glutSolidCube h +renderObject Wireframe (Cube h) = glutWireCube h +renderObject Solid Dodecahedron = glutSolidDodecahedron +renderObject Wireframe Dodecahedron = glutWireDodecahedron +renderObject Solid Icosahedron = glutSolidIcosahedron +renderObject Wireframe Icosahedron = glutWireIcosahedron +renderObject Solid Octahedron = glutSolidOctahedron +renderObject Wireframe Octahedron = glutWireOctahedron +renderObject Solid Tetrahedron = glutSolidTetrahedron +renderObject Wireframe Tetrahedron = glutWireTetrahedron +renderObject Solid RhombicDodecahedron = glutSolidRhombicDodecahedron +renderObject Wireframe RhombicDodecahedron = glutWireRhombicDodecahedron +renderObject Solid (Sphere' r s t) = glutSolidSphere r s t +renderObject Wireframe (Sphere' r s t) = glutWireSphere r s t +renderObject Solid (Cone r h s t) = glutSolidCone r h s t +renderObject Wireframe (Cone r h s t) = glutWireCone 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) = glutSolidTorus i o s r +renderObject Wireframe (Torus i o s r) = glutWireTorus i o s r +renderObject Solid (Teapot h) = glutSolidTeapot h +renderObject Wireframe (Teapot h) = glutWireTeapot h +renderObject Solid (Teacup h) = glutSolidTeacup h +renderObject Wireframe (Teacup h) = glutWireTeacup h +renderObject Solid (Teaspoon h) = glutSolidTeaspoon h +renderObject Wireframe (Teaspoon h) = glutWireTeaspoon h +renderObject Solid (SierpinskiSponge n) = solidSierpinskiSponge n +renderObject Wireframe (SierpinskiSponge n) = wireSierpinskiSponge n + +-------------------------------------------------------------------------------- + +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/src/Graphics/UI/GLUT/Overlay.hs b/src/Graphics/UI/GLUT/Overlay.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Overlay.hs @@ -0,0 +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) diff --git a/src/Graphics/UI/GLUT/QueryUtils.hs b/src/Graphics/UI/GLUT/QueryUtils.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/QueryUtils.hs @@ -0,0 +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 diff --git a/src/Graphics/UI/GLUT/Raw.hs b/src/Graphics/UI/GLUT/Raw.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Raw.hs @@ -0,0 +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 diff --git a/src/Graphics/UI/GLUT/Raw/APIEntry.hs b/src/Graphics/UI/GLUT/Raw/APIEntry.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Raw/APIEntry.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE 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/src/Graphics/UI/GLUT/Raw/Callbacks.hs b/src/Graphics/UI/GLUT/Raw/Callbacks.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Raw/Callbacks.hs @@ -0,0 +1,242 @@ +{-# 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 ( + AppStatusFunc, makeAppStatusFunc, + ButtonBoxFunc, makeButtonBoxFunc, + CloseFunc, makeCloseFunc, + DialsFunc, makeDialsFunc, + DisplayFunc, makeDisplayFunc, + EntryFunc, makeEntryFunc, + IdleFunc, makeIdleFunc, + InitContextFunc, makeInitContextFunc, + JoystickFunc, makeJoystickFunc, + KeyboardFunc, makeKeyboardFunc, + KeyboardUpFunc, makeKeyboardUpFunc, + MenuDestroyFunc, makeMenuDestroyFunc, + MenuFunc, makeMenuFunc, + MenuStateFunc, makeMenuStateFunc, + MenuStatusFunc, makeMenuStatusFunc, + MotionFunc, makeMotionFunc, + MouseFunc, makeMouseFunc, + MouseWheelFunc, makeMouseWheelFunc, + MultiButtonFunc, makeMultiButtonFunc, + MultiEntryFunc, makeMultiEntryFunc, + MultiMotionFunc, makeMultiMotionFunc, + MultiPassiveFunc, makeMultiPassiveFunc, + OverlayDisplayFunc, makeOverlayDisplayFunc, + PassiveMotionFunc, makePassiveMotionFunc, + PositionFunc, makePositionFunc, + 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 AppStatusFunc = CInt -> IO () + +foreign import ccall "wrapper" + makeAppStatusFunc :: AppStatusFunc -> IO (FunPtr AppStatusFunc) + +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 InitContextFunc = IO () + +foreign import ccall "wrapper" + makeInitContextFunc :: InitContextFunc -> IO (FunPtr InitContextFunc) + +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 MenuFunc = CInt -> IO () + +foreign import ccall "wrapper" + makeMenuFunc :: MenuFunc -> IO (FunPtr MenuFunc) + +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 MultiButtonFunc = CInt -> CInt -> CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeMultiButtonFunc :: MultiButtonFunc -> IO (FunPtr MultiButtonFunc) + +type MultiEntryFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeMultiEntryFunc :: MultiEntryFunc -> IO (FunPtr MultiEntryFunc) + +type MultiMotionFunc = CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeMultiMotionFunc :: MultiMotionFunc -> IO (FunPtr MultiMotionFunc) + +type MultiPassiveFunc = CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeMultiPassiveFunc :: MultiPassiveFunc -> IO (FunPtr MultiPassiveFunc) + +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 PositionFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makePositionFunc :: PositionFunc -> IO (FunPtr PositionFunc) + +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/src/Graphics/UI/GLUT/Raw/Fonts.hs b/src/Graphics/UI/GLUT/Raw/Fonts.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Raw/Fonts.hs @@ -0,0 +1,92 @@ +{-# 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 ( + BitmapFont(..), GLUTbitmapFont, marshalBitmapFont, + StrokeFont(..), GLUTstrokeFont, marshalStrokeFont +) where + +import Foreign.C.Types +import Foreign.Ptr + +-------------------------------------------------------------------------------- + +-- | 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 () + +marshalBitmapFont :: BitmapFont -> IO GLUTbitmapFont +marshalBitmapFont 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 + + +foreign import ccall unsafe "hs_GLUT_marshalBitmapFont" + hs_GLUT_marshalBitmapFont :: CInt -> IO (Ptr a) + +-------------------------------------------------------------------------------- + +-- | 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 () + +marshalStrokeFont :: StrokeFont -> IO GLUTstrokeFont +marshalStrokeFont x = case x of + Roman -> hs_GLUT_marshalStrokeFont 0 + MonoRoman -> hs_GLUT_marshalStrokeFont 1 + +foreign import ccall unsafe "hs_GLUT_marshalStrokeFont" + hs_GLUT_marshalStrokeFont :: CInt -> IO (Ptr a) diff --git a/src/Graphics/UI/GLUT/Raw/Functions.hs b/src/Graphics/UI/GLUT/Raw/Functions.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Raw/Functions.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE 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 ( + glutAddMenuEntry, + glutAddSubMenu, + glutAppStatusFunc, + glutAttachMenu, + glutBitmapCharacter, + glutBitmapHeight, + glutBitmapLength, + glutBitmapString, + glutBitmapWidth, + glutButtonBoxFunc, + glutChangeToMenuEntry, + glutChangeToSubMenu, + glutCloseFunc, + glutCopyColormap, + glutCreateMenu, + glutCreateSubWindow, + glutCreateWindow, + glutDestroyMenu, + glutDestroyWindow, + glutDetachMenu, + glutDeviceGet, + glutDialsFunc, + glutDisplayFunc, + glutEnterGameMode, + glutEntryFunc, + glutEstablishOverlay, + glutExit, + glutExtensionSupported, + glutForceJoystickFunc, + glutFullScreen, + glutFullScreenToggle, + glutGameModeGet, + glutGameModeString, + glutGet, + glutGetColor, + glutGetMenu, + glutGetMenuData, + glutGetModeValues, + glutGetModifiers, + glutGetProcAddress, + glutGetWindow, + glutGetWindowData, + glutHideOverlay, + glutHideWindow, + glutIconifyWindow, + glutIdleFunc, + glutIgnoreKeyRepeat, + glutInit, + glutInitContextFlags, + glutInitContextFunc, + glutInitContextProfile, + glutInitContextVersion, + glutInitDisplayMode, + glutInitDisplayString, + glutInitWindowPosition, + glutInitWindowSize, + glutJoystickFunc, + glutKeyboardFunc, + glutKeyboardUpFunc, + glutLayerGet, + glutLeaveFullScreen, + glutLeaveGameMode, + glutLeaveMainLoop, + glutMainLoop, + glutMainLoopEvent, + glutMenuDestroyFunc, + glutMenuStateFunc, + glutMenuStatusFunc, + glutMotionFunc, + glutMouseFunc, + glutMouseWheelFunc, + glutMultiButtonFunc, + glutMultiEntryFunc, + glutMultiMotionFunc, + glutMultiPassiveFunc, + glutOverlayDisplayFunc, + glutPassiveMotionFunc, + glutPopWindow, + glutPositionFunc, + glutPositionWindow, + glutPostOverlayRedisplay, + glutPostRedisplay, + glutPostWindowOverlayRedisplay, + glutPostWindowRedisplay, + glutPushWindow, + glutRemoveMenuItem, + glutRemoveOverlay, + glutReportErrors, + glutReshapeFunc, + glutReshapeWindow, + glutSetColor, + glutSetCursor, + glutSetIconTitle, + glutSetKeyRepeat, + glutSetMenu, + glutSetMenuData, + glutSetMenuFont, + glutSetOption, + glutSetVertexAttribCoord3, + glutSetVertexAttribNormal, + glutSetVertexAttribTexCoord2, + glutSetWindow, + glutSetWindowData, + glutSetWindowTitle, + glutSetupVideoResizing, + glutShowOverlay, + glutShowWindow, + glutSolidCone, + glutSolidCube, + glutSolidCylinder, + glutSolidDodecahedron, + glutSolidIcosahedron, + glutSolidOctahedron, + glutSolidRhombicDodecahedron, + glutSolidSierpinskiSponge, + glutSolidSphere, + glutSolidTeacup, + glutSolidTeapot, + glutSolidTeaspoon, + glutSolidTetrahedron, + glutSolidTorus, + glutSpaceballButtonFunc, + glutSpaceballMotionFunc, + glutSpaceballRotateFunc, + glutSpecialFunc, + glutSpecialUpFunc, + glutStopVideoResizing, + glutStrokeCharacter, + glutStrokeHeight, + glutStrokeLength, + glutStrokeString, + glutStrokeWidth, + glutSwapBuffers, + glutTabletButtonFunc, + glutTabletMotionFunc, + glutTimerFunc, + glutUseLayer, + glutVideoPan, + glutVideoResize, + glutVideoResizeGet, + glutVisibilityFunc, + glutWMCloseFunc, + glutWarpPointer, + glutWindowStatusFunc, + glutWireCone, + glutWireCube, + glutWireCylinder, + glutWireDodecahedron, + glutWireIcosahedron, + glutWireOctahedron, + glutWireRhombicDodecahedron, + glutWireSierpinskiSponge, + glutWireSphere, + glutWireTeacup, + glutWireTeapot, + glutWireTeaspoon, + glutWireTetrahedron, + glutWireTorus +) 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(dyn_glutAddMenuEntry,ptr_glutAddMenuEntry,"glutAddMenuEntry",glutAddMenuEntry,Ptr CChar -> CInt -> IO ()) +API_ENTRY(dyn_glutAddSubMenu,ptr_glutAddSubMenu,"glutAddSubMenu",glutAddSubMenu,Ptr CChar -> CInt -> IO ()) +API_ENTRY(dyn_glutAppStatusFunc,ptr_glutAppStatusFunc,"glutAppStatusFunc",glutAppStatusFunc,FunPtr AppStatusFunc -> IO ()) +API_ENTRY(dyn_glutAttachMenu,ptr_glutAttachMenu,"glutAttachMenu",glutAttachMenu,CInt -> IO ()) +API_ENTRY(dyn_glutBitmapCharacter,ptr_glutBitmapCharacter,"glutBitmapCharacter",glutBitmapCharacter,Ptr a -> CInt -> IO ()) +API_ENTRY(dyn_glutBitmapHeight,ptr_glutBitmapHeight,"glutBitmapHeight",glutBitmapHeight,Ptr a -> IO CInt) +API_ENTRY(dyn_glutBitmapLength,ptr_glutBitmapLength,"glutBitmapLength",glutBitmapLength,Ptr a -> Ptr CUChar -> IO CInt) +API_ENTRY(dyn_glutBitmapString,ptr_glutBitmapString,"glutBitmapString",glutBitmapString,Ptr a -> Ptr CUChar -> IO ()) +API_ENTRY(dyn_glutBitmapWidth,ptr_glutBitmapWidth,"glutBitmapWidth",glutBitmapWidth,Ptr a -> CInt -> IO CInt) +API_ENTRY(dyn_glutButtonBoxFunc,ptr_glutButtonBoxFunc,"glutButtonBoxFunc",glutButtonBoxFunc,FunPtr ButtonBoxFunc -> IO ()) +API_ENTRY(dyn_glutChangeToMenuEntry,ptr_glutChangeToMenuEntry,"glutChangeToMenuEntry",glutChangeToMenuEntry,CInt -> Ptr CChar -> CInt -> IO ()) +API_ENTRY(dyn_glutChangeToSubMenu,ptr_glutChangeToSubMenu,"glutChangeToSubMenu",glutChangeToSubMenu,CInt -> Ptr CChar -> CInt -> IO ()) +API_ENTRY(dyn_glutCloseFunc,ptr_glutCloseFunc,"glutCloseFunc",glutCloseFunc,FunPtr CloseFunc -> IO ()) +API_ENTRY(dyn_glutCopyColormap,ptr_glutCopyColormap,"glutCopyColormap",glutCopyColormap,CInt -> IO ()) +API_ENTRY(dyn_glutCreateMenu,ptr_glutCreateMenu,"glutCreateMenu",glutCreateMenu,FunPtr MenuFunc -> IO CInt) +API_ENTRY(dyn_glutCreateSubWindow,ptr_glutCreateSubWindow,"glutCreateSubWindow",glutCreateSubWindow,CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt) +API_ENTRY(dyn_glutCreateWindow,ptr_glutCreateWindow,"glutCreateWindow",glutCreateWindow,Ptr CChar -> IO CInt) +API_ENTRY(dyn_glutDestroyMenu,ptr_glutDestroyMenu,"glutDestroyMenu",glutDestroyMenu,CInt -> IO ()) +API_ENTRY(dyn_glutDestroyWindow,ptr_glutDestroyWindow,"glutDestroyWindow",glutDestroyWindow,CInt -> IO ()) +API_ENTRY(dyn_glutDetachMenu,ptr_glutDetachMenu,"glutDetachMenu",glutDetachMenu,CInt -> IO ()) +API_ENTRY(dyn_glutDeviceGet,ptr_glutDeviceGet,"glutDeviceGet",glutDeviceGet,GLenum -> IO CInt) +API_ENTRY(dyn_glutDialsFunc,ptr_glutDialsFunc,"glutDialsFunc",glutDialsFunc,FunPtr DialsFunc -> IO ()) +API_ENTRY(dyn_glutDisplayFunc,ptr_glutDisplayFunc,"glutDisplayFunc",glutDisplayFunc,FunPtr DisplayFunc -> IO ()) +API_ENTRY(dyn_glutEnterGameMode,ptr_glutEnterGameMode,"glutEnterGameMode",glutEnterGameMode,IO CInt) +API_ENTRY(dyn_glutEntryFunc,ptr_glutEntryFunc,"glutEntryFunc",glutEntryFunc,FunPtr EntryFunc -> IO ()) +API_ENTRY_SAFE(dyn_glutEstablishOverlay,ptr_glutEstablishOverlay,"glutEstablishOverlay",glutEstablishOverlay,IO ()) +API_ENTRY(dyn_glutExit,ptr_glutExit,"glutExit",glutExit,IO ()) +API_ENTRY(dyn_glutExtensionSupported,ptr_glutExtensionSupported,"glutExtensionSupported",glutExtensionSupported,Ptr CChar -> IO CInt) +API_ENTRY(dyn_glutForceJoystickFunc,ptr_glutForceJoystickFunc,"glutForceJoystickFunc",glutForceJoystickFunc,IO ()) +API_ENTRY(dyn_glutFullScreen,ptr_glutFullScreen,"glutFullScreen",glutFullScreen,IO ()) +API_ENTRY(dyn_glutFullScreenToggle,ptr_glutFullScreenToggle,"glutFullScreenToggle",glutFullScreenToggle,IO ()) +API_ENTRY(dyn_glutGameModeGet,ptr_glutGameModeGet,"glutGameModeGet",glutGameModeGet,GLenum -> IO CInt) +API_ENTRY(dyn_glutGameModeString,ptr_glutGameModeString,"glutGameModeString",glutGameModeString,Ptr CChar -> IO ()) +API_ENTRY(dyn_glutGet,ptr_glutGet,"glutGet",glutGet,GLenum -> IO CInt) +API_ENTRY(dyn_glutGetColor,ptr_glutGetColor,"glutGetColor",glutGetColor,CInt -> CInt -> IO GLfloat) +API_ENTRY(dyn_glutGetMenu,ptr_glutGetMenu,"glutGetMenu",glutGetMenu,IO CInt) +API_ENTRY(dyn_glutGetMenuData,ptr_glutGetMenuData,"glutGetMenuData",glutGetMenuData,IO (Ptr a)) +API_ENTRY(dyn_glutGetModeValues,ptr_glutGetModeValues,"glutGetModeValues",glutGetModeValues,GLenum -> Ptr CInt -> IO (Ptr CInt)) +API_ENTRY(dyn_glutGetModifiers,ptr_glutGetModifiers,"glutGetModifiers",glutGetModifiers,IO CInt) +API_ENTRY(dyn_glutGetProcAddress,ptr_glutGetProcAddress,"glutGetProcAddress",glutGetProcAddress,Ptr CChar -> IO (FunPtr a)) +API_ENTRY(dyn_glutGetWindow,ptr_glutGetWindow,"glutGetWindow",glutGetWindow,IO CInt) +API_ENTRY(dyn_glutGetWindowData,ptr_glutGetWindowData,"glutGetWindowData",glutGetWindowData,IO (Ptr a)) +API_ENTRY_SAFE(dyn_glutHideOverlay,ptr_glutHideOverlay,"glutHideOverlay",glutHideOverlay,IO ()) +API_ENTRY(dyn_glutHideWindow,ptr_glutHideWindow,"glutHideWindow",glutHideWindow,IO ()) +API_ENTRY(dyn_glutIconifyWindow,ptr_glutIconifyWindow,"glutIconifyWindow",glutIconifyWindow,IO ()) +API_ENTRY(dyn_glutIdleFunc,ptr_glutIdleFunc,"glutIdleFunc",glutIdleFunc,FunPtr IdleFunc -> IO ()) +API_ENTRY(dyn_glutIgnoreKeyRepeat,ptr_glutIgnoreKeyRepeat,"glutIgnoreKeyRepeat",glutIgnoreKeyRepeat,CInt -> IO ()) +API_ENTRY(dyn_glutInit,ptr_glutInit,"glutInit",glutInit,Ptr CInt -> Ptr (Ptr CChar) -> IO ()) +API_ENTRY(dyn_glutInitContextFlags,ptr_glutInitContextFlags,"glutInitContextFlags",glutInitContextFlags,CInt -> IO ()) +API_ENTRY(dyn_glutInitContextFunc,ptr_glutInitContextFunc,"glutInitContextFunc",glutInitContextFunc,FunPtr InitContextFunc -> IO ()) +API_ENTRY(dyn_glutInitContextProfile,ptr_glutInitContextProfile,"glutInitContextProfile",glutInitContextProfile,CInt -> IO ()) +API_ENTRY(dyn_glutInitContextVersion,ptr_glutInitContextVersion,"glutInitContextVersion",glutInitContextVersion,CInt -> CInt -> IO ()) +API_ENTRY(dyn_glutInitDisplayMode,ptr_glutInitDisplayMode,"glutInitDisplayMode",glutInitDisplayMode,CUInt -> IO ()) +API_ENTRY(dyn_glutInitDisplayString,ptr_glutInitDisplayString,"glutInitDisplayString",glutInitDisplayString,Ptr CChar -> IO ()) +API_ENTRY(dyn_glutInitWindowPosition,ptr_glutInitWindowPosition,"glutInitWindowPosition",glutInitWindowPosition,CInt -> CInt -> IO ()) +API_ENTRY(dyn_glutInitWindowSize,ptr_glutInitWindowSize,"glutInitWindowSize",glutInitWindowSize,CInt -> CInt -> IO ()) +API_ENTRY(dyn_glutJoystickFunc,ptr_glutJoystickFunc,"glutJoystickFunc",glutJoystickFunc,FunPtr JoystickFunc -> CInt -> IO ()) +API_ENTRY(dyn_glutKeyboardFunc,ptr_glutKeyboardFunc,"glutKeyboardFunc",glutKeyboardFunc,FunPtr KeyboardFunc -> IO ()) +API_ENTRY(dyn_glutKeyboardUpFunc,ptr_glutKeyboardUpFunc,"glutKeyboardUpFunc",glutKeyboardUpFunc,FunPtr KeyboardUpFunc -> IO ()) +API_ENTRY(dyn_glutLayerGet,ptr_glutLayerGet,"glutLayerGet",glutLayerGet,GLenum -> IO CInt) +API_ENTRY(dyn_glutLeaveFullScreen,ptr_glutLeaveFullScreen,"glutLeaveFullScreen",glutLeaveFullScreen,IO ()) +API_ENTRY(dyn_glutLeaveGameMode,ptr_glutLeaveGameMode,"glutLeaveGameMode",glutLeaveGameMode,IO ()) +API_ENTRY_SAFE(dyn_glutLeaveMainLoop,ptr_glutLeaveMainLoop,"glutLeaveMainLoop",glutLeaveMainLoop,IO ()) +API_ENTRY_SAFE(dyn_glutMainLoop,ptr_glutMainLoop,"glutMainLoop",glutMainLoop,IO ()) +API_ENTRY_SAFE(dyn_glutMainLoopEvent,ptr_glutMainLoopEvent,"glutMainLoopEvent",glutMainLoopEvent,IO ()) +API_ENTRY(dyn_glutMenuDestroyFunc,ptr_glutMenuDestroyFunc,"glutMenuDestroyFunc",glutMenuDestroyFunc,FunPtr MenuDestroyFunc -> IO ()) +API_ENTRY(dyn_glutMenuStateFunc,ptr_glutMenuStateFunc,"glutMenuStateFunc",glutMenuStateFunc,FunPtr MenuStateFunc -> IO ()) +API_ENTRY(dyn_glutMenuStatusFunc,ptr_glutMenuStatusFunc,"glutMenuStatusFunc",glutMenuStatusFunc,FunPtr MenuStatusFunc -> IO ()) +API_ENTRY(dyn_glutMotionFunc,ptr_glutMotionFunc,"glutMotionFunc",glutMotionFunc,FunPtr MotionFunc -> IO ()) +API_ENTRY(dyn_glutMouseFunc,ptr_glutMouseFunc,"glutMouseFunc",glutMouseFunc,FunPtr MouseFunc -> IO ()) +API_ENTRY(dyn_glutMouseWheelFunc,ptr_glutMouseWheelFunc,"glutMouseWheelFunc",glutMouseWheelFunc,FunPtr MouseWheelFunc -> IO ()) +API_ENTRY(dyn_glutMultiButtonFunc,ptr_glutMultiButtonFunc,"glutMultiButtonFunc",glutMultiButtonFunc,FunPtr MultiButtonFunc -> IO ()) +API_ENTRY(dyn_glutMultiEntryFunc,ptr_glutMultiEntryFunc,"glutMultiEntryFunc",glutMultiEntryFunc,FunPtr MultiEntryFunc -> IO ()) +API_ENTRY(dyn_glutMultiMotionFunc,ptr_glutMultiMotionFunc,"glutMultiMotionFunc",glutMultiMotionFunc,FunPtr MultiMotionFunc -> IO ()) +API_ENTRY(dyn_glutMultiPassiveFunc,ptr_glutMultiPassiveFunc,"glutMultiPassiveFunc",glutMultiPassiveFunc,FunPtr MultiPassiveFunc -> IO ()) +API_ENTRY(dyn_glutOverlayDisplayFunc,ptr_glutOverlayDisplayFunc,"glutOverlayDisplayFunc",glutOverlayDisplayFunc,FunPtr OverlayDisplayFunc -> IO ()) +API_ENTRY(dyn_glutPassiveMotionFunc,ptr_glutPassiveMotionFunc,"glutPassiveMotionFunc",glutPassiveMotionFunc,FunPtr PassiveMotionFunc -> IO ()) +API_ENTRY(dyn_glutPopWindow,ptr_glutPopWindow,"glutPopWindow",glutPopWindow,IO ()) +API_ENTRY(dyn_glutPositionFunc,ptr_glutPositionFunc,"glutPositionFunc",glutPositionFunc,FunPtr PositionFunc -> IO ()) +API_ENTRY(dyn_glutPositionWindow,ptr_glutPositionWindow,"glutPositionWindow",glutPositionWindow,CInt -> CInt -> IO ()) +API_ENTRY_SAFE(dyn_glutPostOverlayRedisplay,ptr_glutPostOverlayRedisplay,"glutPostOverlayRedisplay",glutPostOverlayRedisplay,IO ()) +API_ENTRY(dyn_glutPostRedisplay,ptr_glutPostRedisplay,"glutPostRedisplay",glutPostRedisplay,IO ()) +API_ENTRY_SAFE(dyn_glutPostWindowOverlayRedisplay,ptr_glutPostWindowOverlayRedisplay,"glutPostWindowOverlayRedisplay",glutPostWindowOverlayRedisplay,CInt -> IO ()) +API_ENTRY(dyn_glutPostWindowRedisplay,ptr_glutPostWindowRedisplay,"glutPostWindowRedisplay",glutPostWindowRedisplay,CInt -> IO ()) +API_ENTRY(dyn_glutPushWindow,ptr_glutPushWindow,"glutPushWindow",glutPushWindow,IO ()) +API_ENTRY(dyn_glutRemoveMenuItem,ptr_glutRemoveMenuItem,"glutRemoveMenuItem",glutRemoveMenuItem,CInt -> IO ()) +API_ENTRY_SAFE(dyn_glutRemoveOverlay,ptr_glutRemoveOverlay,"glutRemoveOverlay",glutRemoveOverlay,IO ()) +API_ENTRY(dyn_glutReportErrors,ptr_glutReportErrors,"glutReportErrors",glutReportErrors,IO ()) +API_ENTRY(dyn_glutReshapeFunc,ptr_glutReshapeFunc,"glutReshapeFunc",glutReshapeFunc,FunPtr ReshapeFunc -> IO ()) +API_ENTRY(dyn_glutReshapeWindow,ptr_glutReshapeWindow,"glutReshapeWindow",glutReshapeWindow,CInt -> CInt -> IO ()) +API_ENTRY(dyn_glutSetColor,ptr_glutSetColor,"glutSetColor",glutSetColor,CInt -> GLfloat -> GLfloat -> GLfloat -> IO ()) +API_ENTRY(dyn_glutSetCursor,ptr_glutSetCursor,"glutSetCursor",glutSetCursor,CInt -> IO ()) +API_ENTRY(dyn_glutSetIconTitle,ptr_glutSetIconTitle,"glutSetIconTitle",glutSetIconTitle,Ptr CChar -> IO ()) +API_ENTRY(dyn_glutSetKeyRepeat,ptr_glutSetKeyRepeat,"glutSetKeyRepeat",glutSetKeyRepeat,CInt -> IO ()) +API_ENTRY(dyn_glutSetMenu,ptr_glutSetMenu,"glutSetMenu",glutSetMenu,CInt -> IO ()) +API_ENTRY(dyn_glutSetMenuData,ptr_glutSetMenuData,"glutSetMenuData",glutSetMenuData,Ptr a -> IO ()) +API_ENTRY(dyn_glutSetMenuFont,ptr_glutSetMenuFont,"glutSetMenuFont",glutSetMenuFont,GLint -> Ptr a -> IO ()) +API_ENTRY(dyn_glutSetOption,ptr_glutSetOption,"glutSetOption",glutSetOption,GLenum -> CInt -> IO ()) +API_ENTRY(dyn_glutSetVertexAttribCoord3,ptr_glutSetVertexAttribCoord3,"glutSetVertexAttribCoord3",glutSetVertexAttribCoord3,GLint -> IO ()) +API_ENTRY(dyn_glutSetVertexAttribNormal,ptr_glutSetVertexAttribNormal,"glutSetVertexAttribNormal",glutSetVertexAttribNormal,GLint -> IO ()) +API_ENTRY(dyn_glutSetVertexAttribTexCoord2,ptr_glutSetVertexAttribTexCoord2,"glutSetVertexAttribTexCoord2",glutSetVertexAttribTexCoord2,GLint -> IO ()) +API_ENTRY(dyn_glutSetWindow,ptr_glutSetWindow,"glutSetWindow",glutSetWindow,CInt -> IO ()) +API_ENTRY(dyn_glutSetWindowData,ptr_glutSetWindowData,"glutSetWindowData",glutSetWindowData,Ptr a -> IO ()) +API_ENTRY(dyn_glutSetWindowTitle,ptr_glutSetWindowTitle,"glutSetWindowTitle",glutSetWindowTitle,Ptr CChar -> IO ()) +API_ENTRY(dyn_glutSetupVideoResizing,ptr_glutSetupVideoResizing,"glutSetupVideoResizing",glutSetupVideoResizing,IO ()) +API_ENTRY_SAFE(dyn_glutShowOverlay,ptr_glutShowOverlay,"glutShowOverlay",glutShowOverlay,IO ()) +API_ENTRY(dyn_glutShowWindow,ptr_glutShowWindow,"glutShowWindow",glutShowWindow,IO ()) +API_ENTRY(dyn_glutSolidCone,ptr_glutSolidCone,"glutSolidCone",glutSolidCone,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) +API_ENTRY(dyn_glutSolidCube,ptr_glutSolidCube,"glutSolidCube",glutSolidCube,GLdouble -> IO ()) +API_ENTRY(dyn_glutSolidCylinder,ptr_glutSolidCylinder,"glutSolidCylinder",glutSolidCylinder,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) +API_ENTRY(dyn_glutSolidDodecahedron,ptr_glutSolidDodecahedron,"glutSolidDodecahedron",glutSolidDodecahedron,IO ()) +API_ENTRY(dyn_glutSolidIcosahedron,ptr_glutSolidIcosahedron,"glutSolidIcosahedron",glutSolidIcosahedron,IO ()) +API_ENTRY(dyn_glutSolidOctahedron,ptr_glutSolidOctahedron,"glutSolidOctahedron",glutSolidOctahedron,IO ()) +API_ENTRY(dyn_glutSolidRhombicDodecahedron,ptr_glutSolidRhombicDodecahedron,"glutSolidRhombicDodecahedron",glutSolidRhombicDodecahedron,IO ()) +API_ENTRY(dyn_glutSolidSierpinskiSponge,ptr_glutSolidSierpinskiSponge,"glutSolidSierpinskiSponge",glutSolidSierpinskiSponge,CInt -> Ptr GLdouble -> GLdouble -> IO ()) +API_ENTRY(dyn_glutSolidSphere,ptr_glutSolidSphere,"glutSolidSphere",glutSolidSphere,GLdouble -> GLint -> GLint -> IO ()) +API_ENTRY(dyn_glutSolidTeacup,ptr_glutSolidTeacup,"glutSolidTeacup",glutSolidTeacup,GLdouble -> IO ()) +API_ENTRY(dyn_glutSolidTeapot,ptr_glutSolidTeapot,"glutSolidTeapot",glutSolidTeapot,GLdouble -> IO ()) +API_ENTRY(dyn_glutSolidTeaspoon,ptr_glutSolidTeaspoon,"glutSolidTeaspoon",glutSolidTeaspoon,GLdouble -> IO ()) +API_ENTRY(dyn_glutSolidTetrahedron,ptr_glutSolidTetrahedron,"glutSolidTetrahedron",glutSolidTetrahedron,IO ()) +API_ENTRY(dyn_glutSolidTorus,ptr_glutSolidTorus,"glutSolidTorus",glutSolidTorus,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) +API_ENTRY(dyn_glutSpaceballButtonFunc,ptr_glutSpaceballButtonFunc,"glutSpaceballButtonFunc",glutSpaceballButtonFunc,FunPtr SpaceballButtonFunc -> IO ()) +API_ENTRY(dyn_glutSpaceballMotionFunc,ptr_glutSpaceballMotionFunc,"glutSpaceballMotionFunc",glutSpaceballMotionFunc,FunPtr SpaceballMotionFunc -> IO ()) +API_ENTRY(dyn_glutSpaceballRotateFunc,ptr_glutSpaceballRotateFunc,"glutSpaceballRotateFunc",glutSpaceballRotateFunc,FunPtr SpaceballRotateFunc -> IO ()) +API_ENTRY(dyn_glutSpecialFunc,ptr_glutSpecialFunc,"glutSpecialFunc",glutSpecialFunc,FunPtr SpecialFunc -> IO ()) +API_ENTRY(dyn_glutSpecialUpFunc,ptr_glutSpecialUpFunc,"glutSpecialUpFunc",glutSpecialUpFunc,FunPtr SpecialUpFunc -> IO ()) +API_ENTRY(dyn_glutStopVideoResizing,ptr_glutStopVideoResizing,"glutStopVideoResizing",glutStopVideoResizing,IO ()) +API_ENTRY(dyn_glutStrokeCharacter,ptr_glutStrokeCharacter,"glutStrokeCharacter",glutStrokeCharacter,Ptr a -> CInt -> IO ()) +API_ENTRY(dyn_glutStrokeHeight,ptr_glutStrokeHeight,"glutStrokeHeight",glutStrokeHeight,Ptr a -> IO GLfloat) +API_ENTRY(dyn_glutStrokeLength,ptr_glutStrokeLength,"glutStrokeLength",glutStrokeLength,Ptr a -> Ptr CUChar -> IO CInt) +API_ENTRY(dyn_glutStrokeString,ptr_glutStrokeString,"glutStrokeString",glutStrokeString,Ptr a -> Ptr CUChar -> IO ()) +API_ENTRY(dyn_glutStrokeWidth,ptr_glutStrokeWidth,"glutStrokeWidth",glutStrokeWidth,Ptr a -> CInt -> IO CInt) +API_ENTRY(dyn_glutSwapBuffers,ptr_glutSwapBuffers,"glutSwapBuffers",glutSwapBuffers,IO ()) +API_ENTRY(dyn_glutTabletButtonFunc,ptr_glutTabletButtonFunc,"glutTabletButtonFunc",glutTabletButtonFunc,FunPtr TabletButtonFunc -> IO ()) +API_ENTRY(dyn_glutTabletMotionFunc,ptr_glutTabletMotionFunc,"glutTabletMotionFunc",glutTabletMotionFunc,FunPtr TabletMotionFunc -> IO ()) +API_ENTRY(dyn_glutTimerFunc,ptr_glutTimerFunc,"glutTimerFunc",glutTimerFunc,CUInt -> FunPtr TimerFunc -> CInt -> IO ()) +API_ENTRY_SAFE(dyn_glutUseLayer,ptr_glutUseLayer,"glutUseLayer",glutUseLayer,GLenum -> IO ()) +API_ENTRY(dyn_glutVideoPan,ptr_glutVideoPan,"glutVideoPan",glutVideoPan,CInt -> CInt -> CInt -> CInt -> IO ()) +API_ENTRY(dyn_glutVideoResize,ptr_glutVideoResize,"glutVideoResize",glutVideoResize,CInt -> CInt -> CInt -> CInt -> IO ()) +API_ENTRY(dyn_glutVideoResizeGet,ptr_glutVideoResizeGet,"glutVideoResizeGet",glutVideoResizeGet,GLenum -> IO CInt) +API_ENTRY(dyn_glutVisibilityFunc,ptr_glutVisibilityFunc,"glutVisibilityFunc",glutVisibilityFunc,FunPtr VisibilityFunc -> IO ()) +API_ENTRY(dyn_glutWMCloseFunc,ptr_glutWMCloseFunc,"glutWMCloseFunc",glutWMCloseFunc,FunPtr WMCloseFunc -> IO ()) +API_ENTRY(dyn_glutWarpPointer,ptr_glutWarpPointer,"glutWarpPointer",glutWarpPointer,CInt -> CInt -> IO ()) +API_ENTRY(dyn_glutWindowStatusFunc,ptr_glutWindowStatusFunc,"glutWindowStatusFunc",glutWindowStatusFunc,FunPtr WindowStatusFunc -> IO ()) +API_ENTRY(dyn_glutWireCone,ptr_glutWireCone,"glutWireCone",glutWireCone,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) +API_ENTRY(dyn_glutWireCube,ptr_glutWireCube,"glutWireCube",glutWireCube,GLdouble -> IO ()) +API_ENTRY(dyn_glutWireCylinder,ptr_glutWireCylinder,"glutWireCylinder",glutWireCylinder,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) +API_ENTRY(dyn_glutWireDodecahedron,ptr_glutWireDodecahedron,"glutWireDodecahedron",glutWireDodecahedron,IO ()) +API_ENTRY(dyn_glutWireIcosahedron,ptr_glutWireIcosahedron,"glutWireIcosahedron",glutWireIcosahedron,IO ()) +API_ENTRY(dyn_glutWireOctahedron,ptr_glutWireOctahedron,"glutWireOctahedron",glutWireOctahedron,IO ()) +API_ENTRY(dyn_glutWireRhombicDodecahedron,ptr_glutWireRhombicDodecahedron,"glutWireRhombicDodecahedron",glutWireRhombicDodecahedron,IO ()) +API_ENTRY(dyn_glutWireSierpinskiSponge,ptr_glutWireSierpinskiSponge,"glutWireSierpinskiSponge",glutWireSierpinskiSponge,CInt -> Ptr GLdouble -> GLdouble -> IO ()) +API_ENTRY(dyn_glutWireSphere,ptr_glutWireSphere,"glutWireSphere",glutWireSphere,GLdouble -> GLint -> GLint -> IO ()) +API_ENTRY(dyn_glutWireTeacup,ptr_glutWireTeacup,"glutWireTeacup",glutWireTeacup,GLdouble -> IO ()) +API_ENTRY(dyn_glutWireTeapot,ptr_glutWireTeapot,"glutWireTeapot",glutWireTeapot,GLdouble -> IO ()) +API_ENTRY(dyn_glutWireTeaspoon,ptr_glutWireTeaspoon,"glutWireTeaspoon",glutWireTeaspoon,GLdouble -> IO ()) +API_ENTRY(dyn_glutWireTetrahedron,ptr_glutWireTetrahedron,"glutWireTetrahedron",glutWireTetrahedron,IO ()) +API_ENTRY(dyn_glutWireTorus,ptr_glutWireTorus,"glutWireTorus",glutWireTorus,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) diff --git a/src/Graphics/UI/GLUT/Raw/Tokens.hs b/src/Graphics/UI/GLUT/Raw/Tokens.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Raw/Tokens.hs @@ -0,0 +1,643 @@ +{-# 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_APPSTATUS_PAUSE :: CInt +glut_APPSTATUS_PAUSE = 0x0001 + +glut_APPSTATUS_RESUME :: CInt +glut_APPSTATUS_RESUME = 0x0002 + +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_GEOMETRY_VISUALIZE_NORMALS :: GLenum +glut_GEOMETRY_VISUALIZE_NORMALS = 0x0205 + +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_ALT_L :: CInt +glut_KEY_ALT_L = 0x0074 + +glut_KEY_ALT_R :: CInt +glut_KEY_ALT_R = 0x0075 + +glut_KEY_BEGIN :: CInt +glut_KEY_BEGIN = 0x006E + +glut_KEY_CTRL_L :: CInt +glut_KEY_CTRL_L = 0x0072 + +glut_KEY_CTRL_R :: CInt +glut_KEY_CTRL_R = 0x0073 + +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_SHIFT_L :: CInt +glut_KEY_SHIFT_L = 0x0070 + +glut_KEY_SHIFT_R :: CInt +glut_KEY_SHIFT_R = 0x0071 + +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_SKIP_STALE_MOTION_EVENTS :: GLenum +glut_SKIP_STALE_MOTION_EVENTS = 0x0204 + +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/src/Graphics/UI/GLUT/State.hs b/src/Graphics/UI/GLUT/State.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/State.hs @@ -0,0 +1,446 @@ +-------------------------------------------------------------------------------- +-- | +-- 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, skipStaleMotionEvents, + + -- * State of the /current window/ + + -- ** Framebuffer state + rgba, + BufferDepth, rgbaBufferDepths, colorBufferDepth, + doubleBuffered, stereo, + accumBufferDepths, depthBufferDepth, stencilBufferDepth, + SampleCount, sampleCount, formatID, + + -- ** Full screen state + fullScreenMode, + + -- ** Object rendering state + geometryVisualizeNormals, + + -- ** Vertex attribute state + vertexAttribCoord3, vertexAttribNormal, vertexAttribTexCoord2, + + -- ** Layer state + 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 +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 + +-------------------------------------------------------------------------------- + +-- | (/freeglut only/) Controls if vectors representing the normals should be +-- drawn, too, when objects are drawn. + +geometryVisualizeNormals :: StateVar Bool +geometryVisualizeNormals = + makeStateVar + (simpleGet i2b glut_GEOMETRY_VISUALIZE_NORMALS) + (glutSetOption glut_GEOMETRY_VISUALIZE_NORMALS . b2i) + + +-------------------------------------------------------------------------------- + +-- | (/freeglut only/) If 'vertexAttribCoord3' and 'vertexAttribNormal' both +-- contain 'Nothing', the fixed function pipeline is used to draw +-- objects. Otherwise VBOs are used and the coordinates are passed via 'Just' +-- this attribute location (for a vec3). + +vertexAttribCoord3 :: SettableStateVar (Maybe AttribLocation) +vertexAttribCoord3 = setVertexAttribWith glutSetVertexAttribCoord3 + +setVertexAttribWith :: (GLint -> IO ()) -> SettableStateVar (Maybe AttribLocation) +setVertexAttribWith f = makeSettableStateVar $ f . getLocation + where getLocation = maybe (-1) (\(AttribLocation l) -> fromIntegral l) + +-- | (/freeglut only/) If 'vertexAttribCoord3' and 'vertexAttribNormal' both +-- contain 'Nothing', the fixed function pipeline is used to draw +-- objects. Otherwise VBOs are used and the normals are passed via 'Just' this +-- attribute location (for a vec3). + +vertexAttribNormal :: SettableStateVar (Maybe AttribLocation) +vertexAttribNormal = setVertexAttribWith glutSetVertexAttribNormal + +-- | (/freeglut only/) If VBOs are used to draw objects (controlled via +-- 'vertexAttribCoord3' and 'vertexAttribNormal'), the texture coordinates are +-- passed via 'Just' this attribute location (for a vec2). + +vertexAttribTexCoord2 :: SettableStateVar (Maybe AttribLocation) +vertexAttribTexCoord2 = setVertexAttribWith glutSetVertexAttribTexCoord2 + +-------------------------------------------------------------------------------- + +-- | 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 (un-)marshalers + +i2b :: CInt -> Bool +i2b = (/= 0) + +b2i :: Bool -> CInt +b2i False = 0 +b2i True = 1 + +-------------------------------------------------------------------------------- + +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 on X11 only/) Controls if all but the last motion event should +-- be discarded. + +skipStaleMotionEvents :: StateVar Bool +skipStaleMotionEvents = + makeStateVar + (simpleGet i2b glut_SKIP_STALE_MOTION_EVENTS) + (glutSetOption glut_SKIP_STALE_MOTION_EVENTS . b2i) + +----------------------------------------------------------------------------- + +-- | (/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/src/Graphics/UI/GLUT/Types.hs b/src/Graphics/UI/GLUT/Types.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Types.hs @@ -0,0 +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 diff --git a/src/Graphics/UI/GLUT/Window.hs b/src/Graphics/UI/GLUT/Window.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Window.hs @@ -0,0 +1,502 @@ +-------------------------------------------------------------------------------- +-- | +-- 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, leaveFullScreen, + + -- * 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 + +-------------------------------------------------------------------------------- + +-- | (/freeglut only/) If we are in full screen mode, resize the current window +-- back to its original size. + +leaveFullScreen :: IO () +leaveFullScreen = glutLeaveFullScreen + +-------------------------------------------------------------------------------- + +-- $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)