diff --git a/GLUT.cabal b/GLUT.cabal --- a/GLUT.cabal +++ b/GLUT.cabal @@ -1,5 +1,5 @@ name: GLUT -version: 2.5.0.2 +version: 2.5.1.0 license: BSD3 license-file: LICENSE maintainer: Sven Panne , Jason Dagit diff --git a/Graphics/UI/GLUT/Callbacks/Registration.hs b/Graphics/UI/GLUT/Callbacks/Registration.hs --- a/Graphics/UI/GLUT/Callbacks/Registration.hs +++ b/Graphics/UI/GLUT/Callbacks/Registration.hs @@ -40,8 +40,10 @@ | SpaceballButtonCB | ButtonBoxCB | DialsCB | TabletMotionCB | TabletButtonCB | JoystickCB | MenuStatusCB | IdleCB - | CloseCB -- freeglut only - | MouseWheelCB -- freeglut only + -- freeglut-only callback types + | CloseCB | MouseWheelCB | PositionCB + | MultiEntryCB | MultiMotionCB | MultiButtonCB + | MultiPassiveCB | InitContextCB | AppStatusCB deriving ( Eq, Ord ) isGlobal :: CallbackType -> Bool diff --git a/Graphics/UI/GLUT/Callbacks/Window.hs b/Graphics/UI/GLUT/Callbacks/Window.hs --- a/Graphics/UI/GLUT/Callbacks/Window.hs +++ b/Graphics/UI/GLUT/Callbacks/Window.hs @@ -17,6 +17,9 @@ -- * Reshape callback ReshapeCallback, reshapeCallback, + -- * Position callback + PositionCallback, positionCallback, + -- * Callbacks for visibility changes Visibility(..), VisibilityCallback, visibilityCallback, WindowState(..), WindowStateCallback, windowStateCallback, @@ -24,6 +27,10 @@ -- * Window close callback CloseCallback, closeCallback, + -- * Life cycle callbacks for mobile platforms + InitContextCallback, initContextCallback, + AppStatus(..), AppStatusCallback, appStatusCallback, + -- * Keyboard callback KeyboardCallback, keyboardCallback, keyboardUpCallback, @@ -57,15 +64,21 @@ -- * Joystick callback JoystickButtons(..), JoystickPosition(..), - JoystickCallback, joystickCallback + 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 ( Position(..), Size(..) - , SettableStateVar, makeSettableStateVar ) +import Graphics.Rendering.OpenGL import Graphics.UI.GLUT.Callbacks.Registration import Graphics.UI.GLUT.Raw import Graphics.UI.GLUT.State @@ -190,6 +203,21 @@ -------------------------------------------------------------------------------- +-- | 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 @@ -277,15 +305,62 @@ -------------------------------------------------------------------------------- +-- | 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 () @@ -296,6 +371,7 @@ -- | Controls the keyboard callback for the /current window/. This is -- activated only when a key is pressed. + keyboardCallback :: SettableStateVar (Maybe KeyboardCallback) keyboardCallback = makeSettableStateVar setKeyboardCallback @@ -310,8 +386,10 @@ -- | 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 @@ -341,7 +419,15 @@ | KeyNumLock | KeyBegin | KeyDelete - | KeyUnknown Int + | 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 @@ -370,11 +456,18 @@ | 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 () @@ -385,8 +478,10 @@ -- | 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 () @@ -397,8 +492,10 @@ -- | 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 @@ -417,6 +514,7 @@ -------------------------------------------------------------------------------- -- | A mouse callback + type MouseCallback = MouseButton -> KeyState -> Position -> IO () setMouseCallback :: Maybe MouseCallback -> IO () @@ -427,8 +525,10 @@ (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 @@ -836,3 +936,56 @@ (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/Fonts.hs b/Graphics/UI/GLUT/Fonts.hs --- a/Graphics/UI/GLUT/Fonts.hs +++ b/Graphics/UI/GLUT/Fonts.hs @@ -26,7 +26,7 @@ import Foreign.C.String import Foreign.C.Types import Foreign.Ptr -import Graphics.Rendering.OpenGL ( GLint, GLfloat ) +import Graphics.Rendering.OpenGL import Graphics.UI.GLUT.Raw -------------------------------------------------------------------------------- @@ -72,72 +72,9 @@ -------------------------------------------------------------------------------- --- | The bitmap fonts available in GLUT. The exact bitmap to be used is --- defined by the standard X glyph bitmaps for the X font with the given name. - -data BitmapFont - = Fixed8By13 -- ^ A fixed width font with every character fitting in an 8 - -- by 13 pixel rectangle. - -- (@-misc-fixed-medium-r-normal--13-120-75-75-C-80-iso8859-1@) - | Fixed9By15 -- ^ A fixed width font with every character fitting in an 9 - -- by 15 pixel rectangle. - -- (@-misc-fixed-medium-r-normal--15-140-75-75-C-90-iso8859-1@) - | TimesRoman10 -- ^ A 10-point proportional spaced Times Roman font. - -- (@-adobe-times-medium-r-normal--10-100-75-75-p-54-iso8859-1@) - | TimesRoman24 -- ^ A 24-point proportional spaced Times Roman font. - -- (@-adobe-times-medium-r-normal--24-240-75-75-p-124-iso8859-1@) - | Helvetica10 -- ^ A 10-point proportional spaced Helvetica font. - -- (@-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1@) - | Helvetica12 -- ^ A 12-point proportional spaced Helvetica font. - -- (@-adobe-helvetica-medium-r-normal--12-120-75-75-p-67-iso8859-1@) - | Helvetica18 -- ^ A 18-point proportional spaced Helvetica font. - -- (@-adobe-helvetica-medium-r-normal--18-180-75-75-p-98-iso8859-1@) - deriving ( Eq, Ord, Show ) - --- Alas, fonts in GLUT are not denoted by some integral value, but by opaque --- pointers on the C side. Even worse: For WinDoze, they are simply small ints, --- casted to void*, for other platforms addresses of global variables are used. --- And all is done via ugly #ifdef-ed #defines... Aaaaargl! So the only portable --- way is using integers on the Haskell side and doing the marshaling via some --- small C wrappers around those macros. *sigh* -type GLUTbitmapFont = Ptr () - -marhshalBitmapFont :: BitmapFont -> IO GLUTbitmapFont -marhshalBitmapFont x = case x of - Fixed8By13 -> hs_GLUT_marshalBitmapFont 0 - Fixed9By15 -> hs_GLUT_marshalBitmapFont 1 - TimesRoman10 -> hs_GLUT_marshalBitmapFont 2 - TimesRoman24 -> hs_GLUT_marshalBitmapFont 3 - Helvetica10 -> hs_GLUT_marshalBitmapFont 4 - Helvetica12 -> hs_GLUT_marshalBitmapFont 5 - Helvetica18 -> hs_GLUT_marshalBitmapFont 6 - --------------------------------------------------------------------------------- - --- | The stroke fonts available in GLUT. -data StrokeFont - = Roman -- ^ A proportionally spaced Roman Simplex font for ASCII - -- characters 32 through 127. The maximum top character in the - -- font is 119.05 units; the bottom descends 33.33 units. - | MonoRoman -- ^ A mono-spaced spaced Roman Simplex font (same characters as - -- 'Roman') for ASCII characters 32 through 127. The maximum - -- top character in the font is 119.05 units; the bottom - -- descends 33.33 units. Each character is 104.76 units wide. - deriving ( Eq, Ord, Show ) - --- Same remarks as for GLUTbitmapFont -type GLUTstrokeFont = Ptr () - -marhshalStrokeFont :: StrokeFont -> IO GLUTstrokeFont -marhshalStrokeFont x = case x of - Roman -> hs_GLUT_marshalStrokeFont 0 - MonoRoman -> hs_GLUT_marshalStrokeFont 1 - --------------------------------------------------------------------------------- - bitmapString :: BitmapFont -> String -> IO () bitmapString f s = do - i <- marhshalBitmapFont f + i <- marshalBitmapFont f mapM_ (\c -> withChar c (glutBitmapCharacter i)) s withChar :: Char -> (CInt -> IO a) -> IO a @@ -147,7 +84,7 @@ strokeString :: StrokeFont -> String -> IO () strokeString f s = do - i <- marhshalStrokeFont f + i <- marshalStrokeFont f mapM_ (\c -> withChar c (glutStrokeCharacter i)) s -------------------------------------------------------------------------------- @@ -157,7 +94,7 @@ -- bits). -> IO GLint -- ^ Width in pixels. bitmapLength f s = do - i <- marhshalBitmapFont f + i <- marshalBitmapFont f fmap fromIntegral $ withCString s (glutBitmapLength i . castPtr) -------------------------------------------------------------------------------- @@ -167,17 +104,17 @@ -- bits). -> IO GLint -- ^ Width in units. strokeLength f s = do - i <- marhshalStrokeFont f + 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 =<< marhshalBitmapFont f +bitmapHeight f = fmap fromIntegral $ glutBitmapHeight =<< marshalBitmapFont f -------------------------------------------------------------------------------- strokeHeight :: StrokeFont -- ^ Stroke font to use. -> IO GLfloat -- ^ Height in units. -strokeHeight f = glutStrokeHeight =<< marhshalStrokeFont f +strokeHeight f = glutStrokeHeight =<< marshalStrokeFont f diff --git a/Graphics/UI/GLUT/Menu.hs b/Graphics/UI/GLUT/Menu.hs --- a/Graphics/UI/GLUT/Menu.hs +++ b/Graphics/UI/GLUT/Menu.hs @@ -24,15 +24,13 @@ import Data.Array import Data.IORef -import qualified Data.Map as Map ( empty, lookup, insert, delete ) +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 ( get, ($=), StateVar - , makeStateVar, GettableStateVar - , makeGettableStateVar ) +import Graphics.Rendering.OpenGL import Graphics.UI.GLUT.Callbacks.Registration import Graphics.UI.GLUT.QueryUtils import Graphics.UI.GLUT.Raw @@ -40,9 +38,19 @@ -------------------------------------------------------------------------------- --- | A menu is simply a list of menu items. -newtype Menu = Menu [MenuItem] +-- | 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 @@ -69,11 +77,11 @@ -- are available. attachMenu :: MouseButton -> Menu -> IO () -attachMenu mouseButton menu@(Menu items) = do +attachMenu mouseButton menu = do win <- getCurrentWindow "attachMenu" let hook = MenuHook win mouseButton detachMenu hook - unless (null items) $ do + unless (null (menuItems menu)) $ do (_, destructor) <- traverseMenu menu addToMenuTable hook destructor attachMenu_ mouseButton @@ -88,10 +96,12 @@ deleteFromMenuTable hook traverseMenu :: Menu -> IO (MenuID, Destructor) -traverseMenu (Menu items) = do - let callbackArray = listArray (1, length items) (map makeCallback items) +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 @@ -231,7 +241,6 @@ -- 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 @@ -246,3 +255,8 @@ 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 --- a/Graphics/UI/GLUT/Objects.hs +++ b/Graphics/UI/GLUT/Objects.hs @@ -15,7 +15,11 @@ -- recognizable objects. These routines can be implemented as pure OpenGL -- rendering routines. The routines do not generate display lists for the -- objects they create. The routines generate normals appropriate for lighting --- but do not generate texture coordinates (except for the teapot). +-- 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'. -- -------------------------------------------------------------------------------- @@ -36,7 +40,7 @@ import Foreign.C.Types import Foreign.Marshal.Utils import Foreign.Ptr -import Graphics.Rendering.OpenGL ( Height, Radius, Slices, Stacks, GLint, GLdouble, Vertex3(..) ) +import Graphics.Rendering.OpenGL import Graphics.UI.GLUT.Raw -------------------------------------------------------------------------------- @@ -62,9 +66,8 @@ -- -- * Approximations to rounded objects. -- --- * The classic teapot modeled by Martin Newell in 1975. Both surface normals --- and texture coordinates for the teapot are generated. The teapot is --- generated with OpenGL evaluators. +-- * The classic teaset modeled by Martin Newell in 1975. Both surface normals +-- and texture coordinates for the teaset are generated. -- -- * A Sierpinski sponge, see -- . @@ -113,6 +116,10 @@ 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 @@ -129,198 +136,34 @@ -- | Render an object in the given flavour. renderObject :: Flavour -> Object -> IO () -renderObject Solid (Cube h) = solidCube h -renderObject Wireframe (Cube h) = wireCube h -renderObject Solid Dodecahedron = solidDodecahedron -renderObject Wireframe Dodecahedron = wireDodecahedron -renderObject Solid Icosahedron = solidIcosahedron -renderObject Wireframe Icosahedron = wireIcosahedron -renderObject Solid Octahedron = solidOctahedron -renderObject Wireframe Octahedron = wireOctahedron -renderObject Solid Tetrahedron = solidTetrahedron -renderObject Wireframe Tetrahedron = wireTetrahedron +renderObject Solid (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) = solidSphere r s t -renderObject Wireframe (Sphere' r s t) = wireSphere r s t -renderObject Solid (Cone r h s t) = solidCone r h s t -renderObject Wireframe (Cone r h s t) = wireCone r h s t +renderObject Solid (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) = solidTorus i o s r -renderObject Wireframe (Torus i o s r) = wireTorus i o s r -renderObject Solid (Teapot h) = solidTeapot h -renderObject Wireframe (Teapot h) = wireTeapot h +renderObject Solid (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 - --------------------------------------------------------------------------------- - --- | Render a solid cube centered at the modeling coordinates origin with sides --- of the given length. - -solidCube - :: Height -- ^ Length of the cube sides - -> IO () -solidCube = glutSolidCube - --- | Render a wireframe cube centered at the modeling coordinates origin with --- sides of the given length. - -wireCube - :: Height -- ^ Length of the cube sides - -> IO () -wireCube = glutWireCube - --------------------------------------------------------------------------------- - --- | Render a solid dodecahedron (12-sided regular solid) centered at the --- modeling coordinates origin with a radius of @sqrt 3@. - -solidDodecahedron :: IO () -solidDodecahedron = glutSolidDodecahedron - --- | Render a wireframe dodecahedron (12-sided regular solid) centered at the --- modeling coordinates origin with a radius of @sqrt 3@. - -wireDodecahedron :: IO () -wireDodecahedron = glutWireDodecahedron - --------------------------------------------------------------------------------- - --- | Render a solid icosahedron (20-sided regular solid) centered at the --- modeling coordinates origin with a radius of 1.0. - -wireIcosahedron :: IO () -wireIcosahedron = glutWireIcosahedron - --- | Render a wireframe icosahedron (20-sided regular solid) centered at the --- modeling coordinates origin with a radius of 1.0. - -solidIcosahedron :: IO () -solidIcosahedron = glutSolidIcosahedron - --------------------------------------------------------------------------------- - --- | Render a solid octahedron (8-sided regular solid) centered at the modeling --- coordinates origin with a radius of 1.0. - -solidOctahedron :: IO () -solidOctahedron = glutSolidOctahedron - --- | Render a wireframe octahedron (8-sided regular solid) centered at the --- modeling coordinates origin with a radius of 1.0. - -wireOctahedron :: IO () -wireOctahedron = glutWireOctahedron - --------------------------------------------------------------------------------- - --- | Render a solid tetrahedron (4-sided regular solid) centered at the modeling --- coordinates origin with a radius of @sqrt 3@. - -wireTetrahedron :: IO () -wireTetrahedron = glutWireTetrahedron - --- | Render a wireframe tetrahedron (4-sided regular solid) centered at the --- modeling coordinates origin with a radius of @sqrt 3@. - -solidTetrahedron :: IO () -solidTetrahedron = glutSolidTetrahedron - --------------------------------------------------------------------------------- - --- | Render a solid sphere centered at the modeling coordinates origin of the --- specified radius. The sphere is subdivided around the Z axis into slices --- and along the Z axis into stacks. - -solidSphere - :: Radius -- ^ Radius of the sphere. - -> Slices -- ^ Number of subdivisions (slices) around the Z axis, similar - -- to lines of longitude. - -> Stacks -- ^ The number of subdivisions (stacks) along the Z axis, - -- similar to lines of latitude. - -> IO () -solidSphere = glutSolidSphere - --- | Render a wireframe sphere centered at the modeling coordinates origin of --- the specified radius. The sphere is subdivided around the Z axis into slices --- and along the Z axis into stacks. - -wireSphere - :: Radius -- ^ Radius of the sphere. - -> Slices -- ^ Number of subdivisions (slices) around the Z axis, similar - -- to lines of longitude. - -> Stacks -- ^ The number of subdivisions (stacks) along the Z axis, - -- similar to lines of latitude. - -> IO () -wireSphere = glutWireSphere - --------------------------------------------------------------------------------- - --- | Render a solid cone oriented along the Z axis. The base of the cone is --- placed at Z = 0, and the top at Z = height. The cone is subdivided around the --- Z axis into slices, and along the Z axis into stacks. - -solidCone - :: Radius -- ^ Radius of the base of the cone. - -> Height -- ^ Height of the cone. - -> Slices -- ^ Number of subdivisions around the Z axis. - -> Stacks -- ^ The number of subdivisions along the Z axis. - -> IO () -solidCone = glutSolidCone - --- | Render a wireframe cone oriented along the Z axis. The base of the cone is --- placed at Z = 0, and the top at Z = height. The cone is subdivided around the --- Z axis into slices, and along the Z axis into stacks. - -wireCone - :: Radius -- ^ Radius of the base of the cone. - -> Height -- ^ Height of the cone. - -> Slices -- ^ Number of subdivisions around the Z axis. - -> Stacks -- ^ The number of subdivisions along the Z axis. - -> IO () -wireCone = glutWireCone - --------------------------------------------------------------------------------- - --- | Render a solid torus (doughnut) centered at the modeling coordinates origin --- whose axis is aligned with the Z axis. - -solidTorus - :: Radius -- ^ Inner radius of the torus. - -> Radius -- ^ Outer radius of the torus. - -> Slices -- ^ Number of sides for each radial section. - -> Stacks -- ^ Number of radial divisions for the torus. - -> IO () -solidTorus = glutSolidTorus - --- | Render a wireframe torus (doughnut) centered at the modeling coordinates --- origin whose axis is aligned with the Z axis. - -wireTorus - :: Radius -- ^ Inner radius of the torus. - -> Radius -- ^ Outer radius of the torus. - -> Slices -- ^ Number of sides for each radial section. - -> Stacks -- ^ Number of radial divisions for the torus. - -> IO () -wireTorus = glutWireTorus - --------------------------------------------------------------------------------- - --- | Render a solid teapot. - -solidTeapot - :: Height -- ^ Relative size of the teapot - -> IO () -solidTeapot = glutSolidTeapot - --- | Render a wireframe teapot. - -wireTeapot - :: Height -- ^ Relative size of the teapot - -> IO () -wireTeapot = glutWireTeapot -------------------------------------------------------------------------------- diff --git a/Graphics/UI/GLUT/Raw/Callbacks.hs b/Graphics/UI/GLUT/Raw/Callbacks.hs --- a/Graphics/UI/GLUT/Raw/Callbacks.hs +++ b/Graphics/UI/GLUT/Raw/Callbacks.hs @@ -15,24 +15,31 @@ ----------------------------------------------------------------------------- module Graphics.UI.GLUT.Raw.Callbacks ( - MenuFunc, makeMenuFunc, + 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, @@ -50,10 +57,10 @@ import Foreign.C.Types import Foreign.Ptr -type MenuFunc = CInt -> IO () +type AppStatusFunc = CInt -> IO () foreign import ccall "wrapper" - makeMenuFunc :: MenuFunc -> IO (FunPtr MenuFunc) + makeAppStatusFunc :: AppStatusFunc -> IO (FunPtr AppStatusFunc) type ButtonBoxFunc = CInt -> CInt -> IO () @@ -85,6 +92,11 @@ 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" @@ -105,6 +117,11 @@ 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" @@ -130,6 +147,26 @@ 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" @@ -139,6 +176,11 @@ 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 () diff --git a/Graphics/UI/GLUT/Raw/Fonts.hs b/Graphics/UI/GLUT/Raw/Fonts.hs --- a/Graphics/UI/GLUT/Raw/Fonts.hs +++ b/Graphics/UI/GLUT/Raw/Fonts.hs @@ -15,15 +15,79 @@ ----------------------------------------------------------------------------- module Graphics.UI.GLUT.Raw.Fonts ( - hs_GLUT_marshalBitmapFont, - hs_GLUT_marshalStrokeFont + 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 --- a/Graphics/UI/GLUT/Raw/Functions.hs +++ b/Graphics/UI/GLUT/Raw/Functions.hs @@ -15,50 +15,48 @@ ----------------------------------------------------------------------------- module Graphics.UI.GLUT.Raw.Functions ( - glutGetProcAddress, - glutGetColor, - glutStrokeHeight, - glutBitmapHeight, - glutBitmapLength, - glutBitmapWidth, - glutCreateMenu, - glutCreateSubWindow, - glutCreateWindow, - glutDeviceGet, - glutEnterGameMode, - glutExtensionSupported, - glutGameModeGet, - glutGet, - glutGetMenu, - glutGetModifiers, - glutGetWindow, - glutLayerGet, - glutStrokeLength, - glutStrokeWidth, - glutVideoResizeGet, - glutGetModeValues, glutAddMenuEntry, glutAddSubMenu, + 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, @@ -66,8 +64,9 @@ glutIgnoreKeyRepeat, glutInit, glutInitContextFlags, - glutInitContextVersion, + glutInitContextFunc, glutInitContextProfile, + glutInitContextVersion, glutInitDisplayMode, glutInitDisplayString, glutInitWindowPosition, @@ -75,6 +74,8 @@ glutJoystickFunc, glutKeyboardFunc, glutKeyboardUpFunc, + glutLayerGet, + glutLeaveFullScreen, glutLeaveGameMode, glutLeaveMainLoop, glutMainLoop, @@ -85,9 +86,14 @@ glutMotionFunc, glutMouseFunc, glutMouseWheelFunc, + glutMultiButtonFunc, + glutMultiEntryFunc, + glutMultiMotionFunc, + glutMultiPassiveFunc, glutOverlayDisplayFunc, glutPassiveMotionFunc, glutPopWindow, + glutPositionFunc, glutPositionWindow, glutPostOverlayRedisplay, glutPostRedisplay, @@ -105,7 +111,11 @@ glutSetKeyRepeat, glutSetMenu, glutSetMenuData, + glutSetMenuFont, glutSetOption, + glutSetVertexAttribCoord3, + glutSetVertexAttribNormal, + glutSetVertexAttribTexCoord2, glutSetWindow, glutSetWindowData, glutSetWindowTitle, @@ -121,7 +131,9 @@ glutSolidRhombicDodecahedron, glutSolidSierpinskiSponge, glutSolidSphere, + glutSolidTeacup, glutSolidTeapot, + glutSolidTeaspoon, glutSolidTetrahedron, glutSolidTorus, glutSpaceballButtonFunc, @@ -131,7 +143,10 @@ glutSpecialUpFunc, glutStopVideoResizing, glutStrokeCharacter, + glutStrokeHeight, + glutStrokeLength, glutStrokeString, + glutStrokeWidth, glutSwapBuffers, glutTabletButtonFunc, glutTabletMotionFunc, @@ -139,6 +154,7 @@ glutUseLayer, glutVideoPan, glutVideoResize, + glutVideoResizeGet, glutVisibilityFunc, glutWMCloseFunc, glutWarpPointer, @@ -152,11 +168,11 @@ glutWireRhombicDodecahedron, glutWireSierpinskiSponge, glutWireSphere, + glutWireTeacup, glutWireTeapot, + glutWireTeaspoon, glutWireTetrahedron, - glutWireTorus, - glutGetMenuData, - glutGetWindowData + glutWireTorus ) where import Foreign.C.Types @@ -167,50 +183,48 @@ #include "HsGLUTExt.h" -API_ENTRY(glutGetProcAddress,Ptr CChar -> IO (FunPtr a)) -API_ENTRY(glutGetColor,CInt -> CInt -> IO GLfloat) -API_ENTRY(glutStrokeHeight,Ptr a -> IO GLfloat) -API_ENTRY(glutBitmapHeight,Ptr a -> IO CInt) -API_ENTRY(glutBitmapLength,Ptr a -> Ptr CUChar -> IO CInt) -API_ENTRY(glutBitmapWidth,Ptr a -> CInt -> IO CInt) -API_ENTRY(glutCreateMenu,FunPtr MenuFunc -> IO CInt) -API_ENTRY(glutCreateSubWindow,CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt) -API_ENTRY(glutCreateWindow,Ptr CChar -> IO CInt) -API_ENTRY(glutDeviceGet,GLenum -> IO CInt) -API_ENTRY(glutEnterGameMode,IO CInt) -API_ENTRY(glutExtensionSupported,Ptr CChar -> IO CInt) -API_ENTRY(glutGameModeGet,GLenum -> IO CInt) -API_ENTRY(glutGet,GLenum -> IO CInt) -API_ENTRY(glutGetMenu,IO CInt) -API_ENTRY(glutGetModifiers,IO CInt) -API_ENTRY(glutGetWindow,IO CInt) -API_ENTRY(glutLayerGet,GLenum -> IO CInt) -API_ENTRY(glutStrokeLength,Ptr a -> Ptr CUChar -> IO CInt) -API_ENTRY(glutStrokeWidth,Ptr a -> CInt -> IO CInt) -API_ENTRY(glutVideoResizeGet,GLenum -> IO CInt) -API_ENTRY(glutGetModeValues,GLenum -> Ptr CInt -> IO (Ptr CInt)) API_ENTRY(glutAddMenuEntry,Ptr CChar -> CInt -> IO ()) API_ENTRY(glutAddSubMenu,Ptr CChar -> CInt -> IO ()) +API_ENTRY(glutAppStatusFunc,FunPtr AppStatusFunc -> IO ()) API_ENTRY(glutAttachMenu,CInt -> IO ()) API_ENTRY(glutBitmapCharacter,Ptr a -> CInt -> IO ()) +API_ENTRY(glutBitmapHeight,Ptr a -> IO CInt) +API_ENTRY(glutBitmapLength,Ptr a -> Ptr CUChar -> IO CInt) API_ENTRY(glutBitmapString,Ptr a -> Ptr CUChar -> IO ()) +API_ENTRY(glutBitmapWidth,Ptr a -> CInt -> IO CInt) API_ENTRY(glutButtonBoxFunc,FunPtr ButtonBoxFunc -> IO ()) API_ENTRY(glutChangeToMenuEntry,CInt -> Ptr CChar -> CInt -> IO ()) API_ENTRY(glutChangeToSubMenu,CInt -> Ptr CChar -> CInt -> IO ()) API_ENTRY(glutCloseFunc,FunPtr CloseFunc -> IO ()) API_ENTRY(glutCopyColormap,CInt -> IO ()) +API_ENTRY(glutCreateMenu,FunPtr MenuFunc -> IO CInt) +API_ENTRY(glutCreateSubWindow,CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt) +API_ENTRY(glutCreateWindow,Ptr CChar -> IO CInt) API_ENTRY(glutDestroyMenu,CInt -> IO ()) API_ENTRY(glutDestroyWindow,CInt -> IO ()) API_ENTRY(glutDetachMenu,CInt -> IO ()) +API_ENTRY(glutDeviceGet,GLenum -> IO CInt) API_ENTRY(glutDialsFunc,FunPtr DialsFunc -> IO ()) API_ENTRY(glutDisplayFunc,FunPtr DisplayFunc -> IO ()) +API_ENTRY(glutEnterGameMode,IO CInt) API_ENTRY(glutEntryFunc,FunPtr EntryFunc -> IO ()) API_ENTRY_SAFE(glutEstablishOverlay,IO ()) API_ENTRY(glutExit,IO ()) +API_ENTRY(glutExtensionSupported,Ptr CChar -> IO CInt) API_ENTRY(glutForceJoystickFunc,IO ()) API_ENTRY(glutFullScreen,IO ()) API_ENTRY(glutFullScreenToggle,IO ()) +API_ENTRY(glutGameModeGet,GLenum -> IO CInt) API_ENTRY(glutGameModeString,Ptr CChar -> IO ()) +API_ENTRY(glutGet,GLenum -> IO CInt) +API_ENTRY(glutGetColor,CInt -> CInt -> IO GLfloat) +API_ENTRY(glutGetMenu,IO CInt) +API_ENTRY(glutGetMenuData,IO (Ptr a)) +API_ENTRY(glutGetModeValues,GLenum -> Ptr CInt -> IO (Ptr CInt)) +API_ENTRY(glutGetModifiers,IO CInt) +API_ENTRY(glutGetProcAddress,Ptr CChar -> IO (FunPtr a)) +API_ENTRY(glutGetWindow,IO CInt) +API_ENTRY(glutGetWindowData,IO (Ptr a)) API_ENTRY_SAFE(glutHideOverlay,IO ()) API_ENTRY(glutHideWindow,IO ()) API_ENTRY(glutIconifyWindow,IO ()) @@ -218,8 +232,9 @@ API_ENTRY(glutIgnoreKeyRepeat,CInt -> IO ()) API_ENTRY(glutInit,Ptr CInt -> Ptr (Ptr CChar) -> IO ()) API_ENTRY(glutInitContextFlags,CInt -> IO ()) -API_ENTRY(glutInitContextVersion,CInt -> CInt -> IO ()) +API_ENTRY(glutInitContextFunc,FunPtr InitContextFunc -> IO ()) API_ENTRY(glutInitContextProfile,CInt -> IO ()) +API_ENTRY(glutInitContextVersion,CInt -> CInt -> IO ()) API_ENTRY(glutInitDisplayMode,CUInt -> IO ()) API_ENTRY(glutInitDisplayString,Ptr CChar -> IO ()) API_ENTRY(glutInitWindowPosition,CInt -> CInt -> IO ()) @@ -227,6 +242,8 @@ API_ENTRY(glutJoystickFunc,FunPtr JoystickFunc -> CInt -> IO ()) API_ENTRY(glutKeyboardFunc,FunPtr KeyboardFunc -> IO ()) API_ENTRY(glutKeyboardUpFunc,FunPtr KeyboardUpFunc -> IO ()) +API_ENTRY(glutLayerGet,GLenum -> IO CInt) +API_ENTRY(glutLeaveFullScreen,IO ()) API_ENTRY(glutLeaveGameMode,IO ()) API_ENTRY_SAFE(glutLeaveMainLoop,IO ()) API_ENTRY_SAFE(glutMainLoop,IO ()) @@ -237,9 +254,14 @@ API_ENTRY(glutMotionFunc,FunPtr MotionFunc -> IO ()) API_ENTRY(glutMouseFunc,FunPtr MouseFunc -> IO ()) API_ENTRY(glutMouseWheelFunc,FunPtr MouseWheelFunc -> IO ()) +API_ENTRY(glutMultiButtonFunc,FunPtr MultiButtonFunc -> IO ()) +API_ENTRY(glutMultiEntryFunc,FunPtr MultiEntryFunc -> IO ()) +API_ENTRY(glutMultiMotionFunc,FunPtr MultiMotionFunc -> IO ()) +API_ENTRY(glutMultiPassiveFunc,FunPtr MultiPassiveFunc -> IO ()) API_ENTRY(glutOverlayDisplayFunc,FunPtr OverlayDisplayFunc -> IO ()) API_ENTRY(glutPassiveMotionFunc,FunPtr PassiveMotionFunc -> IO ()) API_ENTRY(glutPopWindow,IO ()) +API_ENTRY(glutPositionFunc,FunPtr PositionFunc -> IO ()) API_ENTRY(glutPositionWindow,CInt -> CInt -> IO ()) API_ENTRY_SAFE(glutPostOverlayRedisplay,IO ()) API_ENTRY(glutPostRedisplay,IO ()) @@ -257,7 +279,11 @@ API_ENTRY(glutSetKeyRepeat,CInt -> IO ()) API_ENTRY(glutSetMenu,CInt -> IO ()) API_ENTRY(glutSetMenuData,Ptr a -> IO ()) +API_ENTRY(glutSetMenuFont,GLint -> Ptr a -> IO ()) API_ENTRY(glutSetOption,GLenum -> CInt -> IO ()) +API_ENTRY(glutSetVertexAttribCoord3,GLint -> IO ()) +API_ENTRY(glutSetVertexAttribNormal,GLint -> IO ()) +API_ENTRY(glutSetVertexAttribTexCoord2,GLint -> IO ()) API_ENTRY(glutSetWindow,CInt -> IO ()) API_ENTRY(glutSetWindowData,Ptr a -> IO ()) API_ENTRY(glutSetWindowTitle,Ptr CChar -> IO ()) @@ -273,7 +299,9 @@ API_ENTRY(glutSolidRhombicDodecahedron,IO ()) API_ENTRY(glutSolidSierpinskiSponge,CInt -> Ptr GLdouble -> GLdouble -> IO ()) API_ENTRY(glutSolidSphere,GLdouble -> GLint -> GLint -> IO ()) +API_ENTRY(glutSolidTeacup,GLdouble -> IO ()) API_ENTRY(glutSolidTeapot,GLdouble -> IO ()) +API_ENTRY(glutSolidTeaspoon,GLdouble -> IO ()) API_ENTRY(glutSolidTetrahedron,IO ()) API_ENTRY(glutSolidTorus,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) API_ENTRY(glutSpaceballButtonFunc,FunPtr SpaceballButtonFunc -> IO ()) @@ -283,7 +311,10 @@ API_ENTRY(glutSpecialUpFunc,FunPtr SpecialUpFunc -> IO ()) API_ENTRY(glutStopVideoResizing,IO ()) API_ENTRY(glutStrokeCharacter,Ptr a -> CInt -> IO ()) +API_ENTRY(glutStrokeHeight,Ptr a -> IO GLfloat) +API_ENTRY(glutStrokeLength,Ptr a -> Ptr CUChar -> IO CInt) API_ENTRY(glutStrokeString,Ptr a -> Ptr CUChar -> IO ()) +API_ENTRY(glutStrokeWidth,Ptr a -> CInt -> IO CInt) API_ENTRY(glutSwapBuffers,IO ()) API_ENTRY(glutTabletButtonFunc,FunPtr TabletButtonFunc -> IO ()) API_ENTRY(glutTabletMotionFunc,FunPtr TabletMotionFunc -> IO ()) @@ -291,6 +322,7 @@ API_ENTRY_SAFE(glutUseLayer,GLenum -> IO ()) API_ENTRY(glutVideoPan,CInt -> CInt -> CInt -> CInt -> IO ()) API_ENTRY(glutVideoResize,CInt -> CInt -> CInt -> CInt -> IO ()) +API_ENTRY(glutVideoResizeGet,GLenum -> IO CInt) API_ENTRY(glutVisibilityFunc,FunPtr VisibilityFunc -> IO ()) API_ENTRY(glutWMCloseFunc,FunPtr WMCloseFunc -> IO ()) API_ENTRY(glutWarpPointer,CInt -> CInt -> IO ()) @@ -304,8 +336,8 @@ API_ENTRY(glutWireRhombicDodecahedron,IO ()) API_ENTRY(glutWireSierpinskiSponge,CInt -> Ptr GLdouble -> GLdouble -> IO ()) API_ENTRY(glutWireSphere,GLdouble -> GLint -> GLint -> IO ()) +API_ENTRY(glutWireTeacup,GLdouble -> IO ()) API_ENTRY(glutWireTeapot,GLdouble -> IO ()) +API_ENTRY(glutWireTeaspoon,GLdouble -> IO ()) API_ENTRY(glutWireTetrahedron,IO ()) API_ENTRY(glutWireTorus,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(glutGetMenuData,IO (Ptr a)) -API_ENTRY(glutGetWindowData,IO (Ptr a)) diff --git a/Graphics/UI/GLUT/Raw/Tokens.hs b/Graphics/UI/GLUT/Raw/Tokens.hs --- a/Graphics/UI/GLUT/Raw/Tokens.hs +++ b/Graphics/UI/GLUT/Raw/Tokens.hs @@ -48,6 +48,12 @@ 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 @@ -219,6 +225,9 @@ 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 @@ -300,9 +309,21 @@ 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 @@ -378,6 +399,12 @@ 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 @@ -476,6 +503,9 @@ glut_SINGLE :: CUInt glut_SINGLE = 0x0000 + +glut_SKIP_STALE_MOTION_EVENTS :: GLenum +glut_SKIP_STALE_MOTION_EVENTS = 0x0204 glut_SRGB :: CUInt glut_SRGB = 0x1000 diff --git a/Graphics/UI/GLUT/State.hs b/Graphics/UI/GLUT/State.hs --- a/Graphics/UI/GLUT/State.hs +++ b/Graphics/UI/GLUT/State.hs @@ -15,17 +15,27 @@ module Graphics.UI.GLUT.State ( -- * State of all windows - windowBorderWidth, windowHeaderHeight, + 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, - -- * GLUT state pertaining to the layers of the /current window/ + -- ** Object rendering state + geometryVisualizeNormals, + + -- ** Vertex attribute state + vertexAttribCoord3, vertexAttribNormal, vertexAttribTexCoord2, + + -- ** Layer state damaged, -- * Timing @@ -53,9 +63,7 @@ import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable -import Graphics.Rendering.OpenGL ( GLenum, Size(..) - , StateVar, makeStateVar - , GettableStateVar, makeGettableStateVar ) +import Graphics.Rendering.OpenGL import Graphics.UI.GLUT.Overlay import Graphics.UI.GLUT.QueryUtils import Graphics.UI.GLUT.Raw @@ -168,6 +176,47 @@ -------------------------------------------------------------------------------- +-- | (/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. @@ -316,11 +365,15 @@ fmap (map fromIntegral) $ peekArray (fromIntegral size) valuesBuffer -------------------------------------------------------------------------------- --- Convenience unmarshalers +-- Convenience (un-)marshalers i2b :: CInt -> Bool i2b = (/= 0) +b2i :: Bool -> CInt +b2i False = 0 +b2i True = 1 + -------------------------------------------------------------------------------- getDeviceInfo :: GLenum -> IO a -> GettableStateVar (Maybe a) @@ -369,6 +422,17 @@ 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) ----------------------------------------------------------------------------- diff --git a/Graphics/UI/GLUT/Window.hs b/Graphics/UI/GLUT/Window.hs --- a/Graphics/UI/GLUT/Window.hs +++ b/Graphics/UI/GLUT/Window.hs @@ -33,7 +33,7 @@ -- * Changing the window geometry -- $ChangingTheWindowGeometry - windowPosition, windowSize, fullScreen, fullScreenToggle, + windowPosition, windowSize, fullScreen, fullScreenToggle, leaveFullScreen, -- * Manipulating the stacking order @@ -295,6 +295,14 @@ 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 --------------------------------------------------------------------------------