view release on metacpan or  search on metacpan

hugs98-Nov2003/fptools/libraries/GLUT/Graphics/UI/GLUT/Callbacks/Window.hs  view on Meta::CPAN

--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.GLUT.Callbacks.Window
-- Copyright   :  (c) Sven Panne 2003
-- License     :  BSD-style (see the file libraries/GLUT/LICENSE)
-- 
-- Maintainer  :  sven_panne@yahoo.com
-- Stability   :  provisional
-- Portability :  portable
--
--------------------------------------------------------------------------------

module Graphics.UI.GLUT.Callbacks.Window (
   -- * Redisplay callbacks
   DisplayCallback, displayCallback, overlayDisplayCallback,

   -- * Reshape callback
   ReshapeCallback, reshapeCallback,

   -- * Callback for visibility changes
   Visibility(..), VisibilityCallback, visibilityCallback,

   -- * Keyboard and mouse input callback
   Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..),
   KeyboardMouseCallback, keyboardMouseCallback,

   -- * Mouse movement callbacks
   MotionCallback, motionCallback, passiveMotionCallback,
   Crossing(..), CrossingCallback, crossingCallback,

   -- * Spaceball callback
   SpaceballMotion, SpaceballRotation, ButtonIndex, SpaceballInput(..),
   SpaceballCallback, spaceballCallback,

   -- * Dial & button box callback
   DialAndButtonBoxInput(..), DialIndex,
   DialAndButtonBoxCallback, dialAndButtonBoxCallback,

   -- * Tablet callback
   TabletPosition(..), TabletInput(..), TabletCallback, tabletCallback,

   -- * Joystick callback
   JoystickButtons(..), JoystickPosition(..),
   JoystickCallback, joystickCallback
) where

import Control.Monad ( liftM )
import Data.Bits ( Bits((.&.)) )
import Data.Char ( chr )
import Data.Maybe ( fromJust )
import Foreign.C.Types ( CInt, CUInt, CUChar )
import Foreign.Ptr ( FunPtr )
import Graphics.Rendering.OpenGL.GL.CoordTrans ( Position(..), Size(..) )
import Graphics.Rendering.OpenGL.GL.StateVar (
   SettableStateVar, makeSettableStateVar )
import Graphics.UI.GLUT.Callbacks.Registration ( CallbackType(..), setCallback )
import Graphics.UI.GLUT.Constants (
   glut_NOT_VISIBLE, glut_VISIBLE,
   glut_KEY_F1, glut_KEY_F2, glut_KEY_F3, glut_KEY_F4, glut_KEY_F5, glut_KEY_F6,
   glut_KEY_F7, glut_KEY_F8, glut_KEY_F9, glut_KEY_F10, glut_KEY_F11,
   glut_KEY_F12, glut_KEY_LEFT, glut_KEY_UP, glut_KEY_RIGHT, glut_KEY_DOWN,
   glut_KEY_PAGE_UP, glut_KEY_PAGE_DOWN, glut_KEY_HOME, glut_KEY_END,
   glut_KEY_INSERT,
   glut_DOWN, glut_UP,
   glut_ACTIVE_SHIFT, glut_ACTIVE_CTRL, glut_ACTIVE_ALT,
   glut_LEFT, glut_ENTERED,
   glut_JOYSTICK_BUTTON_A, glut_JOYSTICK_BUTTON_B,
   glut_JOYSTICK_BUTTON_C, glut_JOYSTICK_BUTTON_D )
import Graphics.UI.GLUT.State ( PollRate )
import Graphics.UI.GLUT.Types ( MouseButton(..), unmarshalMouseButton )

--------------------------------------------------------------------------------

-- | 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 makeDisplayCallback . Just

foreign import ccall "wrapper" makeDisplayCallback ::
   DisplayCallback -> IO (FunPtr DisplayCallback)

foreign import CALLCONV unsafe "glutDisplayFunc" glutDisplayFunc ::
   FunPtr DisplayCallback -> IO ()

--------------------------------------------------------------------------------

-- | 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 makeDisplayCallback

foreign import CALLCONV unsafe "glutOverlayDisplayFunc" glutOverlayDisplayFunc
   :: FunPtr DisplayCallback -> IO ()

--------------------------------------------------------------------------------

-- | A reshape callback

type ReshapeCallback = Size -> IO ()

type ReshapeCallback' = CInt -> CInt -> 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
--
-- @
-- '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 (makeReshapeCallback . unmarshal)
   where unmarshal cb w h = cb (Size (fromIntegral w) (fromIntegral h))

foreign import ccall "wrapper" makeReshapeCallback ::
   ReshapeCallback' -> IO (FunPtr ReshapeCallback')

foreign import CALLCONV unsafe "glutReshapeFunc" glutReshapeFunc ::
   FunPtr ReshapeCallback' -> IO ()

--------------------------------------------------------------------------------

-- | The visibility state of the /current window/

data Visibility
   = NotVisible -- ^ 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.
   | Visible    -- ^ No part of the /current window/ is visible, i.e., until the
                --   window\'s visibility changes, all further rendering to the
                --   window is discarded.
   deriving ( Eq, Ord, Show )

unmarshalVisibility :: CInt -> Visibility
unmarshalVisibility v
   | v == glut_NOT_VISIBLE = NotVisible
   | v == glut_VISIBLE     = Visible
   | otherwise = error "unmarshalVisibility"

--------------------------------------------------------------------------------

-- | A visibilty callback

type VisibilityCallback = Visibility -> IO ()

type VisibilityCallback' = CInt -> 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.

visibilityCallback :: SettableStateVar (Maybe VisibilityCallback)
visibilityCallback = makeSettableStateVar $
   setCallback VisibilityCB glutVisibilityFunc
               (makeVisibilityCallback . unmarshal)
   where unmarshal cb  = cb . unmarshalVisibility

foreign import ccall "wrapper" makeVisibilityCallback ::