GLUT 2.1.2.2 → 2.2.0.0
raw patch · 24 files changed
+422/−241 lines, 24 filesdep +StateVardep +Tensordep ~OpenGL
Dependencies added: StateVar, Tensor
Dependency ranges changed: OpenGL
Files
- GLUT.cabal +5/−5
- Graphics/UI/GLUT/Begin.hs +4/−6
- Graphics/UI/GLUT/Callbacks/Global.hs +7/−9
- Graphics/UI/GLUT/Callbacks/Registration.hs +7/−7
- Graphics/UI/GLUT/Callbacks/Window.hs +10/−23
- Graphics/UI/GLUT/Colormap.hs +6/−10
- Graphics/UI/GLUT/Constants.hs +2/−2
- Graphics/UI/GLUT/Debugging.hs +4/−4
- Graphics/UI/GLUT/DeviceControl.hs +4/−6
- Graphics/UI/GLUT/Fonts.hs +5/−5
- Graphics/UI/GLUT/GameMode.hs +9/−16
- Graphics/UI/GLUT/Initialization.hs +15/−33
- Graphics/UI/GLUT/Menu.hs +14/−17
- Graphics/UI/GLUT/Objects.hs +5/−6
- Graphics/UI/GLUT/Overlay.hs +5/−13
- Graphics/UI/GLUT/QueryUtils.hs +2/−2
- Graphics/UI/GLUT/State.hs +12/−36
- Graphics/UI/GLUT/Window.hs +7/−21
- examples/Misc/SmoothOpenGL3.hs +266/−0
- examples/Misc/Triangulate.hs +8/−6
- examples/RedBook/MultiTex.hs +7/−5
- examples/RedBook/PickSquare.hs +4/−2
- examples/RedBook/PointP.hs +12/−5
- examples/RedBook/SurfPoints.hs +2/−2
GLUT.cabal view
@@ -1,5 +1,5 @@ name: GLUT-version: 2.1.2.2+version: 2.2.0.0 license: BSD3 license-file: LICENSE maintainer: Sven Panne <sven.panne@aedion.de>@@ -35,6 +35,7 @@ examples/Misc/ExtractContours.hs examples/Misc/Gears.hs examples/Misc/Pitfall14.hs+ examples/Misc/SmoothOpenGL3.hs examples/Misc/Triangulate.hs examples/OrangeBook/3Dlabs-License.txt examples/OrangeBook/ogl2brick/Brick.frag@@ -153,9 +154,8 @@ install-includes: HsGLUT.h c-sources: cbits/HsGLUT.c if flag(split-base)- build-depends: base >= 3 && <5, array, containers+ build-depends: base >= 3 && <5, array, containers else- build-depends: base < 3- build-depends: OpenGL >= 2.2+ build-depends: base < 3+ build-depends: OpenGL >= 2.3, StateVar, Tensor extensions: CPP, ForeignFunctionInterface- extra-libraries: glut
Graphics/UI/GLUT/Begin.hs view
@@ -22,12 +22,10 @@ ActionOnWindowClose(..), actionOnWindowClose ) where -import Foreign.C.Types ( CInt )-import Graphics.Rendering.OpenGL.GL.StateVar ( StateVar, makeStateVar )-import Graphics.UI.GLUT.Constants (- glut_ACTION_ON_WINDOW_CLOSE, glut_ACTION_EXIT,- glut_ACTION_GLUTMAINLOOP_RETURNS, glut_ACTION_CONTINUE_EXECUTION )-import Graphics.UI.GLUT.QueryUtils ( simpleGet, glutSetOption )+import Data.StateVar+import Foreign.C.Types+import Graphics.UI.GLUT.Constants+import Graphics.UI.GLUT.QueryUtils import Graphics.UI.GLUT.Extensions --------------------------------------------------------------------------------
Graphics/UI/GLUT/Callbacks/Global.hs view
@@ -21,15 +21,13 @@ Timeout, TimerCallback, addTimerCallback ) where -import Control.Monad.Fix ( MonadFix(..) )-import Foreign.C.Types ( CInt, CUInt )-import Foreign.Ptr ( FunPtr )-import Graphics.Rendering.OpenGL.GL.CoordTrans ( Position(..) )-import Graphics.Rendering.OpenGL.GL.StateVar (- SettableStateVar, makeSettableStateVar )-import Graphics.UI.GLUT.Constants ( glut_MENU_NOT_IN_USE, glut_MENU_IN_USE )-import Graphics.UI.GLUT.Callbacks.Registration (- CallbackType(..), setCallback, registerForCleanup )+import Control.Monad.Fix+import Data.StateVar+import Foreign.C.Types+import Foreign.Ptr+import Graphics.Rendering.OpenGL ( Position(..) )+import Graphics.UI.GLUT.Constants+import Graphics.UI.GLUT.Callbacks.Registration --------------------------------------------------------------------------------
Graphics/UI/GLUT/Callbacks/Registration.hs view
@@ -19,15 +19,15 @@ -------------------------------------------------------------------------------- -import Control.Monad ( when )-import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef )+import Control.Monad+import Data.IORef import qualified Data.Map as Map ( empty, lookup, insert, delete ) import Data.Map ( Map )-import Foreign.C.Types ( CInt, CUInt )-import Foreign.Ptr ( FunPtr, nullFunPtr, freeHaskellFunPtr )-import System.IO.Unsafe ( unsafePerformIO )-import Graphics.Rendering.OpenGL.GL.StateVar ( HasGetter(get) )-import Graphics.UI.GLUT.Window ( Window, currentWindow )+import Data.StateVar+import Foreign.C.Types+import Foreign.Ptr+import Graphics.UI.GLUT.Window+import System.IO.Unsafe -------------------------------------------------------------------------------- -- No timer callback here, because they are one-shot and "self destroy"
Graphics/UI/GLUT/Callbacks/Window.hs view
@@ -51,29 +51,16 @@ JoystickCallback, joystickCallback ) where -import Data.Bits ( Bits((.&.)) )-import Data.Char ( chr )-import Data.Maybe ( fromJust )-import Foreign.C.Types ( CInt, CUInt, CUChar )-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_HIDDEN, glut_FULLY_RETAINED, glut_PARTIALLY_RETAINED, glut_FULLY_COVERED,- 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_KEY_NUM_LOCK, glut_KEY_BEGIN, glut_KEY_DELETE,- 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 )+import Data.Bits hiding ( shift )+import Data.Char+import Data.Maybe+import Data.StateVar+import Foreign.C.Types+import Graphics.Rendering.OpenGL ( Position(..), Size(..) )+import Graphics.UI.GLUT.Callbacks.Registration+import Graphics.UI.GLUT.Constants+import Graphics.UI.GLUT.State+import Graphics.UI.GLUT.Types import Graphics.UI.GLUT.Extensions --------------------------------------------------------------------------------
Graphics/UI/GLUT/Colormap.hs view
@@ -41,16 +41,12 @@ transparentIndex ) where -import Foreign.C.Types ( CInt )-import Graphics.Rendering.OpenGL.GL.BasicTypes ( GLint, GLfloat )-import Graphics.Rendering.OpenGL.GL.StateVar (- GettableStateVar, makeGettableStateVar, StateVar, makeStateVar )-import Graphics.Rendering.OpenGL.GL.VertexSpec ( Color3(..), Index1(..) )-import Graphics.UI.GLUT.Constants (- glut_RED, glut_GREEN, glut_BLUE,- glut_WINDOW_COLORMAP_SIZE, glut_TRANSPARENT_INDEX )-import Graphics.UI.GLUT.QueryUtils ( simpleGet, layerGet )-import Graphics.UI.GLUT.Window ( Window )+import Data.StateVar+import Foreign.C.Types+import Graphics.Rendering.OpenGL ( GLfloat, GLint, Color3(..), Index1(..) )+import Graphics.UI.GLUT.Constants+import Graphics.UI.GLUT.QueryUtils+import Graphics.UI.GLUT.Window --------------------------------------------------------------------------------
Graphics/UI/GLUT/Constants.hs view
@@ -15,8 +15,8 @@ module Graphics.UI.GLUT.Constants where -import Foreign.C.Types ( CInt, CUInt )-import Graphics.Rendering.OpenGL.GL.BasicTypes ( GLenum )+import Foreign.C.Types+import Graphics.Rendering.OpenGL ( GLenum ) ----------------------------------------------------------------------------- -- * Display mode bit masks
Graphics/UI/GLUT/Debugging.hs view
@@ -17,10 +17,10 @@ reportErrors ) where -import System.Environment ( getProgName )-import System.IO ( hPutStrLn, stderr )-import Graphics.Rendering.OpenGL.GL.StateVar ( HasGetter(get) )-import Graphics.Rendering.OpenGL.GLU.Errors ( Error(..), errors )+import Data.StateVar+import System.Environment+import System.IO+import Graphics.Rendering.OpenGL ( Error(..), errors ) --------------------------------------------------------------------------------
Graphics/UI/GLUT/DeviceControl.hs view
@@ -19,12 +19,10 @@ forceJoystickCallback ) where -import Foreign.C.Types ( CInt )-import Graphics.Rendering.OpenGL.GL.StateVar ( StateVar, makeStateVar )-import Graphics.UI.GLUT.Constants (- glut_KEY_REPEAT_OFF, glut_KEY_REPEAT_ON, glut_KEY_REPEAT_DEFAULT,- glut_DEVICE_KEY_REPEAT, glut_DEVICE_IGNORE_KEY_REPEAT )-import Graphics.UI.GLUT.QueryUtils ( deviceGet )+import Data.StateVar+import Foreign.C.Types+import Graphics.UI.GLUT.Constants+import Graphics.UI.GLUT.QueryUtils --------------------------------------------------------------------------------
Graphics/UI/GLUT/Fonts.hs view
@@ -22,11 +22,11 @@ Font(..), BitmapFont(..), StrokeFont(..), ) where -import Data.Char ( ord )-import Foreign.C.String ( CString, withCString )-import Foreign.C.Types ( CInt )-import Foreign.Ptr ( Ptr )-import Graphics.Rendering.OpenGL.GL.BasicTypes ( GLint, GLfloat )+import Data.Char+import Foreign.C.String+import Foreign.C.Types+import Foreign.Ptr+import Graphics.Rendering.OpenGL ( GLint, GLfloat ) import Graphics.UI.GLUT.Extensions #ifdef __HUGS__
Graphics/UI/GLUT/GameMode.hs view
@@ -30,22 +30,15 @@ gameModeActive ) where -import Data.List ( intersperse )-import Foreign.C.String ( CString, withCString )-import Foreign.C.Types ( CInt )-import Graphics.Rendering.OpenGL.GL.BasicTypes ( GLenum )-import Graphics.Rendering.OpenGL.GL.CoordTrans ( Size(..) )-import Graphics.Rendering.OpenGL.GL.StateVar (- GettableStateVar, makeGettableStateVar,- SettableStateVar, makeSettableStateVar )-import Graphics.UI.GLUT.Constants (- glut_GAME_MODE_DISPLAY_CHANGED, glut_GAME_MODE_POSSIBLE,- glut_GAME_MODE_WIDTH, glut_GAME_MODE_HEIGHT,- glut_GAME_MODE_PIXEL_DEPTH, glut_GAME_MODE_REFRESH_RATE,- glut_GAME_MODE_ACTIVE )-import Graphics.UI.GLUT.Types ( makeWindow, relationToString )-import Graphics.UI.GLUT.Window ( Window )-import Graphics.UI.GLUT.Initialization ( Relation(..) )+import Data.List+import Data.StateVar+import Foreign.C.String+import Foreign.C.Types+import Graphics.Rendering.OpenGL ( GLenum, Size(..) )+import Graphics.UI.GLUT.Constants+import Graphics.UI.GLUT.Types+import Graphics.UI.GLUT.Window+import Graphics.UI.GLUT.Initialization --------------------------------------------------------------------------------
Graphics/UI/GLUT/Initialization.hs view
@@ -48,40 +48,22 @@ initialContextVersion, ContextFlag(..), initialContextFlags ) where -import Control.Monad ( when )-import Data.Bits ( Bits((.|.),(.&.)), complement )-import Data.List ( genericLength, intersperse, mapAccumR )-import Foreign.C.String ( CString, withCString, peekCString )-import Foreign.C.Types ( CInt, CUInt )-import Foreign.Marshal.Array ( withArray0, peekArray )-import Foreign.Marshal.Utils ( with, withMany )-import Foreign.Ptr ( Ptr, nullPtr, nullFunPtr )-import Foreign.Storable ( Storable(..) )-import System.Environment ( getProgName, getArgs )-import Graphics.Rendering.OpenGL.GL.CoordTrans ( Position(..), Size(..) )-import Graphics.Rendering.OpenGL.GL.StateVar (- GettableStateVar, makeGettableStateVar,- SettableStateVar, makeSettableStateVar,- StateVar, makeStateVar, HasGetter(..), HasSetter(..) )-import Graphics.UI.GLUT.Constants (- glut_INIT_WINDOW_X, glut_INIT_WINDOW_Y,- glut_INIT_WINDOW_WIDTH, glut_INIT_WINDOW_HEIGHT,- glut_RGBA, glut_RGB, glut_INDEX, glut_LUMINANCE,- glut_ALPHA, glut_ACCUM, glut_DEPTH, glut_STENCIL,- glut_AUX1, glut_AUX2, glut_AUX3, glut_AUX4,- glut_SINGLE, glut_DOUBLE, glut_MULTISAMPLE, glut_STEREO,- glut_CAPTIONLESS, glut_BORDERLESS,- glut_INIT_DISPLAY_MODE,- glut_DISPLAY_MODE_POSSIBLE,- glut_RENDERING_CONTEXT, glut_CREATE_NEW_CONTEXT, glut_USE_CURRENT_CONTEXT,- glut_DIRECT_RENDERING,- glut_FORCE_INDIRECT_CONTEXT, glut_ALLOW_DIRECT_CONTEXT,- glut_TRY_DIRECT_CONTEXT, glut_FORCE_DIRECT_CONTEXT,- glut_INIT_MAJOR_VERSION, glut_INIT_MINOR_VERSION,- glut_DEBUG, glut_FORWARD_COMPATIBLE, glut_INIT_FLAGS )+import Control.Monad+import Data.Bits+import Data.List+import Data.StateVar+import Foreign.C.String+import Foreign.C.Types+import Foreign.Marshal.Array+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.Storable+import System.Environment+import Graphics.Rendering.OpenGL ( Position(..), Size(..) )+import Graphics.UI.GLUT.Constants import Graphics.UI.GLUT.Extensions-import Graphics.UI.GLUT.QueryUtils ( simpleGet, glutSetOption )-import Graphics.UI.GLUT.Types ( Relation(..), relationToString )+import Graphics.UI.GLUT.QueryUtils+import Graphics.UI.GLUT.Types --------------------------------------------------------------------------------
Graphics/UI/GLUT/Menu.hs view
@@ -22,25 +22,22 @@ numMenuItems ) where -import Data.Array ( listArray, (!) )-import Data.IORef ( IORef, newIORef, readIORef, modifyIORef )+import Data.Array+import Data.IORef import qualified Data.Map as Map ( empty, lookup, insert, delete ) import Data.Map ( Map )-import Foreign.C.String ( CString, withCString )-import Foreign.C.Types ( CInt )-import Foreign.Ptr ( FunPtr, freeHaskellFunPtr )-import Control.Monad ( unless, zipWithM, when )-import System.IO.Unsafe ( unsafePerformIO )-import Graphics.Rendering.OpenGL.GL.StateVar (- HasGetter(get), HasSetter(($=)),- GettableStateVar, makeGettableStateVar,- StateVar, makeStateVar )-import Graphics.UI.GLUT.Constants ( glut_MENU_NUM_ITEMS )-import Graphics.UI.GLUT.QueryUtils ( simpleGet )-import Graphics.UI.GLUT.Types ( marshalMouseButton )-import Graphics.UI.GLUT.Window ( Window )-import Graphics.UI.GLUT.Callbacks.Registration ( getCurrentWindow )-import Graphics.UI.GLUT.Callbacks.Window ( MouseButton )+import Data.StateVar+import Foreign.C.String+import Foreign.C.Types+import Foreign.Ptr+import Control.Monad+import System.IO.Unsafe+import Graphics.UI.GLUT.Constants+import Graphics.UI.GLUT.QueryUtils+import Graphics.UI.GLUT.Types+import Graphics.UI.GLUT.Window+import Graphics.UI.GLUT.Callbacks.Registration+import Graphics.UI.GLUT.Callbacks.Window --------------------------------------------------------------------------------
Graphics/UI/GLUT/Objects.hs view
@@ -33,12 +33,11 @@ renderObject ) where -import Foreign.C.Types ( CInt )-import Foreign.Marshal.Utils ( with )-import Foreign.Ptr ( Ptr )-import Graphics.Rendering.OpenGL.GL.BasicTypes ( GLint, GLdouble )-import Graphics.Rendering.OpenGL.GL.VertexSpec ( Vertex3(..) )-import Graphics.Rendering.OpenGL.GLU.Quadrics ( Radius, Height, Slices, Stacks )+import Data.Tensor+import Foreign.C.Types+import Foreign.Marshal.Utils+import Foreign.Ptr+import Graphics.Rendering.OpenGL ( Height, Radius, Slices, Stacks, GLint, GLdouble ) import Graphics.UI.GLUT.Extensions --------------------------------------------------------------------------------
Graphics/UI/GLUT/Overlay.hs view
@@ -30,19 +30,11 @@ postOverlayRedisplay ) where -import Graphics.Rendering.OpenGL.GL.BasicTypes ( GLenum )-import Graphics.Rendering.OpenGL.GL.StateVar (- GettableStateVar, makeGettableStateVar,- SettableStateVar, makeSettableStateVar,- StateVar, makeStateVar )-import Graphics.UI.GLUT.Constants (- glut_OVERLAY_POSSIBLE, glut_HAS_OVERLAY, glut_NORMAL, glut_OVERLAY,- glut_LAYER_IN_USE )-import Graphics.UI.GLUT.QueryUtils ( layerGet )-#ifdef __NHC__-import NHC.FFI ( CInt )-#endif-import Graphics.UI.GLUT.Window ( Window )+import Data.StateVar+import Graphics.Rendering.OpenGL ( GLenum )+import Graphics.UI.GLUT.Constants+import Graphics.UI.GLUT.QueryUtils+import Graphics.UI.GLUT.Window --------------------------------------------------------------------------------
Graphics/UI/GLUT/QueryUtils.hs view
@@ -17,8 +17,8 @@ Getter, simpleGet, layerGet, deviceGet, glutSetOption ) where -import Foreign.C.Types ( CInt )-import Graphics.Rendering.OpenGL.GL.BasicTypes ( GLenum )+import Foreign.C.Types+import Graphics.Rendering.OpenGL ( GLenum ) import Graphics.UI.GLUT.Extensions --------------------------------------------------------------------------------
Graphics/UI/GLUT/State.hs view
@@ -47,42 +47,18 @@ glutVersion, initState ) where -import Control.Monad ( unless )-import Foreign.C.Types ( CInt )-import Foreign.Marshal.Alloc ( alloca )-import Foreign.Marshal.Array ( peekArray )-import Foreign.Ptr ( Ptr, nullFunPtr )-import Foreign.Storable ( Storable(..) )-import Graphics.Rendering.OpenGL.GL.BasicTypes ( GLenum )-import Graphics.Rendering.OpenGL.GL.CoordTrans ( Size(..) )-import Graphics.Rendering.OpenGL.GL.StateVar (- StateVar, makeStateVar, GettableStateVar, makeGettableStateVar )-import Graphics.UI.GLUT.Constants (- glut_WINDOW_RGBA,- glut_WINDOW_RED_SIZE, glut_WINDOW_GREEN_SIZE, glut_WINDOW_BLUE_SIZE,- glut_WINDOW_ALPHA_SIZE, glut_WINDOW_BUFFER_SIZE,- glut_WINDOW_DOUBLEBUFFER, glut_WINDOW_STEREO,- glut_WINDOW_ACCUM_RED_SIZE, glut_WINDOW_ACCUM_GREEN_SIZE,- glut_WINDOW_ACCUM_BLUE_SIZE, glut_WINDOW_ACCUM_ALPHA_SIZE,- glut_WINDOW_DEPTH_SIZE, glut_WINDOW_STENCIL_SIZE, glut_WINDOW_NUM_SAMPLES,- glut_WINDOW_FORMAT_ID, glut_ELAPSED_TIME,- glut_NORMAL_DAMAGED, glut_OVERLAY_DAMAGED,- glut_SCREEN_WIDTH, glut_SCREEN_HEIGHT,- glut_SCREEN_WIDTH_MM, glut_SCREEN_HEIGHT_MM,- glut_FULL_SCREEN,- glut_HAS_KEYBOARD,- glut_HAS_MOUSE, glut_NUM_MOUSE_BUTTONS,- glut_HAS_SPACEBALL, glut_NUM_SPACEBALL_BUTTONS,- glut_HAS_DIAL_AND_BUTTON_BOX, glut_NUM_DIALS, glut_NUM_BUTTON_BOX_BUTTONS,- glut_HAS_TABLET, glut_NUM_TABLET_BUTTONS,- glut_HAS_JOYSTICK, glut_JOYSTICK_BUTTONS, glut_JOYSTICK_POLL_RATE,- glut_JOYSTICK_AXES,- glut_AUX, glut_MULTISAMPLE,- glut_VERSION, glut_WINDOW_BORDER_WIDTH, glut_WINDOW_HEADER_HEIGHT,- glut_INIT_STATE )-import Graphics.UI.GLUT.Overlay ( Layer(..) )-import Graphics.UI.GLUT.QueryUtils ( simpleGet, layerGet, deviceGet )-import Graphics.UI.GLUT.Window ( fullScreenToggle )+import Control.Monad+import Data.StateVar+import Foreign.C.Types+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable+import Graphics.Rendering.OpenGL ( GLenum, Size(..) )+import Graphics.UI.GLUT.Constants+import Graphics.UI.GLUT.Overlay+import Graphics.UI.GLUT.QueryUtils+import Graphics.UI.GLUT.Window import Graphics.UI.GLUT.Extensions --------------------------------------------------------------------------------
Graphics/UI/GLUT/Window.hs view
@@ -52,28 +52,14 @@ Cursor(..), cursor, pointerPosition ) where -import Foreign.C.String ( CString, withCString )-import Foreign.C.Types ( CInt )-import Graphics.Rendering.OpenGL.GL.CoordTrans ( Position(..), Size(..) )-import Graphics.Rendering.OpenGL.GL.StateVar (- GettableStateVar, makeGettableStateVar,- SettableStateVar, makeSettableStateVar,- StateVar, makeStateVar )-import Graphics.UI.GLUT.Constants (- glut_WINDOW_PARENT, glut_WINDOW_NUM_CHILDREN,- glut_WINDOW_X, glut_WINDOW_Y, glut_WINDOW_WIDTH, glut_WINDOW_HEIGHT,- glut_CURSOR_RIGHT_ARROW, glut_CURSOR_LEFT_ARROW, glut_CURSOR_INFO,- glut_CURSOR_DESTROY, glut_CURSOR_HELP, glut_CURSOR_CYCLE, glut_CURSOR_SPRAY,- glut_CURSOR_WAIT, glut_CURSOR_TEXT, glut_CURSOR_CROSSHAIR,- glut_CURSOR_UP_DOWN, glut_CURSOR_LEFT_RIGHT, glut_CURSOR_TOP_SIDE,- glut_CURSOR_BOTTOM_SIDE, glut_CURSOR_LEFT_SIDE, glut_CURSOR_RIGHT_SIDE,- glut_CURSOR_TOP_LEFT_CORNER, glut_CURSOR_TOP_RIGHT_CORNER,- glut_CURSOR_BOTTOM_RIGHT_CORNER, glut_CURSOR_BOTTOM_LEFT_CORNER,- glut_CURSOR_INHERIT, glut_CURSOR_NONE, glut_CURSOR_FULL_CROSSHAIR,- glut_WINDOW_CURSOR )+import Data.StateVar+import Foreign.C.String+import Foreign.C.Types+import Graphics.Rendering.OpenGL ( Position(..), Size(..) )+import Graphics.UI.GLUT.Constants import Graphics.UI.GLUT.Extensions-import Graphics.UI.GLUT.QueryUtils ( simpleGet )-import Graphics.UI.GLUT.Types ( Window, makeWindow )+import Graphics.UI.GLUT.QueryUtils+import Graphics.UI.GLUT.Types --------------------------------------------------------------------------------
+ examples/Misc/SmoothOpenGL3.hs view
@@ -0,0 +1,266 @@+{-+ SmoothOpenGL3.hs (adapted from freeglut's smooth_opengl3.c example)+ Copyright (c) Sven Panne 2009 <sven.panne@aedion.de>+ This file is part of HOpenGL and distributed under a BSD-style license+ See the file LICENSE+-}++import Control.Monad+import Data.List+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable+import Graphics.Rendering.OpenGL.Raw.Core31+import Graphics.UI.GLUT+import System.Exit+import System.IO++data State = State {+ vertexBufferName :: BufferObject,+ fgProjectionMatrixIndex :: UniformLocation,+ fgColorIndex :: AttribLocation ,+ fgVertexIndex :: AttribLocation,+ projectionMatrix :: GLmatrix GLfloat }++checkError :: String -> IO ()+checkError functionName = get errors >>= mapM_ reportError+ where reportError e = + hPutStrLn stderr (showError e ++ " detected in " ++ functionName)+ showError (Error category message) =+ "GL error" ++ show category ++ " (" ++ message ++ ")"++varray :: [GLfloat]+varray = [+ 1, 0, 0, -- red+ 5, 5, -- lower left++ 0, 1, 0, -- green+ 25, 5, -- lower right++ 0, 0, 1, -- blue+ 5, 25 ] -- upper left++numColorComponents :: NumComponents+numColorComponents = 3++numVertexComponents :: NumComponents+numVertexComponents = 2++sizeOfComponent :: Int+sizeOfComponent = sizeOf (head varray)++stride :: Stride+stride = fromIntegral sizeOfComponent * fromIntegral (numColorComponents + numVertexComponents)++sizeOfVarray :: Int+sizeOfVarray = length varray * sizeOfComponent++numElements :: NumArrayIndices+numElements = fromIntegral sizeOfVarray `div` fromIntegral stride++initBuffer :: IO BufferObject+initBuffer = do+ [bufferObject] <- genObjectNames 1+ bindBuffer ArrayBuffer $= Just bufferObject+ withArray varray $ \buffer ->+ bufferData ArrayBuffer $= (fromIntegral sizeOfVarray, buffer, StaticDraw)+ checkError "initBuffer"+ return bufferObject++vertexShaderSource :: String+vertexShaderSource = unlines [+ "#version 140",+ "uniform mat4 fg_ProjectionMatrix;",+ "in vec4 fg_Color;",+ "in vec4 fg_Vertex;",+ "smooth out vec4 fg_SmoothColor;",+ "void main()",+ "{",+ " fg_SmoothColor = fg_Color;",+ " gl_Position = fg_ProjectionMatrix * fg_Vertex;",+ "}" ]++fragmentShaderSource :: String+fragmentShaderSource = unlines [+ "#version 140",+ "smooth in vec4 fg_SmoothColor;",+ "out vec4 fg_FragColor;",+ "void main(void)",+ "{",+ " fg_FragColor = fg_SmoothColor;",+ "}" ]++checked :: (t -> IO ()) -> (t -> GettableStateVar Bool) -> (t -> GettableStateVar String) -> String -> t -> IO ()+checked action getStatus getInfoLog message object = do+ action object+ status <- get (getStatus object)+ unless status $+ hPutStrLn stderr . ((message ++ " log: ") ++) =<< get (getInfoLog object)++compileAndCheck :: Shader s => s -> IO ()+compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile"++compileShaderSource :: Shader s => [String] -> IO s+compileShaderSource source = do+ [shader] <- genObjectNames 1+ shaderSource shader $= source+ compileAndCheck shader+ return shader++linkAndCheck :: Program -> IO ()+linkAndCheck = checked linkProgram linkStatus programInfoLog "link"++createProgram :: [VertexShader] -> [FragmentShader] -> IO Program+createProgram vertexShaders fragmentShaders = do+ [program] <- genObjectNames 1+ attachedShaders program $= (vertexShaders, fragmentShaders)+ linkAndCheck program+ return program++initShader :: IO (UniformLocation, AttribLocation, AttribLocation)+initShader = do+ vertexShader <- compileShaderSource [vertexShaderSource]+ fragmentShader <- compileShaderSource [fragmentShaderSource]+ program <- createProgram [vertexShader] [fragmentShader]+ currentProgram $= Just program++ projectionMatrixIndex <- get (uniformLocation program "fg_ProjectionMatrix")++ colorIndex <- get (attribLocation program "fg_Color")+ vertexAttribArray colorIndex $= Enabled++ vertexIndex <- get (attribLocation program "fg_Vertex")+ vertexAttribArray vertexIndex $= Enabled++ checkError "initShader"+ return (projectionMatrixIndex, colorIndex, vertexIndex)++initRendering :: IO ()+initRendering = do+ clearColor $= Color4 0 0 0 0+ checkError "initRendering"++myInit :: IO State+myInit = do+ bufferObject <- initBuffer+ (projectionMatrixIndex, colorIndex, vertexIndex) <- initShader+ initRendering+ m <- newMatrix ColumnMajor (replicate 16 0)+ return $ State {+ vertexBufferName = bufferObject,+ fgProjectionMatrixIndex = projectionMatrixIndex,+ fgColorIndex = colorIndex,+ fgVertexIndex = vertexIndex,+ projectionMatrix = m }++dumpInfo :: IO ()+dumpInfo = do+ let dump message var = putStrLn . ((message ++ ": ") ++) =<< get var+ dump "Vendor" vendor+ dump "Renderer" renderer+ dump "Version" glVersion+ dump "GLSL" shadingLanguageVersion+ checkError "dumpInfo"++bufferObjectPtr :: Integral a => a -> Ptr b+bufferObjectPtr = plusPtr (nullPtr :: Ptr GLchar) . fromIntegral++vertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor a+vertexArrayDescriptor count offset =+ VertexArrayDescriptor count Float stride (bufferObjectPtr (fromIntegral sizeOfComponent * offset))++triangle :: State -> IO ()+triangle state = do+ withMatrix (projectionMatrix state) $ \order buffer ->+ uniformMatrix4fv (fgProjectionMatrixIndex state) 1 (order == RowMajor) buffer+ bindBuffer ArrayBuffer $= Just (vertexBufferName state)+ vertexAttribPointer (fgColorIndex state) $=+ (ToFloat, vertexArrayDescriptor numColorComponents 0)+ vertexAttribPointer (fgVertexIndex state) $=+ (ToFloat, vertexArrayDescriptor numVertexComponents numColorComponents)+ drawArrays Triangles 0 numElements+ checkError "triangle"++-- The OpenGL package offers no interface for glUniformMatrix*fv yet+uniformMatrix4fv :: UniformLocation -> GLsizei -> Bool -> Ptr GLfloat -> IO ()+uniformMatrix4fv location count =+ glUniformMatrix4fv (uniformLocationToGLint location) count . marshalGLboolean+ where marshalGLboolean x = fromIntegral $ case x of+ False -> gl_FALSE+ True -> gl_TRUE+ -- MEGA HACK because UniformLocation is abstract+ uniformLocationToGLint = read . head . tail . words . show++display :: State -> DisplayCallback+display state = do+ clear [ ColorBuffer ]+ triangle state+ flush+ checkError "display"++loadOrtho :: (Matrix m, MatrixComponent a, Fractional a) => m a -> a -> a -> a -> a -> a -> a -> IO ()+loadOrtho m l r b t n f =+ fillMatrix m [+ [2 / (r - l),+ 0,+ 0,+ 0],++ [0,+ 2 / (t - b),+ 0,+ 0],++ [0,+ 0,+ -2 / (f - n),+ 0],++ [-(r + l) / (r - l),+ -(t + b) / (t - b),+ -(f + n) / (f - n),+ 1 ]]++fillMatrix :: (Matrix m, MatrixComponent a) => m a -> [[a]] -> IO ()+fillMatrix m xs =+ withMatrix m $ \order buffer ->+ pokeArray buffer . concat . rearrange order $ xs++rearrange :: MatrixOrder -> [[a]] -> [[a]]+rearrange ColumnMajor = id+rearrange RowMajor = transpose++loadOrtho2D :: (Matrix m, MatrixComponent a, Fractional a) => m a -> a -> a -> a -> a -> IO ()+loadOrtho2D m l r b t = loadOrtho m l r b t (-1) 1++reshape :: State -> ReshapeCallback+reshape state size@(Size w h) = do+ viewport $= (Position 0 0, size)+ let wf = fromIntegral w+ hf = fromIntegral h+ if w <= h+ then loadOrtho2D (projectionMatrix state) 0 30 0 (30 * hf / wf)+ else loadOrtho2D (projectionMatrix state) 0 (30 * wf / hf) 0 30+ checkError "reshape"++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _ _ _ _ = return ()++main :: IO ()+main = do+ (progName, args) <- getArgsAndInitialize+ initialDisplayMode $= [ SingleBuffered, RGBMode ]+ -- add command line argument "classic" for a pre-3.x context+ unless (args == ["classic"]) $ do+ initialContextVersion $= (3, 1)+ initialContextFlags $= [ ForwardCompatibleContext, DebugContext ]+ initialWindowSize $= Size 500 500+ initialWindowPosition $= Position 100 100+ createWindow progName+ dumpInfo+ state <- myInit+ displayCallback $= display state+ reshapeCallback $= Just (reshape state)+ keyboardMouseCallback $= Just keyboard+ mainLoop
examples/Misc/Triangulate.hs view
@@ -80,14 +80,16 @@ drawTriangleVertex tv2 drawTriangleVertex tv3 +-- CFloat has no Random instance, so we go via Float+randomGLfloat :: IO GLfloat+randomGLfloat = fmap (realToFrac :: Float -> GLfloat) randomIO+ randomColor :: IO () randomColor = do- r <- randomIO- g <- randomIO- b <- randomIO- -- resolve overloading, not needed in "real" programs- let color3f = color :: Color3 GLfloat -> IO ()- color3f (Color3 r g b)+ r <- randomGLfloat+ g <- randomGLfloat+ b <- randomGLfloat+ color (Color3 r g b) drawTriangleVertex :: TriangleVertex DontCare -> IO () drawTriangleVertex (AnnotatedVertex plainVertex (_, e)) = do
examples/RedBook/MultiTex.hs view
@@ -97,11 +97,13 @@ initialWindowPosition $= Position 100 100 createWindow progName -- we have to do this *after* createWindow, otherwise we have no OpenGL context- exts <- get glExtensions- unless ("GL_ARB_multitexture" `elem` exts &&- "GL_EXT_texture_object" `elem` exts) $ do- putStrLn "Sorry, this demo requires the GL_ARB_multitexture and GL_EXT_texture_object extensions."- exitFailure+ version <- get (majorMinor glVersion)+ unless (version >= (1, 3)) $ do+ exts <- get glExtensions+ unless ("GL_ARB_multitexture" `elem` exts && -- part of 1.3 core+ "GL_EXT_texture_object" `elem` exts) $ do -- part of 1.1 core+ putStrLn "Sorry, this demo requires the GL_ARB_multitexture and GL_EXT_texture_object extensions."+ exitFailure myInit reshapeCallback $= Just reshape displayCallback $= display
examples/RedBook/PickSquare.hs view
@@ -14,7 +14,7 @@ import System.Exit ( exitWith, ExitCode(ExitSuccess) ) import Graphics.UI.GLUT -type Board = Array (GLint,GLint) (IORef Int)+type Board = Array (Int,Int) (IORef Int) data State = State { board :: Board } @@ -46,7 +46,9 @@ color3f (Color3 (fromIntegral i / 3.0) (fromIntegral j / 3.0) (fromIntegral val / 3.0))- rect (Vertex2 i j) (Vertex2 (i + 1) (j + 1))+ let vertex2i :: Int -> Int -> Vertex2 GLint+ vertex2i x y = Vertex2 (fromIntegral x) (fromIntegral y)+ rect (vertex2i i j) (vertex2i (i + 1) (j + 1)) -- processHits prints the hit records and updates the board array. processHits :: Maybe[HitRecord] -> State -> IO ()
examples/RedBook/PointP.hs view
@@ -41,17 +41,24 @@ d <- newIORef (-10) return $ State { distance = d } +-- CFloat has no Random instance, so we go via Float+randomGLfloat :: (GLfloat, GLfloat) -> IO GLfloat+randomGLfloat = fmap floatToGLfloat . randomRIO . fmapPair glFloatToFloat+ where fmapPair f (x, y) = (f x, f y)+ floatToGLfloat = realToFrac :: Float -> GLfloat+ glFloatToFloat = realToFrac :: GLfloat -> Float+ randomColor :: IO (Color3 GLfloat) randomColor = do- g <- randomRIO (0.5, 1)- b <- randomRIO (0, 1)+ g <- randomGLfloat (0.5, 1)+ b <- randomGLfloat (0, 1) return $ Color3 1 g b randomVertex :: IO (Vertex3 GLfloat) randomVertex = do- x <- randomRIO (-5, 5)- y <- randomRIO (-5, 5)- z <- randomRIO (-5, -45)+ x <- randomGLfloat (-5, 5)+ y <- randomGLfloat (-5, 5)+ z <- randomGLfloat (-5, -45) return $ Vertex3 x y z myInit :: IO DisplayList
examples/RedBook/SurfPoints.hs view
@@ -22,7 +22,7 @@ import Data.Char ( toLower ) import Data.IORef ( IORef, newIORef ) import Foreign.Marshal ( withArray )-import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure )+import System.Exit ( exitWith, ExitCode(ExitSuccess) ) import Graphics.UI.GLUT data State = State { showPoints :: IORef Bool }@@ -120,7 +120,7 @@ putStrLn "OpenGL Utility Library (GLU) Version 1.3." putStrLn "If your implementation of GLU has the right extensions," putStrLn "you may be able to modify this program to make it run."- exitFailure+ putStrLn "Continuing anyway..." state <- makeState myInit reshapeCallback $= Just reshape