diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,65 @@ +2.7.0.16 +-------- +* Relaxed upper version bounds for `random` and `bytestring`. + +2.7.0.15 +-------- +* Fixed typo in documentation. +* Relaxed upper version bound for `StateVar`. + +2.7.0.14 +-------- +* Relaxed upper version bound for `containers`. + +2.7.0.13 +-------- +* Relaxed upper version bound for `OpenGLRaw`. + +2.7.0.12 +-------- +* Mac OS X: Make it possible to link against freeglut. + +2.7.0.11 +-------- +* Linux: Try to load versioned GLUT library, too, because the unversioned one is often in *-dev packages only. + +2.7.0.10 +-------- +* Mac OS X: Search public frameworks first, then system frameworks. + +2.7.0.9 +-------- +* The GLUT package compiles without any additional library/framework now. +* Windows: We search for a native freeglut DLL, a MinGW freeglut DLL and a classic GLUT DLL, in that order. + +2.7.0.8 +-------- +* Relaxed upper version bound for `OpenGLRaw`. + +2.7.0.7 +------- +* Removed redundant constraints. + +2.7.0.6 +-------- +* Relaxed upper version bound for `OpenGLRaw`. + +2.7.0.5 +-------- +* Make things work with both old and new `OpenGLRaw`/`GLURaw` packages. +* Build all examples via cabal, no need for `make` anymore. + +2.7.0.4 +-------- +* Relaxed upper version bound for `transformers`. + +2.7.0.3 +-------- +* Relaxed upper version bound for OpenGLRaw. +* Added CHANGELOG.md to distribution. +* Minor build/testing tweaks. + +2.7.0.2 +-------- +* Fixed typo in shader file extension. +* Relaxed bounds for OpenGL package. diff --git a/GLUT.cabal b/GLUT.cabal --- a/GLUT.cabal +++ b/GLUT.cabal @@ -1,172 +1,920 @@ name: GLUT -version: 2.3.0.0 -license: BSD3 -license-file: LICENSE -maintainer: Jason Dagit , Sven Panne -bug-reports: https://github.com/haskell-opengl/GLUT/issues -homepage: http://www.haskell.org/haskellwiki/Opengl -category: Graphics -synopsis: A binding for the OpenGL Utility Toolkit -description: - A Haskell binding for the OpenGL Utility Toolkit, a window system independent - toolkit for writing OpenGL programs. For more information about the C library - on which this binding is based, please see: - . -build-type: Simple -cabal-version: >=1.6 -extra-source-files: - README - examples/BOGLGP/Chapter01/OnYourOwn1.hs - examples/BOGLGP/Chapter01/Simple.hs - examples/BOGLGP/Chapter02/OnYourOwn1.hs - examples/BOGLGP/Chapter02/OpenGLApplication.hs - examples/BOGLGP/Chapter03/Lines.hs - examples/BOGLGP/Chapter03/OnYourOwn1.hs - examples/BOGLGP/Chapter03/Points.hs - examples/BOGLGP/Chapter03/Polygons.hs - examples/BOGLGP/Chapter03/TrianglesQuads.hs - examples/Misc/ARBOcclude.hs - 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 - examples/OrangeBook/ogl2brick/Brick.hs - examples/OrangeBook/ogl2brick/Brick.vert - examples/RedBook/00-README - examples/RedBook/AAIndex.hs - examples/RedBook/AARGB.hs - examples/RedBook/AccAnti.hs - examples/RedBook/AccPersp.hs - examples/RedBook/Alpha.hs - examples/RedBook/Alpha3D.hs - examples/RedBook/BezCurve.hs - examples/RedBook/BezMesh.hs - examples/RedBook/BezSurf.hs - examples/RedBook/BlendEqn.hs - examples/RedBook/Checker.hs - examples/RedBook/Clip.hs - examples/RedBook/ColorMat.hs - examples/RedBook/ColorMatrix.hs - examples/RedBook/ColorTable.hs - examples/RedBook/Combiner.hs - examples/RedBook/Convolution.hs - examples/RedBook/Cube.hs - examples/RedBook/CubeMap.hs - examples/RedBook/DList.hs - examples/RedBook/DOF.hs - examples/RedBook/Data/leeds.bin - examples/RedBook/Double.hs - examples/RedBook/DrawF.hs - examples/RedBook/Feedback.hs - examples/RedBook/Fog.hs - examples/RedBook/FogCoord.hs - examples/RedBook/FogIndex.hs - examples/RedBook/Font.hs - examples/RedBook/Hello.hs - examples/RedBook/Histogram.hs - examples/RedBook/Image.hs - examples/RedBook/Light.hs - examples/RedBook/Lines.hs - examples/RedBook/MVArray.hs - examples/RedBook/Material.hs - examples/RedBook/Minmax.hs - examples/RedBook/Mipmap.hs - examples/RedBook/Model.hs - examples/RedBook/MoveLight.hs - examples/RedBook/MultiTex.hs - examples/RedBook/Multisamp.hs - examples/RedBook/PickDepth.hs - examples/RedBook/PickSquare.hs - examples/RedBook/Planet.hs - examples/RedBook/PointP.hs - examples/RedBook/PolyOff.hs - examples/RedBook/Polys.hs - examples/RedBook/Quadric.hs - examples/RedBook/ReadImage.hs - examples/RedBook/Robot.hs - examples/RedBook/Scene.hs - examples/RedBook/Select.hs - examples/RedBook/ShadowMap.hs - examples/RedBook/Smooth.hs - examples/RedBook/Stencil.hs - examples/RedBook/Stroke.hs - examples/RedBook/SurfPoints.hs - examples/RedBook/Surface.hs - examples/RedBook/Teapots.hs - examples/RedBook/Tess.hs - examples/RedBook/TessWind.hs - examples/RedBook/TexBind.hs - examples/RedBook/TexGen.hs - examples/RedBook/TexProx.hs - examples/RedBook/TexSub.hs - examples/RedBook/Texture3D.hs - examples/RedBook/TextureSurf.hs - examples/RedBook/Torus.hs - examples/RedBook/Trim.hs - examples/RedBook/UnProject.hs - examples/RedBook/VArray.hs - examples/RedBook/Wrap.hs - include/HsGLUTExt.h - -flag split-base - -flag UseNativeWindowsLibraries - description: - When compiling under Windows, use the native libraries instead of e.g. the - ones coming with Cygwin. - -library - exposed-modules: - Graphics.UI.GLUT, - Graphics.UI.GLUT.Begin, - Graphics.UI.GLUT.Callbacks, - Graphics.UI.GLUT.Callbacks.Global, - Graphics.UI.GLUT.Callbacks.Window, - Graphics.UI.GLUT.Colormap, - Graphics.UI.GLUT.Debugging, - Graphics.UI.GLUT.DeviceControl, - Graphics.UI.GLUT.Fonts, - Graphics.UI.GLUT.GameMode, - Graphics.UI.GLUT.Initialization, - Graphics.UI.GLUT.Menu, - Graphics.UI.GLUT.Objects, - Graphics.UI.GLUT.Overlay, - Graphics.UI.GLUT.State, - Graphics.UI.GLUT.Window - other-modules: - Graphics.UI.GLUT.Callbacks.Registration, - Graphics.UI.GLUT.QueryUtils, - Graphics.UI.GLUT.Raw, - Graphics.UI.GLUT.Raw.APIEntry, - Graphics.UI.GLUT.Raw.Callbacks, - Graphics.UI.GLUT.Raw.Fonts, - Graphics.UI.GLUT.Raw.Functions, - Graphics.UI.GLUT.Raw.Tokens, - Graphics.UI.GLUT.Types - include-dirs: include - c-sources: - cbits/HsGLUT.c - if flag(split-base) - build-depends: base >= 3 && < 5, array >= 0.3 && < 0.5, containers >= 0.3 && < 0.5 - else - build-depends: base < 3 - build-depends: OpenGL == 2.5.*, OpenGLRaw == 1.2.*, StateVar == 1.0.*, Tensor == 1.0.* - ghc-options: -Wall - if os(windows) && flag(UseNativeWindowsLibraries) - cpp-options: "-DCALLCONV=stdcall" - cc-options: "-DUSE_GETPROCADDRESS" - extra-libraries: glut32 - else - cpp-options: "-DCALLCONV=ccall" - cc-options: "-DUSE_DLSYM" - if os(darwin) - frameworks: GLUT - else - extra-libraries: glut - -source-repository head - type: git - location: https://github.com/haskell-opengl/GLUT +version: 2.7.0.16 +synopsis: A binding for the OpenGL Utility Toolkit +description: + A Haskell binding for the OpenGL Utility Toolkit, a window system independent + toolkit for writing OpenGL programs. For more information about the C library + on which this binding is based, please see: + . +homepage: http://www.haskell.org/haskellwiki/Opengl +bug-reports: https://github.com/haskell-opengl/GLUT/issues +copyright: Copyright (C) 2002-2018 Sven Panne +license: BSD3 +license-file: LICENSE +author: Sven Panne +maintainer: Sven Panne , Jason Dagit +category: Graphics +build-type: Simple +tested-with: + GHC == 7.0.4 + GHC == 7.2.2 + GHC == 7.4.2 + GHC == 7.6.3 + GHC == 7.8.4 + GHC == 7.10.3 + GHC == 8.0.2 + GHC == 8.2.2 + GHC == 8.4.3 + GHC == 8.6.5 + GHC == 8.8.1 +cabal-version: >= 1.10 +extra-source-files: + CHANGELOG.md + README.md + examples/00-README + examples/BOGLGP/00-README + examples/Misc/00-README + examples/Misc/ColorTriangle/color_triangles.frag + examples/Misc/ColorTriangle/color_triangles.vert + examples/OrangeBook/00-README + examples/OrangeBook/3Dlabs-License.txt + examples/OrangeBook/ogl2brick/Brick.frag + examples/OrangeBook/ogl2brick/Brick.vert + examples/RedBook4/00-README + examples/RedBook4/Data/leeds.bin + examples/RedBook8/00-README + examples/RedBook8/Chapter01/triangles.frag + examples/RedBook8/Chapter01/triangles.vert + +flag UseNativeWindowsLibraries + description: + When compiling under Windows, use the native libraries instead of e.g. the + ones coming with Cygwin or MSYS. + +flag BuildExamples + description: Build various OpenGL/GLUT examples. + default: False + +library + exposed-modules: + Graphics.UI.GLUT + Graphics.UI.GLUT.Begin + Graphics.UI.GLUT.Callbacks + Graphics.UI.GLUT.Callbacks.Global + Graphics.UI.GLUT.Callbacks.Window + Graphics.UI.GLUT.Colormap + Graphics.UI.GLUT.Debugging + Graphics.UI.GLUT.DeviceControl + Graphics.UI.GLUT.Fonts + Graphics.UI.GLUT.GameMode + Graphics.UI.GLUT.Initialization + Graphics.UI.GLUT.Menu + Graphics.UI.GLUT.Objects + Graphics.UI.GLUT.Overlay + Graphics.UI.GLUT.State + Graphics.UI.GLUT.Window + other-modules: + Graphics.UI.GLUT.Callbacks.Registration + Graphics.UI.GLUT.QueryUtils + Graphics.UI.GLUT.Raw + Graphics.UI.GLUT.Raw.Callbacks + Graphics.UI.GLUT.Raw.Fonts + Graphics.UI.GLUT.Raw.Functions + Graphics.UI.GLUT.Raw.Tokens + Graphics.UI.GLUT.Types + c-sources: + cbits/HsGLUT.c + hs-source-dirs: src + build-depends: + base >= 3 && < 5, + array >= 0.3 && < 0.6, + containers >= 0.3 && < 0.7, + transformers >= 0.2 && < 0.6, + StateVar >= 1.1 && < 1.3, + OpenGL >= 2.12 && < 3.1 + default-language: Haskell2010 + other-extensions: CPP + ghc-options: -Wall + if impl(ghc > 8) + ghc-options: -Wcompat + if os(windows) && flag(UseNativeWindowsLibraries) + if arch(i386) + cpp-options: "-DCALLCONV=stdcall" + else + cpp-options: "-DCALLCONV=ccall" + cc-options: "-DUSE_GETPROCADDRESS" + else + cpp-options: "-DCALLCONV=ccall" + cc-options: "-DUSE_DLSYM" + +executable BOGLGP01-OnYourOwn1 + if !flag(BuildExamples) + buildable: False + main-is: OnYourOwn1.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/BOGLGP/Chapter01 + default-language: Haskell2010 + ghc-options: -Wall + +executable BOGLGP01-Simple + if !flag(BuildExamples) + buildable: False + main-is: Simple.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/BOGLGP/Chapter01 + default-language: Haskell2010 + ghc-options: -Wall + +executable BOGLGP02-OnYourOwn1.hs + if !flag(BuildExamples) + buildable: False + main-is: OnYourOwn1.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/BOGLGP/Chapter02 + default-language: Haskell2010 + ghc-options: -Wall + +executable BOGLGP02-OpenGLApplication.hs + if !flag(BuildExamples) + buildable: False + main-is: OpenGLApplication.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/BOGLGP/Chapter02 + default-language: Haskell2010 + ghc-options: -Wall + +executable BOGLGP03-Lines + if !flag(BuildExamples) + buildable: False + main-is: Lines.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/BOGLGP/Chapter03 + default-language: Haskell2010 + ghc-options: -Wall + +executable BOGLGP03-OnYourOwn1 + if !flag(BuildExamples) + buildable: False + main-is: OnYourOwn1.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/BOGLGP/Chapter03 + default-language: Haskell2010 + ghc-options: -Wall + +executable BOGLGP03-Points + if !flag(BuildExamples) + buildable: False + main-is: Points.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/BOGLGP/Chapter03 + default-language: Haskell2010 + ghc-options: -Wall + +executable BOGLGP03-Polygons + if !flag(BuildExamples) + buildable: False + main-is: Polygons.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/BOGLGP/Chapter03 + default-language: Haskell2010 + ghc-options: -Wall + +executable BOGLGP03-TrianglesQuads + if !flag(BuildExamples) + buildable: False + main-is: TrianglesQuads.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/BOGLGP/Chapter03 + default-language: Haskell2010 + ghc-options: -Wall + +executable Misc-ARBOcclude + if !flag(BuildExamples) + buildable: False + main-is: ARBOcclude.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/Misc + default-language: Haskell2010 + ghc-options: -Wall + +executable Misc-ColorTriangle + if !flag(BuildExamples) + buildable: False + main-is: ColorTriangle.hs + other-modules: LoadShaders + build-depends: base >= 3 && < 5, bytestring >= 0.9 && < 0.12, GLUT + hs-source-dirs: examples/Misc/ColorTriangle, examples/RedBook8/common + default-language: Haskell2010 + ghc-options: -Wall + +executable Misc-ExtractContours + if !flag(BuildExamples) + buildable: False + main-is: ExtractContours.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/Misc + default-language: Haskell2010 + ghc-options: -Wall + +executable Misc-Gears + if !flag(BuildExamples) + buildable: False + main-is: Gears.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/Misc + default-language: Haskell2010 + ghc-options: -Wall + +executable Misc-Pitfall14 + if !flag(BuildExamples) + buildable: False + main-is: Pitfall14.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/Misc + default-language: Haskell2010 + ghc-options: -Wall + +executable Misc-SmoothOpenGL3 + if !flag(BuildExamples) + buildable: False + main-is: SmoothOpenGL3.hs + build-depends: base >= 3 && < 5, bytestring >= 0.9 && < 0.12, OpenGLRaw >= 1.0 && < 3.4, GLUT + hs-source-dirs: examples/Misc + default-language: Haskell2010 + ghc-options: -Wall + +executable Misc-Triangulate + if !flag(BuildExamples) + buildable: False + main-is: Triangulate.hs + build-depends: base >= 3 && < 5, random >= 1.0 && < 1.3, GLUT + hs-source-dirs: examples/Misc + default-language: Haskell2010 + ghc-options: -Wall + +executable OrangeBook-Brick + if !flag(BuildExamples) + buildable: False + main-is: Brick.hs + build-depends: base >= 3 && < 5, bytestring >= 0.9 && < 0.12, GLUT + hs-source-dirs: examples/OrangeBook/ogl2brick + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-AAIndex + if !flag(BuildExamples) + buildable: False + main-is: AAIndex.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-AARGB + if !flag(BuildExamples) + buildable: False + main-is: AARGB.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-AccAnti + if !flag(BuildExamples) + buildable: False + main-is: AccAnti.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-AccPersp + if !flag(BuildExamples) + buildable: False + main-is: AccPersp.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Alpha + if !flag(BuildExamples) + buildable: False + main-is: Alpha.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Alpha3D + if !flag(BuildExamples) + buildable: False + main-is: Alpha3D.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-BezCurve + if !flag(BuildExamples) + buildable: False + main-is: BezCurve.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-BezMesh + if !flag(BuildExamples) + buildable: False + main-is: BezMesh.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-BezSurf + if !flag(BuildExamples) + buildable: False + main-is: BezSurf.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-BlendEqn + if !flag(BuildExamples) + buildable: False + main-is: BlendEqn.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Checker + if !flag(BuildExamples) + buildable: False + main-is: Checker.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Clip + if !flag(BuildExamples) + buildable: False + main-is: Clip.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-ColorMat + if !flag(BuildExamples) + buildable: False + main-is: ColorMat.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-ColorMatrix + if !flag(BuildExamples) + buildable: False + main-is: ColorMatrix.hs + other-modules: ReadImage + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-ColorTable + if !flag(BuildExamples) + buildable: False + main-is: ColorTable.hs + other-modules: ReadImage + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Combiner + if !flag(BuildExamples) + buildable: False + main-is: Combiner.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Convolution + if !flag(BuildExamples) + buildable: False + main-is: Convolution.hs + other-modules: ReadImage + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Cube + if !flag(BuildExamples) + buildable: False + main-is: Cube.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-CubeMap + if !flag(BuildExamples) + buildable: False + main-is: CubeMap.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-DList + if !flag(BuildExamples) + buildable: False + main-is: DList.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-DOF + if !flag(BuildExamples) + buildable: False + main-is: DOF.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Double + if !flag(BuildExamples) + buildable: False + main-is: Double.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-DrawF + if !flag(BuildExamples) + buildable: False + main-is: DrawF.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Feedback + if !flag(BuildExamples) + buildable: False + main-is: Feedback.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Fog + if !flag(BuildExamples) + buildable: False + main-is: Fog.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-FogCoord + if !flag(BuildExamples) + buildable: False + main-is: FogCoord.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-FogIndex + if !flag(BuildExamples) + buildable: False + main-is: FogIndex.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Font + if !flag(BuildExamples) + buildable: False + main-is: Font.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Hello + if !flag(BuildExamples) + buildable: False + main-is: Hello.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Histogram + if !flag(BuildExamples) + buildable: False + main-is: Histogram.hs + other-modules: ReadImage + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Image + if !flag(BuildExamples) + buildable: False + main-is: Image.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Light + if !flag(BuildExamples) + buildable: False + main-is: Light.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Lines + if !flag(BuildExamples) + buildable: False + main-is: Lines.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-MVArray + if !flag(BuildExamples) + buildable: False + main-is: MVArray.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Material + if !flag(BuildExamples) + buildable: False + main-is: Material.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Minmax + if !flag(BuildExamples) + buildable: False + main-is: Minmax.hs + other-modules: ReadImage + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Mipmap + if !flag(BuildExamples) + buildable: False + main-is: Mipmap.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Model + if !flag(BuildExamples) + buildable: False + main-is: Model.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-MoveLight + if !flag(BuildExamples) + buildable: False + main-is: MoveLight.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-MultiTex + if !flag(BuildExamples) + buildable: False + main-is: MultiTex.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Multisamp + if !flag(BuildExamples) + buildable: False + main-is: Multisamp.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-PickDepth + if !flag(BuildExamples) + buildable: False + main-is: PickDepth.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-PickSquare + if !flag(BuildExamples) + buildable: False + main-is: PickSquare.hs + build-depends: base >= 3 && < 5, array >= 0.1 && < 0.6, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Planet + if !flag(BuildExamples) + buildable: False + main-is: Planet.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-PointP + if !flag(BuildExamples) + buildable: False + main-is: PointP.hs + build-depends: base >= 3 && < 5, random >= 1.0 && < 1.3, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-PolyOff + if !flag(BuildExamples) + buildable: False + main-is: PolyOff.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Polys + if !flag(BuildExamples) + buildable: False + main-is: Polys.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Quadric + if !flag(BuildExamples) + buildable: False + main-is: Quadric.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Robot + if !flag(BuildExamples) + buildable: False + main-is: Robot.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Scene + if !flag(BuildExamples) + buildable: False + main-is: Scene.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Select + if !flag(BuildExamples) + buildable: False + main-is: Select.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-ShadowMap + if !flag(BuildExamples) + buildable: False + main-is: ShadowMap.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Smooth + if !flag(BuildExamples) + buildable: False + main-is: Smooth.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Stencil + if !flag(BuildExamples) + buildable: False + main-is: Stencil.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Stroke + if !flag(BuildExamples) + buildable: False + main-is: Stroke.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-SurfPoints + if !flag(BuildExamples) + buildable: False + main-is: SurfPoints.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Surface + if !flag(BuildExamples) + buildable: False + main-is: Surface.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Teapots + if !flag(BuildExamples) + buildable: False + main-is: Teapots.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Tess + if !flag(BuildExamples) + buildable: False + main-is: Tess.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-TessWind + if !flag(BuildExamples) + buildable: False + main-is: TessWind.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-TexBind + if !flag(BuildExamples) + buildable: False + main-is: TexBind.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-TexGen + if !flag(BuildExamples) + buildable: False + main-is: TexGen.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-TexProx + if !flag(BuildExamples) + buildable: False + main-is: TexProx.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-TexSub + if !flag(BuildExamples) + buildable: False + main-is: TexSub.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Texture3D + if !flag(BuildExamples) + buildable: False + main-is: Texture3D.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-TextureSurf + if !flag(BuildExamples) + buildable: False + main-is: TextureSurf.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Torus + if !flag(BuildExamples) + buildable: False + main-is: Torus.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Trim + if !flag(BuildExamples) + buildable: False + main-is: Trim.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-UnProject + if !flag(BuildExamples) + buildable: False + main-is: UnProject.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-VArray + if !flag(BuildExamples) + buildable: False + main-is: VArray.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook4-Wrap + if !flag(BuildExamples) + buildable: False + main-is: Wrap.hs + build-depends: base >= 3 && < 5, GLUT + hs-source-dirs: examples/RedBook4 + default-language: Haskell2010 + ghc-options: -Wall + +executable RedBook8-Triangles + if !flag(BuildExamples) + buildable: False + main-is: Triangles.hs + other-modules: LoadShaders + build-depends: base >= 3 && < 5, bytestring >= 0.9 && < 0.12, GLUT + hs-source-dirs: examples/RedBook8/Chapter01, examples/RedBook8/common + default-language: Haskell2010 + ghc-options: -Wall + +source-repository head + type: git + location: https://github.com/haskell-opengl/GLUT.git diff --git a/Graphics/UI/GLUT.hs b/Graphics/UI/GLUT.hs deleted file mode 100644 --- a/Graphics/UI/GLUT.hs +++ /dev/null @@ -1,386 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Graphics.UI.GLUT --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- A Haskell binding for GLUT, the OpenGL Utility Toolkit, a window system --- independent toolkit for writing OpenGL programs. It includes support for --- the extended functionality available in freeglut (see --- ) and OpenGLUT (see --- ), too. --- ------------------------------------------------------------------------------ - -module Graphics.UI.GLUT ( - -- * Legal stuff - - -- $LegalStuff - - -- * Introduction - - -- $Introduction - - -- ** Background - - -- $Background - - -- ** Design Philosophy - - -- $DesignPhilosophy - - -- ** API Versions - - -- $APIVersions - - -- ** Conventions - - -- $Conventions - - -- ** Terminology - - -- $Terminology - - module Graphics.Rendering.OpenGL, - - module Graphics.UI.GLUT.Initialization, - module Graphics.UI.GLUT.Begin, - module Graphics.UI.GLUT.Window, - module Graphics.UI.GLUT.Overlay, - module Graphics.UI.GLUT.Menu, - module Graphics.UI.GLUT.Callbacks, - module Graphics.UI.GLUT.Colormap, - module Graphics.UI.GLUT.State, - module Graphics.UI.GLUT.Fonts, - module Graphics.UI.GLUT.Objects, - module Graphics.UI.GLUT.Debugging, - module Graphics.UI.GLUT.DeviceControl, - module Graphics.UI.GLUT.GameMode -) where - -import Graphics.Rendering.OpenGL - -import Graphics.UI.GLUT.Initialization -import Graphics.UI.GLUT.Begin -import Graphics.UI.GLUT.Window -import Graphics.UI.GLUT.Overlay -import Graphics.UI.GLUT.Menu -import Graphics.UI.GLUT.Callbacks -import Graphics.UI.GLUT.Colormap -import Graphics.UI.GLUT.State -import Graphics.UI.GLUT.Fonts -import Graphics.UI.GLUT.Objects -import Graphics.UI.GLUT.Debugging -import Graphics.UI.GLUT.DeviceControl -import Graphics.UI.GLUT.GameMode - ------------------------------------------------------------------------------ --- $LegalStuff --- This documentation is heavily based on the man pages of Mark J. Kilgard\'s --- GLUT library. --- --- OpenGL is a trademark of Silicon Graphics, Inc. --- X Window System is a trademark of X Consortium, Inc. --- Spaceball is a registered trademark of Spatial Systems, Inc. --- --- The author has taken care in preparation of this documentation but makes --- no expressed or implied warranty of any kind and assumes no responsibility --- for errors or omissions. No liability is assumed for incidental or --- consequential damages in connection with or arising from the use of --- information or programs contained herein. - ------------------------------------------------------------------------------ --- $Introduction --- The OpenGL Utility Toolkit (GLUT) is a programming interface for writing --- window system independent OpenGL programs. Currently there are --- implementations for the X Window System, the Windows family, OS\/2, and Mac. --- The toolkit supports the following functionality: --- --- * Multiple windows for OpenGL rendering. --- --- * Callback driven event processing. --- --- * Sophisticated input devices. --- --- * An /idle/ routine and timers. --- --- * A simple, cascading pop-up menu facility. --- --- * Utility routines to generate various solid and wire frame objects. --- --- * Support for bitmap and stroke fonts. --- --- * Miscellaneous window management functions, including managing overlays. --- --- This documentation serves as both a specification and a programming guide. --- If you are interested in a brief introduction to programming with GLUT, --- have a look at the relevant parts of and the vast --- amount of books on OpenGL, most of them use GLUT. --- --- The remainder of this section describes GLUT\'s design philosophy and --- usage model. The following sections specify the GLUT routines, grouped by --- functionality. The final sections discuss usage advice and the logical --- programmer visible state maintained by GLUT. - ------------------------------------------------------------------------------ --- $Background --- One of the major accomplishments in the specification of OpenGL was --- the isolation of window system dependencies from OpenGL\'s rendering --- model. The result is that OpenGL is window system independent. --- --- Window system operations such as the creation of a rendering window and the --- handling of window system events are left to the native window system to --- define. Necessary interactions between OpenGL and the window system such as --- creating and binding an OpenGL context to a window are described separately --- from the OpenGL specification in a window system dependent specification. For --- example, the GLX specification describes the standard by which OpenGL --- interacts with the X Window System. --- --- The predecessor to OpenGL is IRIS GL. Unlike OpenGL, IRIS GL /does/ --- specify how rendering windows are created and manipulated. IRIS GL\'s --- windowing interface is reasonably popular largely because it is simple to --- use. IRIS GL programmers can worry about graphics programming without needing --- to be an expert in programming the native window system. Experience also --- demonstrated that IRIS GL\'s windowing interface was high-level enough that --- it could be retargeted to different window systems. Silicon Graphics migrated --- from NeWS to the X Window System without any major changes to IRIS GL\'s --- basic windowing interface. --- --- Removing window system operations from OpenGL is a sound decision because it --- allows the OpenGL graphics system to be retargeted to various systems --- including powerful but expensive graphics workstations as well as --- mass-production graphics systems like video games, set-top boxes for --- interactive television, and PCs. --- --- Unfortunately, the lack of a window system interface for OpenGL is a gap in --- OpenGL\'s utility. Learning native window system APIs such as the X Window --- System\'s Xlib or Motif can be daunting. Even those familiar with --- native window system APIs need to understand the interface that binds OpenGL --- to the native window system. And when an OpenGL program is written using the --- native window system interface, despite the portability of the program\'s --- OpenGL rendering code, the program itself will be window system dependent. --- --- Testing and documenting OpenGL\'s functionality lead to the development of --- the @tk@ and @aux@ toolkits. The @aux@ toolkit is used in the examples found --- in the /OpenGL Programming Guide/. Unfortunately, @aux@ has numerous --- limitations and its utility is largely limited to toy programs. The @tk@ --- library has more functionality than @aux@ but was developed in an /ad hoc/ --- fashion and still lacks much important functionality that IRIS GL programmers --- expect, like pop-up menus and overlays. --- --- GLUT is designed to fill the need for a window system independent programming --- interface for OpenGL programs. The interface is designed to be simple yet --- still meet the needs of useful OpenGL programs. Features from the IRIS GL, --- @aux@, and @tk@ interfaces are included to make it easy for programmers used --- to these interfaces to develop programs for GLUT. - ------------------------------------------------------------------------------ --- $DesignPhilosophy --- GLUT simplifies the implementation of programs using OpenGL rendering. The --- GLUT application programming interface (API) requires very few routines to --- display a graphics scene rendered using OpenGL. The GLUT API (like the OpenGL --- API) is stateful. Most initial GLUT state is defined and the initial state is --- reasonable for simple programs. The GLUT routines also take relatively few --- parameters. --- --- The GLUT API is (as much as reasonable) window system independent. For this --- reason, GLUT does not return /any/ native window system handles, pointers, or --- other data structures. More subtle window system dependencies such as --- reliance on window system dependent fonts are avoided by GLUT; instead, GLUT --- supplies its own (limited) set of fonts. --- --- For programming ease, GLUT provides a simple menu sub-API. While the menuing --- support is designed to be implemented as pop-up menus, GLUT gives window --- system leeway to support the menu functionality in another manner (pull-down --- menus for example). --- --- Two of the most important pieces of GLUT state are the /current window/ and --- /current menu/. Most window and menu routines affect the /current window/ or --- /menu/ respectively. Most callbacks implicitly set the /current window/ and --- /menu/ to the appropriate window or menu responsible for the callback. GLUT --- is designed so that a program with only a single window and\/or menu will not --- need to keep track of any window or menu identifiers. This greatly simplifies --- very simple GLUT programs. --- --- GLUT is designed for simple to moderately complex programs focused on OpenGL --- rendering. GLUT implements its own event loop. For this reason, mixing GLUT --- with other APIs that demand their own event handling structure may be --- difficult. The advantage of a builtin event dispatch loop is simplicity. --- --- GLUT contains routines for rendering fonts and geometric objects, however --- GLUT makes no claims on the OpenGL display list name space. For this reason, --- none of the GLUT rendering routines use OpenGL display lists. It is up to the --- GLUT programmer to compile the output from GLUT rendering routines into --- display lists if this is desired. --- --- GLUT routines are logically organized into several sub-APIs according to --- their functionality. The sub-APIs are: --- --- * /Initialization:/ Command line processing, window system initialization, --- and initial window creation state are controlled by these routines. --- --- * /Beginning Event Processing:/ This routine enters GLUT\'s event processing --- loop. This routine never returns, and it continuously calls GLUT callbacks --- as necessary. --- --- * /Window Management:/ These routines create and control windows. --- --- * /Overlay Management:/ These routines establish and manage overlays for --- windows. --- --- * /Menu Management:/ These routines create and control pop-up menus. --- --- * /Callback Registration:/ These routines register callbacks to be called by --- the GLUT event processing loop. --- --- * /Color Index Colormap Management:/ These routines allow the manipulation --- of color index colormaps for windows. --- --- * /State Retrieval:/ These routines allows programs to retrieve state from --- GLUT. --- --- * /Font Rendering:/ These routines allow rendering of stroke and bitmap --- fonts. --- --- * /Geometric Shape Rendering:/ These routines allow the rendering of 3D --- geometric objects including spheres, cones, icosahedrons, and teapots. --- --- * /Debugging:/ This routine reports any pending GL errors. --- --- * /Device Control:/ These routines allow setting the key repeat and polling --- the joystick. --- --- * /Game Mode:/ These routines allow programs to enter\/leave a full-screen --- mode with specified properties. - --- Note that the following item has been left out intentionally, its --- implementation is too SGI-specific: --- * /Video Resizing:/ These routines provide a means for doing swap or frame --- synchronous resizing\/panning of the area that is to be magnified (or --- passed through) to the output video resolution. - ------------------------------------------------------------------------------ --- $APIVersions --- The GLUT API has undergone several revisions with increasing functionality. --- This Haskell binding provides access to everything in API version 4, --- although it is not yet officially finalized. Nevertheless, it provides very --- useful things like handling full-screen modes and special keys. - ------------------------------------------------------------------------------ --- $Conventions --- GLUT window and screen coordinates are expressed in pixels. The upper --- left hand corner of the screen or a window is (0,0). X coordinates --- increase in a rightward direction; Y coordinates increase in a --- downward direction. Note: This is inconsistent with OpenGL\'s --- coordinate scheme that generally considers the lower left hand --- coordinate of a window to be at (0,0) but is consistent with most --- popular window systems. - ------------------------------------------------------------------------------ --- $Terminology --- A number of terms are used in a GLUT-specific manner throughout this --- document. The GLUT meaning of these terms is independent of the window --- system GLUT is used with. Here are GLUT-specific meanings for the --- following GLUT-specific terms: --- --- * /Callback:/ A programmer specified routine that can be registered with --- GLUT to be called in response to a specific type of event. Also used to --- refer to a specific callback routine being called. --- --- * /Colormap:/ A mapping of pixel values to RGB color values. Used by color --- index windows. --- --- * /Dials and button box:/ A sophisticated input device consisting of a pad --- of buttons and an array of rotating dials, often used by computer-aided --- design programs. --- --- * /Display mode:/ A set of OpenGL frame buffer capabilities that can be --- attributed to a window. --- --- * /Idle:/ A state when no window system events are received for processing --- as callbacks and the idle callback, if one is registered, is called. --- --- * /Layer in use:/ Either the normal plane or overlay. This per-window state --- determines what frame buffer layer OpenGL commands affect. --- --- * /Menu entry:/ A menu item that the user can select to trigger the menu --- callback for the menu entry\'s value. --- --- * /Menu item:/ Either a menu entry or a sub-menu trigger. --- --- * /Modifiers:/ The Shift, Ctrl, and Alt keys that can be held down --- simultaneously with a key or mouse button being pressed or released. --- --- * /Multisampling:/ A technique for hardware antialiasing generally available --- only on expensive 3D graphics hardware. Each pixel is composed of a number --- of samples (each containing color and depth information). The samples are --- averaged to determine the displayed pixel color value. Multisampling is --- supported as an extension to OpenGL. --- --- * /Normal plane:/ The default frame buffer layer where GLUT window state --- resides; as opposed to the /overlay/. --- --- * /Overlay:/ A frame buffer layer that can be displayed preferentially to --- the /normal plane/ and supports transparency to display through to the --- /normal plane/. Overlays are useful for rubber-banding effects, text --- annotation, and other operations, to avoid damaging the normal plane frame --- buffer state. Overlays require hardware support not present on all systems. --- --- * /Pop:/ The act of forcing a window to the top of the stacking order for --- sibling windows. --- --- * /Pop-up menu:/ A menu that can be set to appear when a specified mouse --- button is pressed in a window. A pop-menu consists of multiple menu items. --- --- * /Push:/ The act of forcing a window to the bottom of the stacking order --- for sibling windows. --- --- * /Reshape:/ The act of changing the size or shape of the window. --- --- * /Spaceball:/ A sophisticated 3D input device that provides six degrees of --- freedom, three axes of rotation and three axes of translation. It also --- supports a number of buttons. The device is a hand-sized ball attached to --- a base. By cupping the ball with one\'s hand and applying torsional or --- directional force on the ball, rotations and translationsare generated. --- --- * /Stereo:/ A frame buffer capability providing left and right color buffers --- for creating stereoscopic renderings. Typically, the user wears LCD --- shuttered goggles synchronized with the alternating display on the screen --- of the left and right color buffers. --- --- * /Sub-menu:/ A menu cascaded from some sub-menu trigger. --- --- * /Sub-menu trigger:/ A menu item that the user can enter to cascade another --- pop-up menu. --- --- * /Subwindow:/ A type of window that is the child window of a top-level --- window or other subwindow. The drawing and visible region of a subwindow --- is limited by its parent window. --- --- * /Tablet:/ A precise 2D input device. Like a mouse, 2D coordinates are --- returned. The absolute position of the tablet \"puck\" on the tablet is --- returned. Tablets also support a number of buttons. --- --- * /Timer:/ A callback that can be scheduled to be called in a specified --- interval of time. --- --- * /Top-level window:/ A window that can be placed, moved, resized, etc. --- independently from other top-level windows by the user. Subwindows may --- reside within a top-level window. --- --- * /Window:/ A rectangular area for OpenGL rendering. --- --- * /Window display state:/ One of shown, hidden, or iconified. A shown window --- is potentially visible on the screen (it may be obscured by other windows --- and not actually visible). A hidden window will never be visible. An --- iconified window is not visible but could be made visible in response to --- some user action like clicking on the window\'s corresponding icon. --- --- * /Window system:/ A broad notion that refers to both the mechanism and --- policy of the window system. For example, in the X Window System both the --- window manager and the X server are integral to what GLUT considers the --- window system. diff --git a/Graphics/UI/GLUT/Begin.hs b/Graphics/UI/GLUT/Begin.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Begin.hs +++ /dev/null @@ -1,98 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Begin --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- After a GLUT program has done initial setup such as creating windows and --- menus, GLUT programs enter the GLUT event processing loop by calling --- 'mainLoop' or handle events iteratively with 'mainLoopEvent'. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Begin ( - -- * Handling events - mainLoop, mainLoopEvent, leaveMainLoop, - - -- * Controlling the behaviour when windows are closed - ActionOnWindowClose(..), actionOnWindowClose -) where - -import Data.StateVar -import Foreign.C.Types -import Graphics.UI.GLUT.QueryUtils -import Graphics.UI.GLUT.Raw - --------------------------------------------------------------------------------- - --- | Enter the GLUT event processing loop; it will call as necessary any --- callbacks that have been registered. This routine should be called at most --- once in a GLUT program. - -mainLoop :: IO () -mainLoop = glutMainLoop - --------------------------------------------------------------------------------- - --- | (/freeglut only/) Process one iteration's worth of events in its event loop. --- This allows the application to control its own event loop and still use the --- GLUT package. - -mainLoopEvent :: IO () -mainLoopEvent = glutMainLoopEvent - --------------------------------------------------------------------------------- - --- | (/freeglut only/) Stop the event loop. If 'actionOnWindowClose' contains --- 'Exit', the application will exit; otherwise control will return to the --- function which called 'mainLoop'. --- --- If the application has two nested calls to 'mainLoop' and calls --- 'leaveMainLoop', the behaviour is undefined. It may leave only the inner --- nested loop or it may leave both loops. If the reader has a strong preference --- for one behaviour over the other he should contact the freeglut Programming --- Consortium and ask for the code to be fixed. - -leaveMainLoop :: IO () -leaveMainLoop = glutLeaveMainLoop - --------------------------------------------------------------------------------- - --- | The behaviour when the user closes a window. - -data ActionOnWindowClose - = -- | Exit the whole program when any window is closed or 'leaveMainLoop' - -- is called (default). - Exit - | -- | Return from mainLoop when any window is closed. - MainLoopReturns - | -- | Return from mainLoop after the last window is closed. - ContinueExectuion - deriving ( Eq, Ord, Show ) - -marshalActionOnWindowClose :: ActionOnWindowClose -> CInt -marshalActionOnWindowClose x = case x of - Exit -> glut_ACTION_EXIT - MainLoopReturns -> glut_ACTION_GLUTMAINLOOP_RETURNS - ContinueExectuion -> glut_ACTION_CONTINUE_EXECUTION - -unmarshalActionOnWindowClose :: CInt -> ActionOnWindowClose -unmarshalActionOnWindowClose x - | x == glut_ACTION_EXIT = Exit - | x == glut_ACTION_GLUTMAINLOOP_RETURNS = MainLoopReturns - | x == glut_ACTION_CONTINUE_EXECUTION = ContinueExectuion - | otherwise = error ("unmarshalActionOnWindowClose: illegal value " ++ show x) - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Controls the behaviour when the user closes a window. - -actionOnWindowClose :: StateVar ActionOnWindowClose -actionOnWindowClose = - makeStateVar - (simpleGet unmarshalActionOnWindowClose glut_ACTION_ON_WINDOW_CLOSE) - (glutSetOption glut_ACTION_ON_WINDOW_CLOSE . marshalActionOnWindowClose) diff --git a/Graphics/UI/GLUT/Callbacks.hs b/Graphics/UI/GLUT/Callbacks.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Callbacks.hs +++ /dev/null @@ -1,47 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Callbacks --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- --- GLUT supports a number of callbacks to respond to events. There are three --- types of callbacks: window, menu, and global. Window callbacks indicate when --- to redisplay or reshape a window, when the visibility of the window changes, --- and when input is available for the window. Menu callbacks are described in --- "Graphics.UI.GLUT.Menu". The global callbacks manage the passing of time and --- menu usage. The calling order of callbacks between different windows is --- undefined. --- --- Callbacks for input events should be delivered to the window the event occurs --- in. Events should not propagate to parent windows. --- --- A callback of type @Foo@ can registered by setting @fooCallback@ to 'Just' --- the callback. Almost all callbacks can be de-registered by setting --- the corresponding @fooCallback@ to 'Nothing', the only exceptions being --- 'Graphics.UI.GLUT.Callbacks.Window.DisplayCallback' (can only be --- re-registered) and 'Graphics.UI.GLUT.Callbacks.Global.TimerCallback' (can\'t --- be unregistered). --- --- /X Implementation Notes:/ The X GLUT implementation uses the X Input --- extension to support sophisticated input devices: Spaceball, dial & button --- box, and digitizing tablet. Because the X Input extension does not mandate --- how particular types of devices are advertised through the extension, it is --- possible GLUT for X may not correctly support input devices that would --- otherwise be of the correct type. The X GLUT implementation will support the --- Silicon Graphics Spaceball, dial & button box, and digitizing tablet as --- advertised through the X Input extension. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Callbacks ( - module Graphics.UI.GLUT.Callbacks.Window, - module Graphics.UI.GLUT.Callbacks.Global -) where - -import Graphics.UI.GLUT.Callbacks.Window -import Graphics.UI.GLUT.Callbacks.Global diff --git a/Graphics/UI/GLUT/Callbacks/Global.hs b/Graphics/UI/GLUT/Callbacks/Global.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Callbacks/Global.hs +++ /dev/null @@ -1,113 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Callbacks.Global --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Callbacks.Global ( - -- * Menu status callback - MenuUsage(..), MenuStatusCallback, menuStatusCallback, - - -- * Idle callback - IdleCallback, idleCallback, - - -- * Timer callbacks - Timeout, TimerCallback, addTimerCallback -) where - -import Control.Monad.Fix -import Data.StateVar -import Foreign.C.Types -import Graphics.Rendering.OpenGL ( Position(..) ) -import Graphics.UI.GLUT.Callbacks.Registration -import Graphics.UI.GLUT.Raw - --------------------------------------------------------------------------------- - -data MenuUsage - = NotInUse - | InUse - deriving ( Eq, Ord, Show ) - -unmarshalMenuUsage :: CInt -> MenuUsage -unmarshalMenuUsage x - | x == glut_MENU_NOT_IN_USE = NotInUse - | x == glut_MENU_IN_USE = InUse - | otherwise = error ("unmarshalMenuUsage: illegal value " ++ show x) - -type MenuStatusCallback = MenuUsage -> Position -> IO () - --- | Controls the global menu status callback so a GLUT program can determine --- when a menu is in use or not. When a menu status callback is registered, it --- will be called with the value 'InUse' when pop-up menus are in use by the --- user; and the callback will be called with the value 'NotInUse' when pop-up --- menus are no longer in use. Additionally, the location in window coordinates --- of the button press that caused the menu to go into use, or the location where --- the menu was released (maybe outside the window). Other callbacks continue to --- operate (except mouse motion callbacks) when pop-up menus are in use so the --- menu status callback allows a program to suspend animation or other tasks --- when menus are in use. The cascading and unmapping of sub-menus from an --- initial pop-up menu does not generate menu status callbacks. There is a --- single menu status callback for GLUT. --- --- When the menu status callback is called, the /current menu/ will be set to --- the initial pop-up menu in both the 'InUse' and 'NotInUse' cases. The --- /current window/ will be set to the window from which the initial menu was --- popped up from, also in both cases. - -menuStatusCallback :: SettableStateVar (Maybe MenuStatusCallback) -menuStatusCallback = - makeSettableStateVar $ - setCallback MenuStatusCB glutMenuStatusFunc - (makeMenuStatusFunc . unmarshal) - where unmarshal cb s x y = - cb (unmarshalMenuUsage s) - (Position (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - -type IdleCallback = IO () - --- | Controls the global idle callback so a GLUT program can perform background --- processing tasks or continuous animation when window system events are not --- being received. If enabled, the idle callback is continuously called when --- events are not being received. The /current window/ and /current menu/ will --- not be changed before the idle callback. Programs with multiple windows --- and\/or menus should explicitly set the /current window/ and\/or /current --- menu/ and not rely on its current setting. --- --- The amount of computation and rendering done in an idle callback should be --- minimized to avoid affecting the program\'s interactive response. In general, --- not more than a single frame of rendering should be done in an idle callback. - -idleCallback :: SettableStateVar (Maybe IdleCallback) -idleCallback = - makeSettableStateVar $ setCallback IdleCB glutIdleFunc makeIdleFunc - --------------------------------------------------------------------------------- - --- | Timeout for the timer callback in milliseconds -type Timeout = Int - -type TimerCallback = IO () - --- | Register a one-shot timer callback to be triggered after at least the given --- amount of time. Multiple timer callbacks at same or differing times may be --- registered simultaneously. There is no support for canceling a registered --- callback. --- --- The number of milliseconds is a lower bound on the time before the callback --- is generated. GLUT attempts to deliver the timer callback as soon as possible --- after the expiration of the callback\'s time interval. - -addTimerCallback :: Timeout -> TimerCallback -> IO () -addTimerCallback msecs timerCallback = do - funPtr <- mfix (\self -> makeTimerFunc (\_ -> do registerForCleanup self - timerCallback)) - glutTimerFunc (fromIntegral msecs) funPtr 0 diff --git a/Graphics/UI/GLUT/Callbacks/Registration.hs b/Graphics/UI/GLUT/Callbacks/Registration.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Callbacks/Registration.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# OPTIONS_GHC -fno-cse #-} - --- #hide --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Callbacks.Registration --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Callbacks.Registration ( - CallbackType(..), registerForCleanup, setCallback, getCurrentWindow -) where - --------------------------------------------------------------------------------- - -import Control.Monad -import Data.IORef -import qualified Data.Map as Map ( empty, lookup, insert, delete ) -import Data.Map ( Map ) -import Data.StateVar -import Foreign.Ptr -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.Window - --------------------------------------------------------------------------------- --- No timer callback here, because they are one-shot and "self destroy" - -data CallbackType - = DisplayCB | OverlayDisplayCB | ReshapeCB - | KeyboardCB | KeyboardUpCB | MouseCB - | MotionCB | PassiveMotionCB | CrossingCB - | VisibilityCB | WindowStatusCB | SpecialCB - | SpecialUpCB | SpaceballMotionCB | SpaceballRotateCB - | SpaceballButtonCB | ButtonBoxCB | DialsCB - | TabletMotionCB | TabletButtonCB | JoystickCB - | MenuStatusCB | IdleCB - | CloseCB -- freeglut only - | MouseWheelCB -- freeglut only - deriving ( Eq, Ord ) - -isGlobal :: CallbackType -> Bool -isGlobal MenuStatusCB = True -isGlobal IdleCB = True -isGlobal _ = False - --------------------------------------------------------------------------------- --- To uniquely identify a particular callback, the associated window is needed --- for window callbacks. - -data CallbackID = CallbackID (Maybe Window) CallbackType - deriving ( Eq, Ord ) - -getCallbackID :: CallbackType -> IO CallbackID -getCallbackID callbackType = do - maybeWindow <- if isGlobal callbackType - then return Nothing - else fmap Just $ getCurrentWindow "getCallbackID" - return $ CallbackID maybeWindow callbackType - -getCurrentWindow :: String -> IO Window -getCurrentWindow func = do - win <- get currentWindow - maybe (error (func ++ ": no current window")) return win - --------------------------------------------------------------------------------- --- This seems to be a common Haskell hack nowadays: A plain old global variable --- with an associated mutator. Perhaps some language/library support is needed? - -{-# NOINLINE theCallbackTable #-} -theCallbackTable :: IORef (CallbackTable a) -theCallbackTable = unsafePerformIO (newIORef emptyCallbackTable) - -getCallbackTable :: IO (CallbackTable a) -getCallbackTable = readIORef theCallbackTable - -modifyCallbackTable :: (CallbackTable a -> CallbackTable a) -> IO () -modifyCallbackTable = modifyIORef theCallbackTable - --------------------------------------------------------------------------------- - -type CallbackTable a = Map CallbackID (FunPtr a) - -emptyCallbackTable :: CallbackTable a -emptyCallbackTable = Map.empty - -lookupInCallbackTable :: CallbackID -> IO (Maybe (FunPtr a)) -lookupInCallbackTable callbackID = - fmap (Map.lookup callbackID) getCallbackTable - -deleteFromCallbackTable :: CallbackID -> IO () -deleteFromCallbackTable callbackID = - modifyCallbackTable (Map.delete callbackID) - -addToCallbackTable :: CallbackID -> FunPtr a -> IO () -addToCallbackTable callbackID funPtr = - modifyCallbackTable (Map.insert callbackID funPtr) - --------------------------------------------------------------------------------- --- Another global mutable variable: The list of function pointers ready to be --- freed by freeHaskellFunPtr - -{-# NOINLINE theCleanupList #-} -theCleanupList :: IORef [FunPtr a] -theCleanupList = unsafePerformIO (newIORef []) - -getCleanupList :: IO [FunPtr a] -getCleanupList = readIORef theCleanupList - -setCleanupList :: [FunPtr a] -> IO () -setCleanupList = writeIORef theCleanupList - --------------------------------------------------------------------------------- --- And yet another mutable (write-once) variable: A function pointer to a --- callback which frees all function pointers on the cleanup list. - -{-# NOINLINE theScavenger #-} -theScavenger :: IORef (FunPtr TimerFunc) -theScavenger = unsafePerformIO (newIORef =<< makeTimerFunc (\_ -> do - cleanupList <- getCleanupList - mapM_ freeHaskellFunPtr cleanupList - setCleanupList [])) - -getScavenger :: IO (FunPtr TimerFunc) -getScavenger = readIORef theScavenger - --------------------------------------------------------------------------------- --- Here is the really cunning stuff: If an element is added to the cleanup list --- when it is empty, register an immediate callback at GLUT to free the list as --- soon as possible. - -registerForCleanup :: FunPtr a -> IO () -registerForCleanup funPtr = do - oldCleanupList <- getCleanupList - setCleanupList (funPtr : oldCleanupList) - when (null oldCleanupList) $ do - scavenger <- getScavenger - glutTimerFunc 0 scavenger 0 - --------------------------------------------------------------------------------- - -setCallback :: CallbackType -> (FunPtr a -> IO ()) -> (b -> IO (FunPtr a)) - -> Maybe b -> IO () -setCallback callbackType registerAtGLUT makeCallback maybeCallback = do - callbackID <- getCallbackID callbackType - maybeOldFunPtr <- lookupInCallbackTable callbackID - case maybeOldFunPtr of - Nothing -> return () - Just oldFunPtr -> do registerForCleanup oldFunPtr - deleteFromCallbackTable callbackID - case maybeCallback of - Nothing -> registerAtGLUT nullFunPtr - Just callback -> do newFunPtr <- makeCallback callback - addToCallbackTable callbackID newFunPtr - registerAtGLUT newFunPtr diff --git a/Graphics/UI/GLUT/Callbacks/Window.hs b/Graphics/UI/GLUT/Callbacks/Window.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Callbacks/Window.hs +++ /dev/null @@ -1,802 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Callbacks.Window --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Callbacks.Window ( - -- * Redisplay callbacks - DisplayCallback, displayCallback, overlayDisplayCallback, - - -- * Reshape callback - ReshapeCallback, reshapeCallback, - - -- * Callbacks for visibility changes - Visibility(..), VisibilityCallback, visibilityCallback, - WindowState(..), WindowStateCallback, windowStateCallback, - - -- * Window close callback - CloseCallback, closeCallback, - - -- * Keyboard and mouse input callback - Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..), - KeyboardMouseCallback, keyboardMouseCallback, - - -- * Mouse wheel callback - WheelNumber, WheelDirection, MouseWheelCallback, mouseWheelCallback, - - -- * Mouse movement callbacks - MotionCallback, motionCallback, passiveMotionCallback, - Crossing(..), CrossingCallback, crossingCallback, - - -- * Spaceball callback - SpaceballMotion, SpaceballRotation, ButtonIndex, SpaceballInput(..), - SpaceballCallback, spaceballCallback, - - -- * Dial & button box callback - DialAndButtonBoxInput(..), DialIndex, - DialAndButtonBoxCallback, dialAndButtonBoxCallback, - - -- * Tablet callback - TabletPosition(..), TabletInput(..), TabletCallback, tabletCallback, - - -- * Joystick callback - JoystickButtons(..), JoystickPosition(..), - JoystickCallback, joystickCallback -) where - -import Data.Bits hiding ( shift ) -import Data.Char -import Data.Maybe -import Data.StateVar -import Foreign.C.Types -import Graphics.Rendering.OpenGL ( Position(..), Size(..) ) -import Graphics.UI.GLUT.Callbacks.Registration -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.State -import Graphics.UI.GLUT.Types - --------------------------------------------------------------------------------- - --- | A display callback - -type DisplayCallback = IO () - --- | Controls the display callback for the /current window./ When GLUT determines --- that the normal plane for the window needs to be redisplayed, the display --- callback for the window is called. Before the callback, the /current window/ --- is set to the window needing to be redisplayed and (if no overlay display --- callback is registered) the /layer in use/ is set to the normal plane. The --- entire normal plane region should be redisplayed in response to the callback --- (this includes ancillary buffers if your program depends on their state). --- --- GLUT determines when the display callback should be triggered based on the --- window\'s redisplay state. The redisplay state for a window can be either set --- explicitly by calling 'Graphics.UI.GLUT.Window.postRedisplay' or implicitly --- as the result of window damage reported by the window system. Multiple posted --- redisplays for a window are coalesced by GLUT to minimize the number of --- display callbacks called. --- --- When an overlay is established for a window, but there is no overlay display --- callback registered, the display callback is used for redisplaying both the --- overlay and normal plane (that is, it will be called if either the redisplay --- state or overlay redisplay state is set). In this case, the /layer in use/ is --- not implicitly changed on entry to the display callback. --- --- See 'overlayDisplayCallback' to understand how distinct callbacks for the --- overlay and normal plane of a window may be established. --- --- When a window is created, no display callback exists for the window. It is --- the responsibility of the programmer to install a display callback for the --- window before the window is shown. A display callback must be registered for --- any window that is shown. If a window becomes displayed without a display --- callback being registered, a fatal error occurs. There is no way to --- \"deregister\" a display callback (though another callback routine can always --- be registered). --- --- Upon return from the display callback, the normal damaged state of the window --- (see 'Graphics.UI.GLUT.State.damaged') is cleared. If there is no overlay --- display callback registered the overlay damaged state of the window (see --- 'Graphics.UI.GLUT.State.damaged') is also cleared. - -displayCallback :: SettableStateVar DisplayCallback -displayCallback = makeSettableStateVar $ - setCallback DisplayCB glutDisplayFunc makeDisplayFunc . Just - --------------------------------------------------------------------------------- - --- | Controls the overlay display callback for the /current window./ The overlay --- display callback is functionally the same as the window\'s display callback --- except that the overlay display callback is used to redisplay the window\'s --- overlay. --- --- When GLUT determines that the overlay plane for the window needs to be --- redisplayed, the overlay display callback for the window is called. Before --- the callback, the /current window/ is set to the window needing to be --- redisplayed and the /layer in use/ is set to the overlay. The entire overlay --- region should be redisplayed in response to the callback (this includes --- ancillary buffers if your program depends on their state). --- --- GLUT determines when the overlay display callback should be triggered based --- on the window\'s overlay redisplay state. The overlay redisplay state for a --- window can be either set explicitly by calling --- 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay' or implicitly as the result --- of window damage reported by the window system. Multiple posted overlay --- redisplays for a window are coalesced by GLUT to minimize the number of --- overlay display callbacks called. --- --- Upon return from the overlay display callback, the overlay damaged state of --- the window (see 'Graphics.UI.GLUT.State.damaged') is cleared. --- --- Initially there is no overlay display callback registered when an overlay is --- established. See 'displayCallback' to understand how the display callback --- alone is used if an overlay display callback is not registered. - -overlayDisplayCallback :: SettableStateVar (Maybe DisplayCallback) -overlayDisplayCallback = makeSettableStateVar $ - setCallback OverlayDisplayCB glutOverlayDisplayFunc makeOverlayDisplayFunc - --------------------------------------------------------------------------------- - --- | A reshape callback - -type ReshapeCallback = Size -> IO () - --- | Controls the reshape callback for the /current window./ The reshape callback --- is triggered when a window is reshaped. A reshape callback is also triggered --- immediately before a window\'s first display callback after a window is --- created or whenever an overlay for the window is established. The parameter --- of the callback specifies the new window size in pixels. Before the callback, --- the /current window/ is set to the window that has been reshaped. --- --- If a reshape callback is not registered for a window or 'reshapeCallback' is --- set to 'Nothing' (to deregister a previously registered callback), the --- default reshape callback is used. This default callback will simply call --- --- @ --- 'Graphics.Rendering.OpenGL.GL.CoordTrans.viewport' ('Graphics.Rendering.OpenGL.GL.CoordTrans.Position' 0 0) ('Graphics.Rendering.OpenGL.GL.CoordTrans.Size' /width/ /height/) --- @ --- --- on the normal plane (and on the overlay if one exists). --- --- If an overlay is established for the window, a single reshape callback is --- generated. It is the callback\'s responsibility to update both the normal --- plane and overlay for the window (changing the layer in use as necessary). --- --- When a top-level window is reshaped, subwindows are not reshaped. It is up to --- the GLUT program to manage the size and positions of subwindows within a --- top-level window. Still, reshape callbacks will be triggered for subwindows --- when their size is changed using 'Graphics.UI.GLUT.Window.windowSize'. - -reshapeCallback :: SettableStateVar (Maybe ReshapeCallback) -reshapeCallback = makeSettableStateVar $ - setCallback ReshapeCB glutReshapeFunc (makeReshapeFunc . unmarshal) - where unmarshal cb w h = cb (Size (fromIntegral w) (fromIntegral h)) - --------------------------------------------------------------------------------- - --- | The visibility state of the /current window/ - -data Visibility - = NotVisible -- ^ No part of the /current window/ is visible, i.e., until the - -- window\'s visibility changes, all further rendering to the - -- window is discarded. - | Visible -- ^ The /current window/ is totally or partially visible. GLUT - -- considers a window visible if any pixel of the window is - -- visible or any pixel of any descendant window is visible on - -- the screen. - deriving ( Eq, Ord, Show ) - -unmarshalVisibility :: CInt -> Visibility -unmarshalVisibility x - | x == glut_NOT_VISIBLE = NotVisible - | x == glut_VISIBLE = Visible - | otherwise = error ("unmarshalVisibility: illegal value " ++ show x) - --------------------------------------------------------------------------------- - --- | A visibility callback - -type VisibilityCallback = Visibility -> IO () - --- | Controls the visibility callback for the /current window./ The visibility --- callback for a window is called when the visibility of a window changes. --- --- If the visibility callback for a window is disabled and later re-enabled, the --- visibility status of the window is undefined; any change in window visibility --- will be reported, that is if you disable a visibility callback and re-enable --- the callback, you are guaranteed the next visibility change will be reported. --- --- Note that you can either use 'visibilityCallback' or 'windowStateCallback', --- but not both, because the former is implemented via the latter. - -visibilityCallback :: SettableStateVar (Maybe VisibilityCallback) -visibilityCallback = makeSettableStateVar $ - setCallback VisibilityCB glutVisibilityFunc - (makeVisibilityFunc . unmarshal) - where unmarshal cb = cb . unmarshalVisibility - --------------------------------------------------------------------------------- - --- | The window state of the /current window/ - -data WindowState - = Unmapped -- ^ The /current window/ is unmapped. - | FullyRetained -- ^ The /current window/ is unobscured. - | PartiallyRetained -- ^ The /current window/ is partially obscured. - | FullyCovered -- ^ The /current window/ is fully obscured. - deriving ( Eq, Ord, Show ) - -unmarshalWindowState :: CInt -> WindowState -unmarshalWindowState x - | x == glut_HIDDEN = Unmapped - | x == glut_FULLY_RETAINED = FullyRetained - | x == glut_PARTIALLY_RETAINED = PartiallyRetained - | x == glut_FULLY_COVERED = FullyCovered - | otherwise = error ("unmarshalWindowState: illegal value " ++ show x) - --------------------------------------------------------------------------------- - --- | A window state callback - -type WindowStateCallback = WindowState -> IO () - --- | Controls the window state callback for the --- /current window./ The window state callback for a window is called when the --- window state of a window changes. --- --- If the window state callback for a window is disabled and later re-enabled, --- the window state state of the window is undefined; any change in the window --- state will be reported, that is if you disable a window state callback and --- re-enable the callback, you are guaranteed the next window state change will --- be reported. --- --- Note that you can either use 'visibilityCallback' or 'windowStateCallback', --- but not both, because the former is implemented via the latter. - -windowStateCallback :: SettableStateVar (Maybe WindowStateCallback) -windowStateCallback = makeSettableStateVar $ - setCallback WindowStatusCB glutWindowStatusFunc - (makeWindowStatusFunc . unmarshal) - where unmarshal cb = cb . unmarshalWindowState - --------------------------------------------------------------------------------- - -type CloseCallback = IO () - -closeCallback :: SettableStateVar (Maybe CloseCallback) -closeCallback = makeSettableStateVar $ - setCallback CloseCB glutCloseFunc makeCloseFunc - --------------------------------------------------------------------------------- - -type KeyboardCallback = Char -> Position -> IO () - -setKeyboardCallback :: Maybe KeyboardCallback -> IO () -setKeyboardCallback = - setCallback KeyboardCB glutKeyboardFunc (makeKeyboardFunc . unmarshal) - where unmarshal cb c x y = cb (chr (fromIntegral c)) - (Position (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - -setKeyboardUpCallback :: Maybe KeyboardCallback -> IO () -setKeyboardUpCallback = - setCallback KeyboardUpCB glutKeyboardUpFunc - (makeKeyboardUpFunc . unmarshal) - where unmarshal cb c x y = cb (chr (fromIntegral c)) - (Position (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - --- | Special keys - -data SpecialKey - = KeyF1 - | KeyF2 - | KeyF3 - | KeyF4 - | KeyF5 - | KeyF6 - | KeyF7 - | KeyF8 - | KeyF9 - | KeyF10 - | KeyF11 - | KeyF12 - | KeyLeft - | KeyUp - | KeyRight - | KeyDown - | KeyPageUp - | KeyPageDown - | KeyHome - | KeyEnd - | KeyInsert - | KeyNumLock - | KeyBegin - | KeyDelete - | KeyUnknown Int - deriving ( Eq, Ord, Show ) - -unmarshalSpecialKey :: CInt -> SpecialKey -unmarshalSpecialKey x - | x == glut_KEY_F1 = KeyF1 - | x == glut_KEY_F2 = KeyF2 - | x == glut_KEY_F3 = KeyF3 - | x == glut_KEY_F4 = KeyF4 - | x == glut_KEY_F5 = KeyF5 - | x == glut_KEY_F6 = KeyF6 - | x == glut_KEY_F7 = KeyF7 - | x == glut_KEY_F8 = KeyF8 - | x == glut_KEY_F9 = KeyF9 - | x == glut_KEY_F10 = KeyF10 - | x == glut_KEY_F11 = KeyF11 - | x == glut_KEY_F12 = KeyF12 - | x == glut_KEY_LEFT = KeyLeft - | x == glut_KEY_UP = KeyUp - | x == glut_KEY_RIGHT = KeyRight - | x == glut_KEY_DOWN = KeyDown - | x == glut_KEY_PAGE_UP = KeyPageUp - | x == glut_KEY_PAGE_DOWN = KeyPageDown - | x == glut_KEY_HOME = KeyHome - | x == glut_KEY_END = KeyEnd - | x == glut_KEY_INSERT = KeyInsert - | x == glut_KEY_NUM_LOCK = KeyNumLock - | x == glut_KEY_BEGIN = KeyBegin - | x == glut_KEY_DELETE = KeyDelete - | otherwise = KeyUnknown (fromIntegral x) - --------------------------------------------------------------------------------- - -type SpecialCallback = SpecialKey -> Position -> IO () - -setSpecialCallback :: Maybe SpecialCallback -> IO () -setSpecialCallback = - setCallback SpecialCB glutSpecialFunc (makeSpecialFunc . unmarshal) - where unmarshal cb k x y = cb (unmarshalSpecialKey k) - (Position (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - -setSpecialUpCallback :: Maybe SpecialCallback -> IO () -setSpecialUpCallback = - setCallback SpecialUpCB glutSpecialUpFunc (makeSpecialUpFunc . unmarshal) - where unmarshal cb k x y = cb (unmarshalSpecialKey k) - (Position (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - --- | The current state of a key or button - -data KeyState - = Down - | Up - deriving ( Eq, Ord, Show ) - -unmarshalKeyState :: CInt -> KeyState -unmarshalKeyState x - | x == glut_DOWN = Down - | x == glut_UP = Up - | otherwise = error ("unmarshalKeyState: illegal value " ++ show x) - --------------------------------------------------------------------------------- - -type MouseCallback = MouseButton -> KeyState -> Position -> IO () - -setMouseCallback :: Maybe MouseCallback -> IO () -setMouseCallback = - setCallback MouseCB glutMouseFunc (makeMouseFunc . unmarshal) - where unmarshal cb b s x y = cb (unmarshalMouseButton b) - (unmarshalKeyState s) - (Position (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - --- | The state of the keyboard modifiers - -data Modifiers = Modifiers { shift, ctrl, alt :: KeyState } - deriving ( Eq, Ord, Show ) - --- Could use fromBitfield + Enum/Bounded instances + marshalModifier instead... -unmarshalModifiers :: CInt -> Modifiers -unmarshalModifiers m = Modifiers { - shift = if (m .&. glut_ACTIVE_SHIFT) /= 0 then Down else Up, - ctrl = if (m .&. glut_ACTIVE_CTRL ) /= 0 then Down else Up, - alt = if (m .&. glut_ACTIVE_ALT ) /= 0 then Down else Up } - -getModifiers :: IO Modifiers -getModifiers = fmap unmarshalModifiers glutGetModifiers - --------------------------------------------------------------------------------- - --- | A generalized view of keys - -data Key - = Char Char - | SpecialKey SpecialKey - | MouseButton MouseButton - deriving ( Eq, Ord, Show ) - --- | A keyboard\/mouse callback - -type KeyboardMouseCallback = - Key -> KeyState -> Modifiers -> Position -> IO () - --- | Controls the keyboard\/mouse callback for the /current window./ The --- keyboard\/mouse callback for a window is called when the state of a key or --- mouse button changes. The callback parameters indicate the new state of the --- key\/button, the state of the keyboard modifiers, and the mouse location in --- window relative coordinates. - -keyboardMouseCallback :: SettableStateVar (Maybe KeyboardMouseCallback) -keyboardMouseCallback = makeSettableStateVar setKeyboardMouseCallback - -setKeyboardMouseCallback :: Maybe KeyboardMouseCallback -> IO () -setKeyboardMouseCallback Nothing = do - setKeyboardCallback Nothing - setKeyboardUpCallback Nothing - setSpecialCallback Nothing - setSpecialUpCallback Nothing - setMouseCallback Nothing -setKeyboardMouseCallback (Just cb) = do - setKeyboardCallback (Just (\c p -> do m <- getModifiers - cb (Char c) Down m p)) - setKeyboardUpCallback (Just (\c p -> do m <- getModifiers - cb (Char c) Up m p)) - setSpecialCallback (Just (\s p -> do m <- getModifiers - cb (SpecialKey s) Down m p)) - setSpecialUpCallback (Just (\s p -> do m <- getModifiers - cb (SpecialKey s) Up m p)) - setMouseCallback (Just (\b s p -> do m <- getModifiers - cb (MouseButton b) s m p)) - --------------------------------------------------------------------------------- - -type WheelNumber = Int - -type WheelDirection = Int - -type MouseWheelCallback = WheelNumber -> WheelDirection -> Position -> IO () - --- | (/freeglut only/) Controls the mouse wheel callback for the --- /current window./ The mouse wheel callback for a window is called when a --- mouse wheel is used and the wheel number is greater than or equal to --- 'Graphics.UI.GLUT.State.numMouseButtons'. - -mouseWheelCallback :: SettableStateVar (Maybe MouseWheelCallback) -mouseWheelCallback = makeSettableStateVar $ - setCallback MouseWheelCB glutMouseWheelFunc (makeMouseWheelFunc . unmarshal) - where unmarshal cb n d x y = cb (fromIntegral n) (fromIntegral d) - (Position (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - --- | A motion callback - -type MotionCallback = Position -> IO () - --- | Controls the motion callback for the /current window./ The motion callback --- for a window is called when the mouse moves within the window while one or --- more mouse buttons are pressed. The callback parameter indicates the mouse --- location in window relative coordinates. - -motionCallback :: SettableStateVar (Maybe MotionCallback) -motionCallback = makeSettableStateVar $ - setCallback MotionCB glutMotionFunc (makeMotionFunc . unmarshal) - where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - --- | Controls the passive motion callback for the /current window./ The passive --- motion callback for a window is called when the mouse moves within the window --- while /no/ mouse buttons are pressed. The callback parameter indicates the --- mouse location in window relative coordinates. - -passiveMotionCallback :: SettableStateVar (Maybe MotionCallback) -passiveMotionCallback = makeSettableStateVar $ - setCallback PassiveMotionCB glutPassiveMotionFunc - (makePassiveMotionFunc . unmarshal) - where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - --- | The relation between the mouse pointer and the /current window/ has --- changed. - -data Crossing - = WindowLeft -- ^ The mouse pointer has left the /current window./ - | WindowEntered -- ^ The mouse pointer has entered the /current window./ - deriving ( Eq, Ord, Show ) - -unmarshalCrossing :: CInt -> Crossing -unmarshalCrossing x - | x == glut_LEFT = WindowLeft - | x == glut_ENTERED = WindowEntered - | otherwise = error ("unmarshalCrossing: illegal value " ++ show x) - --------------------------------------------------------------------------------- - --- | An enter\/leave callback - -type CrossingCallback = Crossing -> IO () - --- | Controls the mouse enter\/leave callback for the /current window./ Note --- that some window systems may not generate accurate enter\/leave callbacks. --- --- /X Implementation Notes:/ An X implementation of GLUT should generate --- accurate enter\/leave callbacks. - -crossingCallback :: SettableStateVar (Maybe CrossingCallback) -crossingCallback = makeSettableStateVar $ - setCallback CrossingCB glutEntryFunc (makeEntryFunc . unmarshal) - where unmarshal cb = cb . unmarshalCrossing - --------------------------------------------------------------------------------- - --- | Translation of the Spaceball along one axis, normalized to be in the range --- of -1000 to +1000 inclusive - -type SpaceballMotion = Int - --- | Rotation of the Spaceball along one axis, normalized to be in the range --- of -1800 .. +1800 inclusive - -type SpaceballRotation = Int - --- | The index of a specific buttons of an input device. - -type ButtonIndex = Int - --- | The state of the Spaceball has changed. - -data SpaceballInput - = SpaceballMotion SpaceballMotion SpaceballMotion SpaceballMotion - | SpaceballRotation SpaceballRotation SpaceballRotation SpaceballRotation - | SpaceballButton ButtonIndex KeyState - deriving ( Eq, Ord, Show ) - --- | A SpaceballButton callback - -type SpaceballCallback = SpaceballInput -> IO () - --- | Controls the Spaceball callback for the /current window./ The Spaceball --- callback for a window is called when the window has Spaceball input focus --- (normally, when the mouse is in the window) and the user generates Spaceball --- translations, rotations, or button presses. The number of available Spaceball --- buttons can be determined with 'Graphics.UI.GLUT.State.numSpaceballButtons'. --- --- Registering a Spaceball callback when a Spaceball device is not available has --- no effect and is not an error. In this case, no Spaceball callbacks will be --- generated. - -spaceballCallback :: SettableStateVar (Maybe SpaceballCallback) -spaceballCallback = makeSettableStateVar setSpaceballCallback - -setSpaceballCallback :: Maybe SpaceballCallback -> IO () -setSpaceballCallback Nothing = do - setSpaceballMotionCallback Nothing - setSpaceballRotationCallback Nothing - setSpaceballButtonCallback Nothing -setSpaceballCallback (Just cb) = do - setSpaceballMotionCallback (Just (\x y z -> cb (SpaceballMotion x y z))) - setSpaceballRotationCallback (Just (\x y z -> cb (SpaceballRotation x y z))) - setSpaceballButtonCallback (Just (\b s -> cb (SpaceballButton b s))) - --------------------------------------------------------------------------------- - -type SpaceballMotionCallback = - SpaceballMotion -> SpaceballMotion -> SpaceballMotion -> IO () - -setSpaceballMotionCallback :: Maybe SpaceballMotionCallback -> IO () -setSpaceballMotionCallback = - setCallback SpaceballMotionCB glutSpaceballMotionFunc - (makeSpaceballMotionFunc . unmarshal) - where unmarshal cb x y z = - cb (fromIntegral x) (fromIntegral y) (fromIntegral z) - --------------------------------------------------------------------------------- - -type SpaceballRotationCallback = - SpaceballRotation -> SpaceballRotation -> SpaceballRotation -> IO () - -setSpaceballRotationCallback :: Maybe SpaceballRotationCallback -> IO () -setSpaceballRotationCallback = - setCallback SpaceballRotateCB glutSpaceballRotateFunc - (makeSpaceballRotateFunc . unmarshal) - where unmarshal cb x y z = - cb (fromIntegral x) (fromIntegral y) (fromIntegral z) - --------------------------------------------------------------------------------- - -type SpaceballButtonCallback = ButtonIndex -> KeyState -> IO () - -setSpaceballButtonCallback :: Maybe SpaceballButtonCallback -> IO () -setSpaceballButtonCallback = - setCallback SpaceballButtonCB glutSpaceballButtonFunc - (makeSpaceballButtonFunc . unmarshal) - where unmarshal cb b s = cb (fromIntegral b) (unmarshalKeyState s) - --------------------------------------------------------------------------------- - --- | The index of a specific dial of a dial and button box. - -type DialIndex = Int - --- | The dial & button box state has changed. - -data DialAndButtonBoxInput - = DialAndButtonBoxButton ButtonIndex KeyState - | DialAndButtonBoxDial DialIndex Int - deriving ( Eq, Ord, Show ) - --- | A dial & button box callback - -type DialAndButtonBoxCallback = DialAndButtonBoxInput -> IO () - --- | Controls the dial & button box callback for the /current window./ The dial --- & button box button callback for a window is called when the window has dial --- & button box input focus (normally, when the mouse is in the window) and the --- user generates dial & button box button presses or dial changes. The number --- of available dial & button box buttons and dials can be determined with --- 'Graphics.UI.GLUT.State.numDialsAndButtons'. --- --- Registering a dial & button box callback when a dial & button box device is --- not available is ineffectual and not an error. In this case, no dial & button --- box button will be generated. - -dialAndButtonBoxCallback :: SettableStateVar (Maybe DialAndButtonBoxCallback) -dialAndButtonBoxCallback = makeSettableStateVar setDialAndButtonBoxCallback - -setDialAndButtonBoxCallback :: Maybe DialAndButtonBoxCallback -> IO () -setDialAndButtonBoxCallback Nothing = do - setButtonBoxCallback Nothing - setDialsCallback Nothing -setDialAndButtonBoxCallback (Just cb) = do - setButtonBoxCallback (Just (\b s -> cb (DialAndButtonBoxButton b s))) - setDialsCallback (Just (\d x -> cb (DialAndButtonBoxDial d x))) - --------------------------------------------------------------------------------- - -type ButtonBoxCallback = ButtonIndex -> KeyState -> IO () - -setButtonBoxCallback :: Maybe ButtonBoxCallback -> IO () -setButtonBoxCallback = - setCallback ButtonBoxCB glutButtonBoxFunc (makeButtonBoxFunc . unmarshal) - where unmarshal cb b s = cb (fromIntegral b) (unmarshalKeyState s) - --------------------------------------------------------------------------------- - -type DialsCallback = DialIndex -> Int -> IO () - -setDialsCallback :: Maybe DialsCallback -> IO () -setDialsCallback = - setCallback DialsCB glutDialsFunc (makeDialsFunc . unmarshal) - where unmarshal cb d x = cb (fromIntegral d) (fromIntegral x) - --------------------------------------------------------------------------------- - --- | Absolute tablet position, with coordinates normalized to be in the range of --- 0 to 2000 inclusive - -data TabletPosition = TabletPosition Int Int - deriving ( Eq, Ord, Show ) - --- | The table state has changed. - -data TabletInput - = TabletMotion - | TabletButton ButtonIndex KeyState - deriving ( Eq, Ord, Show ) - --- | A tablet callback - -type TabletCallback = TabletInput -> TabletPosition -> IO () - --- | Controls the tablet callback for the /current window./ The tablet callback --- for a window is called when the window has tablet input focus (normally, when --- the mouse is in the window) and the user generates tablet motion or button --- presses. The number of available tablet buttons can be determined with --- 'Graphics.UI.GLUT.State.numTabletButtons'. --- --- Registering a tablet callback when a tablet device is not available is --- ineffectual and not an error. In this case, no tablet callbacks will be --- generated. - -tabletCallback :: SettableStateVar (Maybe TabletCallback) -tabletCallback = makeSettableStateVar setTabletCallback - -setTabletCallback :: Maybe TabletCallback -> IO () -setTabletCallback Nothing = do - setTabletMotionCallback Nothing - setTabletButtonCallback Nothing -setTabletCallback (Just cb) = do - setTabletMotionCallback (Just (\p -> cb TabletMotion p)) - setTabletButtonCallback (Just (\b s p -> cb (TabletButton b s) p)) - --------------------------------------------------------------------------------- - -type TabletMotionCallback = TabletPosition -> IO () - -setTabletMotionCallback :: Maybe TabletMotionCallback -> IO () -setTabletMotionCallback = - setCallback TabletMotionCB glutTabletMotionFunc - (makeTabletMotionFunc . unmarshal) - where unmarshal cb x y = - cb (TabletPosition (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - -type TabletButtonCallback = ButtonIndex -> KeyState -> TabletPosition -> IO () - -setTabletButtonCallback :: Maybe TabletButtonCallback -> IO () -setTabletButtonCallback = - setCallback TabletButtonCB glutTabletButtonFunc - (makeTabletButtonFunc . unmarshal) - where unmarshal cb b s x y = - cb (fromIntegral b) (unmarshalKeyState s) - (TabletPosition (fromIntegral x) (fromIntegral y)) - --------------------------------------------------------------------------------- - --- | The state of the joystick buttons - -data JoystickButtons = JoystickButtons { - joystickButtonA, joystickButtonB, - joystickButtonC, joystickButtonD :: KeyState } - deriving ( Eq, Ord, Show ) - --- Could use fromBitfield + Enum/Bounded instances + unmarshalJoystickButton --- instead... -unmarshalJoystickButtons :: CUInt -> JoystickButtons -unmarshalJoystickButtons m = JoystickButtons { - joystickButtonA = if (m .&. glut_JOYSTICK_BUTTON_A) /= 0 then Down else Up, - joystickButtonB = if (m .&. glut_JOYSTICK_BUTTON_B) /= 0 then Down else Up, - joystickButtonC = if (m .&. glut_JOYSTICK_BUTTON_C) /= 0 then Down else Up, - joystickButtonD = if (m .&. glut_JOYSTICK_BUTTON_D) /= 0 then Down else Up } - --------------------------------------------------------------------------------- - --- | Absolute joystick position, with coordinates normalized to be in the range --- of -1000 to 1000 inclusive. The signs of the three axes mean the following: --- --- * negative = left, positive = right --- --- * negative = towards player, positive = away --- --- * if available (e.g. rudder): negative = down, positive = up - -data JoystickPosition = JoystickPosition Int Int Int - deriving ( Eq, Ord, Show ) - --------------------------------------------------------------------------------- - --- | A joystick callback - -type JoystickCallback = JoystickButtons -> JoystickPosition -> IO () - --- | Controls the joystick callback for the /current window./ The joystick --- callback is called either due to polling of the joystick at the uniform timer --- interval specified (if > 0) or in response to an explicit call of --- 'Graphics.UI.GLUT.DeviceControl.forceJoystickCallback'. --- --- /X Implementation Notes:/ Currently GLUT has no joystick support for X11. - --- joystickCallback :: SettableStateVar (Maybe JoystickCallback, PollRate) -joystickCallback :: SettableStateVar (Maybe (JoystickCallback, PollRate)) -joystickCallback = - makeSettableStateVar $ \maybeCBAndRate -> - setCallback JoystickCB - (\f -> glutJoystickFunc f (fromIntegral (snd (fromJust maybeCBAndRate)))) - (makeJoystickFunc . unmarshal) - (fmap fst maybeCBAndRate) - where unmarshal cb b x y z = cb (unmarshalJoystickButtons b) - (JoystickPosition (fromIntegral x) - (fromIntegral y) - (fromIntegral z)) diff --git a/Graphics/UI/GLUT/Colormap.hs b/Graphics/UI/GLUT/Colormap.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Colormap.hs +++ /dev/null @@ -1,109 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Colormap --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- OpenGL supports both RGBA and color index rendering. The RGBA mode is --- generally preferable to color index because more OpenGL rendering --- capabilities are available and color index mode requires the loading of --- colormap entries. --- --- The GLUT color index state variables are used to read and write entries in a --- window\'s color index colormap. Every GLUT color index window has its own --- logical color index colormap. The size of a window\'s colormap can be --- determined by reading 'numColorMapEntries'. --- --- GLUT color index windows within a program can attempt to share colormap --- resources by copying a single color index colormap to multiple windows using --- 'copyColormap'. If possible GLUT will attempt to share the actual colormap. --- While copying colormaps using 'copyColormap' can potentially allow sharing of --- physical colormap resources, logically each window has its own colormap. So --- changing a copied colormap of a window will force the duplication of the --- colormap. For this reason, color index programs should generally load a --- single color index colormap, copy it to all color index windows within the --- program, and then not modify any colormap cells. --- --- Use of multiple colormaps is likely to result in colormap installation --- problems where some windows are displayed with an incorrect colormap due to --- limitations on colormap resources. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Colormap ( - colorMapEntry, - copyColormap, - numColorMapEntries, - transparentIndex -) where - -import Data.StateVar -import Foreign.C.Types -import Graphics.Rendering.OpenGL ( GLfloat, GLint, Color3(..), Index1(..) ) -import Graphics.UI.GLUT.QueryUtils -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.Types - --------------------------------------------------------------------------------- - --- | Controls the color index colormap entry of the /current window/\'s logical --- colormap for the /layer in use/. The /layer in use/ of the /current window/ --- should be a color index window. The color index should be zero or greater and --- less than the total number of colormap entries for the window (see --- 'numColorMapEntries') and different from an overlay\'s transparent index (see --- 'transparentIndex'). --- --- If the /layer in use/\'s colormap was copied by reference, setting a colormap --- entry will force the duplication of the colormap. - -colorMapEntry :: Index1 GLint -> StateVar (Color3 GLfloat) -colorMapEntry (Index1 cell) = - makeStateVar (getColorMapEntry (fromIntegral cell)) - (setColorMapEntry (fromIntegral cell)) - -setColorMapEntry :: CInt -> Color3 GLfloat -> IO () -setColorMapEntry cell (Color3 r g b) = glutSetColor cell r g b - -getColorMapEntry :: CInt -> IO (Color3 GLfloat) -getColorMapEntry cell = do - r <- glutGetColor cell glut_RED - g <- glutGetColor cell glut_GREEN - b <- glutGetColor cell glut_BLUE - return $ Color3 r g b - --------------------------------------------------------------------------------- - --- | Copy (lazily if possible to promote sharing) the logical colormap from a --- specified window to the /current window/\'s /layer in use/. The copy will be --- from the normal plane to the normal plane; or from the overlay to the overlay --- (never across different layers). Once a colormap has been copied, avoid --- setting cells in the colormap via 'colorMapEntry' since that will force an --- actual copy of the colormap if it was previously copied by reference. --- 'copyColormap' should only be called when both the /current window/ and the --- specified window are color index windows. - -copyColormap :: Window -> IO () -copyColormap (Window win) = glutCopyColormap win - --------------------------------------------------------------------------------- - --- | Contains the number of entries in the colormap of the /current window/\'s --- current layer (0 in RGBA mode). - -numColorMapEntries :: GettableStateVar GLint -numColorMapEntries = - makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_COLORMAP_SIZE - --------------------------------------------------------------------------------- - --- | Contains the transparent color index of the overlay of the /current window/ --- or -1 if no overlay is in use. - -transparentIndex :: GettableStateVar (Index1 GLint) -transparentIndex = - makeGettableStateVar $ - layerGet (Index1 . fromIntegral) glut_TRANSPARENT_INDEX diff --git a/Graphics/UI/GLUT/Debugging.hs b/Graphics/UI/GLUT/Debugging.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Debugging.hs +++ /dev/null @@ -1,38 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Debugging --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- This module contains a simple utility routine to report any pending GL --- errors. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Debugging ( - reportErrors -) where - -import Data.StateVar -import Graphics.Rendering.OpenGL ( Error(..), errors ) -import System.Environment -import System.IO - --------------------------------------------------------------------------------- - --- | Report any pending GL errors to stderr (which is typically the console). --- If there are no pending errors, this routine does nothing. Note that the --- error flags are reset after this action, i.e. there are no pending errors --- left afterwards. - -reportErrors :: IO () -reportErrors = get errors >>= mapM_ reportError - -reportError :: Error -> IO () -reportError (Error _ msg) = do - pn <- getProgName - hPutStrLn stderr ("GLUT: Warning in " ++ pn ++ ": GL error: " ++ msg) diff --git a/Graphics/UI/GLUT/DeviceControl.hs b/Graphics/UI/GLUT/DeviceControl.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/DeviceControl.hs +++ /dev/null @@ -1,122 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.DeviceControl --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- GLUT offers some routines for controlling the key repeat and polling the --- joystick. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.DeviceControl ( - GlobalKeyRepeat(..), globalKeyRepeat, - PerWindowKeyRepeat(..), perWindowKeyRepeat, - forceJoystickCallback -) where - -import Data.StateVar -import Foreign.C.Types -import Graphics.UI.GLUT.QueryUtils -import Graphics.UI.GLUT.Raw - --------------------------------------------------------------------------------- - --- | The state of the global key repeat - -data GlobalKeyRepeat - = GlobalKeyRepeatOff - | GlobalKeyRepeatOn - | GlobalKeyRepeatDefault - deriving ( Eq, Ord, Show ) - -marshalGlobalKeyRepeat :: GlobalKeyRepeat -> CInt -marshalGlobalKeyRepeat x = case x of - GlobalKeyRepeatOff -> glut_KEY_REPEAT_OFF - GlobalKeyRepeatOn -> glut_KEY_REPEAT_ON - GlobalKeyRepeatDefault -> glut_KEY_REPEAT_DEFAULT - -unmarshalGlobalKeyRepeat :: CInt -> GlobalKeyRepeat -unmarshalGlobalKeyRepeat x - | x == glut_KEY_REPEAT_OFF = GlobalKeyRepeatOff - | x == glut_KEY_REPEAT_ON = GlobalKeyRepeatOn - | x == glut_KEY_REPEAT_DEFAULT = GlobalKeyRepeatDefault - | otherwise = error ("unmarshalGlobalKeyRepeat: illegal value " ++ show x) - --------------------------------------------------------------------------------- - --- | Controls the key repeat mode for the window system on a global basis if --- possible. If supported by the window system, the key repeat can either be --- disabled, enabled, or set to the window system\'s default key repeat state. --- --- /X Implementation Notes:/ X11 sends @KeyPress@ events repeatedly when the --- window system\'s global auto repeat is enabled. 'perWindowKeyRepeat' can --- prevent these auto repeated keystrokes from being reported as keyboard or --- special callbacks, but there is still some minimal overhead by the X server --- to continually stream @KeyPress@ events to the GLUT application. The --- 'globalKeyRepeat' state variable can be used to actually disable the global --- sending of auto repeated @KeyPress@ events. Note that 'globalKeyRepeat' --- affects the global window system auto repeat state so other applications --- will not auto repeat if you disable auto repeat globally through --- 'globalKeyRepeat'. GLUT applications using the X11 GLUT implementation --- should disable key repeat with 'globalKeyRepeat' to disable key repeats most --- efficiently, but are responsible for explicitly restoring the default key --- repeat state on exit. --- --- /Win32 Implementation Notes:/ The Win32 implementation of 'globalKeyRepeat' --- does nothing. The 'perWindowKeyRepeat' can be used in the Win32 GLUT --- implementation to ignore repeated keys on a per-window basis without changing --- the global window system key repeat. - -globalKeyRepeat :: StateVar GlobalKeyRepeat -globalKeyRepeat = - makeStateVar (deviceGet unmarshalGlobalKeyRepeat glut_DEVICE_KEY_REPEAT) - (glutSetKeyRepeat . marshalGlobalKeyRepeat) - --------------------------------------------------------------------------------- - --- | The state of the per-window key repeat - -data PerWindowKeyRepeat - = PerWindowKeyRepeatOff - | PerWindowKeyRepeatOn - deriving ( Eq, Ord, Show ) - -marshalPerWindowKeyRepeat :: PerWindowKeyRepeat -> CInt -marshalPerWindowKeyRepeat x = case x of - PerWindowKeyRepeatOn -> 0 - PerWindowKeyRepeatOff -> 1 - -unmarshalPerWindowKeyRepeat :: CInt -> PerWindowKeyRepeat -unmarshalPerWindowKeyRepeat x - | x == 0 = PerWindowKeyRepeatOn - | otherwise = PerWindowKeyRepeatOff - --------------------------------------------------------------------------------- - --- | Controls if auto repeat keystrokes are reported to the /current window./ --- Ignoring auto repeated keystrokes is generally done in conjunction with using --- the 'Graphics.UI.GLUT.Callbacks.Window.keyboardMouseCallback'. If you do --- not ignore auto repeated keystrokes, your GLUT application will experience --- repeated release\/press callbacks. Games using the keyboard will typically --- want to ignore key repeat. - -perWindowKeyRepeat :: StateVar PerWindowKeyRepeat -perWindowKeyRepeat = - makeStateVar - (deviceGet unmarshalPerWindowKeyRepeat glut_DEVICE_IGNORE_KEY_REPEAT) - (glutIgnoreKeyRepeat . marshalPerWindowKeyRepeat) - --------------------------------------------------------------------------------- - --- | Execute the joystick callback set by --- 'Graphics.UI.GLUT.Callbacks.Window.joystickCallback' once (if one exists). --- This is done in a synchronous fashion within the current context, i.e. when --- 'forceJoystickCallback' returns, the callback will have already happened. - -forceJoystickCallback :: IO () -forceJoystickCallback = glutForceJoystickFunc diff --git a/Graphics/UI/GLUT/Fonts.hs b/Graphics/UI/GLUT/Fonts.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Fonts.hs +++ /dev/null @@ -1,183 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Fonts --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- GLUT supports two types of font rendering: stroke fonts, meaning each --- character is rendered as a set of line segments; and bitmap fonts, where each --- character is a bitmap generated with --- 'Graphics.Rendering.OpenGL.GL.Bitmaps.bitmap'. Stroke fonts have the --- advantage that because they are geometry, they can be arbitrarily scale and --- rendered. Bitmap fonts are less flexible since they are rendered as bitmaps --- but are usually faster than stroke fonts. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Fonts ( - Font(..), BitmapFont(..), StrokeFont(..), -) where - -import Data.Char -import Foreign.C.String -import Foreign.C.Types -import Foreign.Ptr -import Graphics.Rendering.OpenGL ( GLint, GLfloat ) -import Graphics.UI.GLUT.Raw - --------------------------------------------------------------------------------- - -class Font a where - -- | Render the string in the named font, without using any display lists. - -- Rendering a nonexistent character has no effect. - -- - -- If the font is a bitmap font, 'renderString' automatically sets the OpenGL - -- unpack pixel storage modes it needs appropriately and saves and restores - -- the previous modes before returning. The generated call to - -- 'Graphics.Rendering.OpenGL.GL.bitmap' will adjust the current raster - -- position based on the width of the string. - -- If the font is a stroke font, - -- 'Graphics.Rendering.OpenGL.GL.CoordTrans.translate' is used to translate - -- the current model view matrix to advance the width of the string. - - renderString :: a -> String -> IO () - - -- | For a bitmap font, return the width in pixels of a string. For a stroke - -- font, return the width in units. While the width of characters in a font - -- may vary (though fixed width fonts do not vary), the maximum height - -- characteristics of a particular font are fixed. - - stringWidth :: a -> String -> IO GLint - - -- | (/freeglut only/) For a bitmap font, return the maximum height of the - -- characters in the given font measured in pixels. For a stroke font, - -- return the width in units. - - fontHeight :: a -> IO GLfloat - -instance Font BitmapFont where - renderString = bitmapString - stringWidth = bitmapLength - fontHeight = bitmapHeight - - -instance Font StrokeFont where - renderString = strokeString - stringWidth = strokeLength - fontHeight = strokeHeight - --------------------------------------------------------------------------------- - --- | The bitmap fonts available in GLUT. The exact bitmap to be used is --- defined by the standard X glyph bitmaps for the X font with the given name. - -data BitmapFont - = Fixed8By13 -- ^ A fixed width font with every character fitting in an 8 - -- by 13 pixel rectangle. - -- (@-misc-fixed-medium-r-normal--13-120-75-75-C-80-iso8859-1@) - | Fixed9By15 -- ^ A fixed width font with every character fitting in an 9 - -- by 15 pixel rectangle. - -- (@-misc-fixed-medium-r-normal--15-140-75-75-C-90-iso8859-1@) - | TimesRoman10 -- ^ A 10-point proportional spaced Times Roman font. - -- (@-adobe-times-medium-r-normal--10-100-75-75-p-54-iso8859-1@) - | TimesRoman24 -- ^ A 24-point proportional spaced Times Roman font. - -- (@-adobe-times-medium-r-normal--24-240-75-75-p-124-iso8859-1@) - | Helvetica10 -- ^ A 10-point proportional spaced Helvetica font. - -- (@-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1@) - | Helvetica12 -- ^ A 12-point proportional spaced Helvetica font. - -- (@-adobe-helvetica-medium-r-normal--12-120-75-75-p-67-iso8859-1@) - | Helvetica18 -- ^ A 18-point proportional spaced Helvetica font. - -- (@-adobe-helvetica-medium-r-normal--18-180-75-75-p-98-iso8859-1@) - deriving ( Eq, Ord, Show ) - --- Alas, fonts in GLUT are not denoted by some integral value, but by opaque --- pointers on the C side. Even worse: For WinDoze, they are simply small ints, --- casted to void*, for other platforms addresses of global variables are used. --- And all is done via ugly #ifdef-ed #defines... Aaaaargl! So the only portable --- way is using integers on the Haskell side and doing the marshaling via some --- small C wrappers around those macros. *sigh* -type GLUTbitmapFont = Ptr () - -marhshalBitmapFont :: BitmapFont -> IO GLUTbitmapFont -marhshalBitmapFont x = case x of - Fixed8By13 -> hs_GLUT_marshalBitmapFont 0 - Fixed9By15 -> hs_GLUT_marshalBitmapFont 1 - TimesRoman10 -> hs_GLUT_marshalBitmapFont 2 - TimesRoman24 -> hs_GLUT_marshalBitmapFont 3 - Helvetica10 -> hs_GLUT_marshalBitmapFont 4 - Helvetica12 -> hs_GLUT_marshalBitmapFont 5 - Helvetica18 -> hs_GLUT_marshalBitmapFont 6 - --------------------------------------------------------------------------------- - --- | The stroke fonts available in GLUT. -data StrokeFont - = Roman -- ^ A proportionally spaced Roman Simplex font for ASCII - -- characters 32 through 127. The maximum top character in the - -- font is 119.05 units; the bottom descends 33.33 units. - | MonoRoman -- ^ A mono-spaced spaced Roman Simplex font (same characters as - -- 'Roman') for ASCII characters 32 through 127. The maximum - -- top character in the font is 119.05 units; the bottom - -- descends 33.33 units. Each character is 104.76 units wide. - deriving ( Eq, Ord, Show ) - --- Same remarks as for GLUTbitmapFont -type GLUTstrokeFont = Ptr () - -marhshalStrokeFont :: StrokeFont -> IO GLUTstrokeFont -marhshalStrokeFont x = case x of - Roman -> hs_GLUT_marshalStrokeFont 0 - MonoRoman -> hs_GLUT_marshalStrokeFont 1 - --------------------------------------------------------------------------------- - -bitmapString :: BitmapFont -> String -> IO () -bitmapString f s = do - i <- marhshalBitmapFont f - mapM_ (\c -> withChar c (glutBitmapCharacter i)) s - -withChar :: Char -> (CInt -> IO a) -> IO a -withChar c f = f . fromIntegral . ord $ c - --------------------------------------------------------------------------------- - -strokeString :: StrokeFont -> String -> IO () -strokeString f s = do - i <- marhshalStrokeFont f - mapM_ (\c -> withChar c (glutStrokeCharacter i)) s - --------------------------------------------------------------------------------- - -bitmapLength :: BitmapFont -- ^ Bitmap font to use. - -> String -- ^ String to return width of (not confined to 8 - -- bits). - -> IO GLint -- ^ Width in pixels. -bitmapLength f s = do - i <- marhshalBitmapFont f - fmap fromIntegral $ withCString s (glutBitmapLength i . castPtr) - --------------------------------------------------------------------------------- - -strokeLength :: StrokeFont -- ^ Stroke font to use. - -> String -- ^ String to return width of (not confined to 8 - -- bits). - -> IO GLint -- ^ Width in units. -strokeLength f s = do - i <- marhshalStrokeFont f - fmap fromIntegral $ withCString s (glutStrokeLength i . castPtr) - --------------------------------------------------------------------------------- - -bitmapHeight :: BitmapFont -- ^ Bitmap font to use. - -> IO GLfloat -- ^ Height in pixels. -bitmapHeight f = fmap fromIntegral $ glutBitmapHeight =<< marhshalBitmapFont f - --------------------------------------------------------------------------------- - -strokeHeight :: StrokeFont -- ^ Stroke font to use. - -> IO GLfloat -- ^ Height in units. -strokeHeight f = glutStrokeHeight =<< marhshalStrokeFont f diff --git a/Graphics/UI/GLUT/GameMode.hs b/Graphics/UI/GLUT/GameMode.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/GameMode.hs +++ /dev/null @@ -1,188 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.GameMode --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- In addition to the functionality offered by --- 'Graphics.UI.GLUT.Window.fullScreen', GLUT offers an sub-API to change the --- screen resolution, color depth, and refresh rate of the display for a single --- full screen window. This mode of operation is called /game mode/, and is --- restricted in various ways: No pop-up menus are allowed for this full screen --- window, no other (sub-)windows can be created, and all other applications are --- hidden. --- --- /X Implementation Notes:/ Note that game mode is not fully supported in the --- original GLUT for X, it is essentially the same as using --- 'Graphics.UI.GLUT.Window.fullScreen'. The GLUT clone freeglut --- (see ) does not have this restriction. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.GameMode ( - GameModeCapability(..), GameModeCapabilityDescription(..), - gameModeCapabilities, enterGameMode, leaveGameMode, - BitsPerPlane, RefreshRate, GameModeInfo(..), gameModeInfo, - gameModeActive -) where - -import Data.List -import Data.StateVar -import Foreign.C.String -import Graphics.Rendering.OpenGL ( GLenum, Size(..) ) -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.Types - --------------------------------------------------------------------------------- - --- | Capabilities for 'gameModeCapabilities' - -data GameModeCapability - = GameModeWidth -- ^ Width of the screen resolution in pixels - | GameModeHeight -- ^ Height of the screen resolution in pixels - | GameModeBitsPerPlane -- ^ Color depth of the screen in bits - | GameModeRefreshRate -- ^ Refresh rate in Hertz - | GameModeNum -- ^ Match the Nth frame buffer configuration - -- compatible with the given capabilities - -- (numbering starts at 1) - deriving ( Eq, Ord, Show ) - -gameModeCapabilityToString :: GameModeCapability -> String -gameModeCapabilityToString x = case x of - GameModeWidth -> "width" - GameModeHeight -> "height" - GameModeBitsPerPlane -> "bpp" - GameModeRefreshRate -> "hertz" - GameModeNum -> "num" - --- | A single capability description for 'gameModeCapabilities'. - -data GameModeCapabilityDescription = Where' GameModeCapability Relation Int - deriving ( Eq, Ord, Show ) - -gameModeCapabilityDescriptionToString :: GameModeCapabilityDescription -> String -gameModeCapabilityDescriptionToString (Where' c r i) = - gameModeCapabilityToString c ++ relationToString r ++ show i - --------------------------------------------------------------------------------- - --- | Controls the /game mode/ to be used when 'enterGameMode' is called. It is --- described by a list of zero or more capability descriptions, which are --- translated into a set of criteria used to select the appropriate screen --- configuration. The criteria are matched in strict left to right order of --- precdence. That is, the first specified criterion (leftmost) takes precedence --- over the later criteria for non-exact criteria --- ('Graphics.UI.GLUT.Initialization.IsGreaterThan', --- 'Graphics.UI.GLUT.Initialization.IsLessThan', etc.). Exact criteria --- ('Graphics.UI.GLUT.Initialization.IsEqualTo', --- 'Graphics.UI.GLUT.Initialization.IsNotEqualTo') must match exactly so --- precedence is not relevant. --- --- To determine which configuration will actually be tried by 'enterGameMode' --- (if any), use 'gameModeInfo'. --- --- Note that even for game mode the current values of --- 'Graphics.UI.GLUT.Initialization.initialDisplayMode'or --- 'Graphics.UI.GLUT.Initialization.initialDisplayCapabilities' will --- determine which buffers are available, if double buffering is used or not, --- etc. - -gameModeCapabilities :: SettableStateVar [GameModeCapabilityDescription] -gameModeCapabilities = makeSettableStateVar $ \ds -> - withCString (descriptionsToString ds) glutGameModeString - --- freeglut currently handles only simple game mode descriptions like "WxH:B@R", --- so we try hard to use this format instead of the more general format allowed --- by the "real" GLUT. -descriptionsToString :: [GameModeCapabilityDescription] -> String -descriptionsToString ds = - let ws = [ x | Where' GameModeWidth IsEqualTo x <- ds ] - hs = [ x | Where' GameModeHeight IsEqualTo x <- ds ] - bs = [ x | Where' GameModeBitsPerPlane IsEqualTo x <- ds ] - rs = [ x | Where' GameModeRefreshRate IsEqualTo x <- ds ] - allSimple = (length ws + length hs + length bs + length rs) == (length ds) - dimensionsOK = (null ws) == (null hs) - in if allSimple && dimensionsOK - then simpleCapStr ws hs bs rs - else generalCapStr ds - -simpleCapStr :: [Int] -> [Int] -> [Int] -> [Int] -> String -simpleCapStr ws hs bs rs = - showCap "" ws ++ showCap "x" hs ++ showCap ":" bs ++ showCap "@" rs - where showCap _ [] = "" - showCap prefix (x:_) = prefix ++ show x - -generalCapStr :: [GameModeCapabilityDescription] -> String -generalCapStr = - concat . intersperse " " . map gameModeCapabilityDescriptionToString - --------------------------------------------------------------------------------- - --- | Enter /game mode/, trying to change resolution, refresh rate, etc., as --- specified by the current value of 'gameModeCapabilities'. An identifier for --- the game mode window and a flag, indicating if the display mode actually --- changed, are returned. The game mode window is made the /current window/. --- --- Re-entering /game mode/ is allowed, the previous game mode window gets --- destroyed by this, and a new one is created. - -enterGameMode :: IO (Window, Bool) -enterGameMode = do - w <- glutEnterGameMode - c <- getBool glut_GAME_MODE_DISPLAY_CHANGED - return (Window w, c) - --------------------------------------------------------------------------------- - --- | Leave /game mode/, restoring the old display mode and destroying the game --- mode window. - -leaveGameMode :: IO () -leaveGameMode = glutLeaveGameMode - --------------------------------------------------------------------------------- - --- | The color depth of the screen, measured in bits (e.g. 8, 16, 24, 32, ...) - -type BitsPerPlane = Int - --- | The refresh rate of the screen, measured in Hertz (e.g. 60, 75, 100, ...) - -type RefreshRate = Int - -data GameModeInfo = GameModeInfo Size BitsPerPlane RefreshRate - deriving ( Eq, Ord, Show ) - --------------------------------------------------------------------------------- - --- | Return 'Just' the mode which would be tried by the next call to --- 'enterGameMode'. Returns 'Nothing' if the mode requested by the current value --- of 'gameModeCapabilities' is not possible, in which case 'enterGameMode' --- would simply create a full screen window using the current mode. - -gameModeInfo :: GettableStateVar (Maybe GameModeInfo) -gameModeInfo = makeGettableStateVar $ do - possible <- getBool glut_GAME_MODE_POSSIBLE - if possible - then do - w <- glutGameModeGet glut_GAME_MODE_WIDTH - h <- glutGameModeGet glut_GAME_MODE_HEIGHT - let size = Size (fromIntegral w) (fromIntegral h) - b <- glutGameModeGet glut_GAME_MODE_PIXEL_DEPTH - r <- glutGameModeGet glut_GAME_MODE_REFRESH_RATE - return $ Just $ GameModeInfo size (fromIntegral b) (fromIntegral r) - else return Nothing - -getBool :: GLenum -> IO Bool -getBool = fmap (/= 0) . glutGameModeGet - --------------------------------------------------------------------------------- - --- | Contains 'True' when the /game mode/ is active, 'False' otherwise. - -gameModeActive :: GettableStateVar Bool -gameModeActive = makeGettableStateVar $ getBool glut_GAME_MODE_ACTIVE diff --git a/Graphics/UI/GLUT/Initialization.hs b/Graphics/UI/GLUT/Initialization.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Initialization.hs +++ /dev/null @@ -1,770 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Initialization --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- Actions and state variables in this module are used to initialize GLUT state. --- The primary initialization routine is 'initialize', which should only be --- called exactly once in a GLUT program. No other GLUT or OpenGL actions should --- be called before 'initialize', apart from getting or setting the state --- variables in this module. --- --- The reason is that these state variables can be used to set default window --- initialization state that might be modified by the command processing done in --- 'initialize'. For example, 'initialWindowSize' can be set to @('Size' --- 400 400)@ before 'initialize' is called to indicate 400 by 400 is the --- program\'s default window size. Setting the initial window size or position --- before 'initialize' allows the GLUT program user to specify the initial size --- or position using command line arguments. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Initialization ( - -- * Primary initialization - initialize, getArgsAndInitialize, exit, - - -- * Initial window geometry - initialWindowPosition, initialWindowSize, - - -- * Setting the initial display mode (I) - DisplayMode(..), initialDisplayMode, displayModePossible, - - -- * Setting the initial display mode (II) - DisplayCapability(..), Relation(..), DisplayCapabilityDescription(..), - initialDisplayCapabilities, - - -- * Controlling the creation of rendering contexts - RenderingContext(..), renderingContext, - - -- * Direct\/indirect rendering - DirectRendering(..), directRendering, - - -- * OpenGL 3.x context support - initialContextVersion, ContextFlag(..), initialContextFlags, - ContextProfile(..), initialContextProfile -) where - -import Control.Monad -import Data.Bits -import Data.List -import 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 Graphics.Rendering.OpenGL ( Position(..), Size(..) ) -import Graphics.UI.GLUT.QueryUtils -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.Types -import System.Environment - --------------------------------------------------------------------------------- - --- | Given the program name and command line arguments, initialize the GLUT --- library and negotiate a session with the window system. During this --- process, 'initialize' may cause the termination of the GLUT program with an --- error message to the user if GLUT cannot be properly initialized. --- Examples of this situation include the failure to connect to the window --- system, the lack of window system support for OpenGL, and invalid command --- line options. --- --- 'initialize' also processes command line options, but the specific options --- parsed are window system dependent. Any command line arguments which are --- not GLUT-specific are returned. --- --- /X Implementation Notes:/ The X Window System specific options parsed by --- 'initialize' are as follows: --- --- * @-display /DISPLAY/@: Specify the X server to connect to. If not specified, --- the value of the @DISPLAY@ environment variable is used. --- --- * @-geometry /WxH+X+Y/@: Determines where windows should be created on the --- screen. The parameter following @-geometry@ should be formatted as a --- standard X geometry specification. The effect of using this option is to --- change the GLUT initial size and initial position the same as if --- 'initialWindowSize' or 'initialWindowPosition' were modified directly. --- --- * @-iconic@: Requests all top-level windows be created in an iconic state. --- --- * @-indirect@: Force the use of indirect OpenGL rendering contexts. --- --- * @-direct@: Force the use of direct OpenGL rendering contexts (not all GLX --- implementations support direct rendering contexts). A fatal error is --- generated if direct rendering is not supported by the OpenGL --- implementation. If neither @-indirect@ or @-direct@ are used to force a --- particular behavior, GLUT will attempt to use direct rendering if --- possible and otherwise fallback to indirect rendering. --- --- * @-gldebug@: After processing callbacks and\/or events, call --- 'Graphics.UI.GLUT.Debugging.reportErrors' to check if there are any pending --- OpenGL errors. Using this option is helpful in detecting OpenGL run-time --- errors. --- --- * @-sync@: Enable synchronous X protocol transactions. This option makes --- it easier to track down potential X protocol errors. - -initialize :: String -- ^ The program name. - -> [String] -- ^ The command line arguments - -> IO [String] -- ^ Non-GLUT command line arguments -initialize prog args = - with (1 + genericLength args) $ \argcBuf -> - withMany withCString (prog : args) $ \argvPtrs -> - withArray0 nullPtr argvPtrs $ \argvBuf -> do - glutInit argcBuf argvBuf - newArgc <- peek argcBuf - newArgvPtrs <- peekArray (fromIntegral newArgc) argvBuf - newArgv <- mapM peekCString newArgvPtrs - return $ tail newArgv - --- | Convenience action: Initialize GLUT, returning the program name and any --- non-GLUT command line arguments. - -getArgsAndInitialize :: IO (String, [String]) -getArgsAndInitialize = do - prog <- getProgName - args <- getArgs - nonGLUTArgs <- initialize prog args - return (prog, nonGLUTArgs) - ------------------------------------------------------------------------------ - --- | (/freeglut only/) De-initialize GLUT. After this, one has to use --- 'initialize' or 'getArgsAndInitialize' to initialize GLUT again. - -exit :: IO () -exit = glutExit - --------------------------------------------------------------------------------- - --- | Controls the /initial window position/. Windows created by --- 'Graphics.UI.GLUT.Window.createWindow' will be requested to be created with --- the current /initial window position/. The initial value of the /initial --- window position/ GLUT state is @'Size' (-1) (-1)@. If either the X or Y --- component of the /initial window position/ is negative, the actual window --- position is left to the window system to determine. --- --- The intent of the /initial window position/ is to provide a suggestion to --- the window system for a window\'s initial position. The window system is --- not obligated to use this information. Therefore, GLUT programs should not --- assume the window was created at the specified position. - -initialWindowPosition :: StateVar Position -initialWindowPosition = - makeStateVar getInitialWindowPosition setInitialWindowPosition - -getInitialWindowPosition :: IO Position -getInitialWindowPosition = do - x <- simpleGet fromIntegral glut_INIT_WINDOW_X - y <- simpleGet fromIntegral glut_INIT_WINDOW_Y - return $ Position x y - -setInitialWindowPosition :: Position -> IO () -setInitialWindowPosition (Position x y) = - glutInitWindowPosition (fromIntegral x) (fromIntegral y) - --------------------------------------------------------------------------------- - --- | Controls the /initial window size/. Windows created by --- 'Graphics.UI.GLUT.Window.createWindow' will be requested to be created with --- the current /initial window size/. The initial value of the /initial window --- size/ GLUT state is @'Size' 300 300@. If either the width or the height --- component of the /initial window size/ is non-positive, the actual window --- size is left to the window system to determine. --- --- The intent of the /initial window size/ is to provide a suggestion to the --- window system for a window\'s initial size. The window system is not --- obligated to use this information. Therefore, GLUT programs should not --- assume the window was created at the specified size. A GLUT program should --- use the window\'s reshape callback to determine the true size of the --- window. - -initialWindowSize :: StateVar Size -initialWindowSize = makeStateVar getInitialWindowSize setInitialWindowSize - -getInitialWindowSize :: IO Size -getInitialWindowSize = do - w <- simpleGet fromIntegral glut_INIT_WINDOW_WIDTH - h <- simpleGet fromIntegral glut_INIT_WINDOW_HEIGHT - return $ Size w h - -setInitialWindowSize :: Size -> IO () -setInitialWindowSize (Size w h) = - glutInitWindowSize (fromIntegral w) (fromIntegral h) - --------------------------------------------------------------------------------- - --- | A single aspect of a window which is to be created, used in conjunction --- with 'initialDisplayMode'. - -data DisplayMode - = RGBAMode - -- ^ Select an RGBA mode window. This is the default if neither 'RGBAMode' - -- nor 'IndexMode' are specified. - | RGBMode - -- ^ An alias for 'RGBAMode'. - | IndexMode - -- ^ Select a color index mode window. This overrides 'RGBAMode' if it is - -- also specified. - | LuminanceMode - -- ^ Select a window with a \"luminance\" color model. This model provides - -- the functionality of OpenGL\'s RGBA color model, but the green and blue - -- components are not maintained in the frame buffer. Instead each pixel\'s - -- red component is converted to an index between zero and - -- 'Graphics.UI.GLUT.Colormap.numColorMapEntries' and looked up in a - -- per-window color map to determine the color of pixels within the window. - -- The initial colormap of 'LuminanceMode' windows is initialized to be a - -- linear gray ramp, but can be modified with GLUT\'s colormap actions. - -- /Implementation Notes:/ 'LuminanceMode' is not supported on most OpenGL - -- platforms. - | WithAlphaComponent - -- ^ Select a window with an alpha component to the color buffer(s). - | WithAccumBuffer - -- ^ Select a window with an accumulation buffer. - | WithDepthBuffer - -- ^ Select a window with a depth buffer. - | WithStencilBuffer - -- ^ Select a window with a stencil buffer. - | WithAuxBuffers Int - -- ^ (/freeglut only/) Select a window with /n/ (1 .. 4) auxiliary buffers. - -- Any /n/ outside the range 1 .. 4 is a fatal error. - | SingleBuffered - -- ^ Select a single buffered window. This is the default if neither - -- 'DoubleBuffered' nor 'SingleBuffered' are specified. - | DoubleBuffered - -- ^ Select a double buffered window. This overrides 'SingleBuffered' if it - -- is also specified. - | Multisampling - -- ^ Select a window with multisampling support. If multisampling is not - -- available, a non-multisampling window will automatically be chosen. - -- Note: both the OpenGL client-side and server-side implementations must - -- support the @GLX_SAMPLE_SGIS@ extension for multisampling to be - -- available. Deprecated, use 'WithSamplesPerPixel'. - | WithSamplesPerPixel Int - -- ^ Select a window with multisampling, using the given samples per pixel. - | Stereoscopic - -- ^ Select a stereo window. - | Captionless - -- ^ Select a window without a caption (/freeglut only/). - | Borderless - -- ^ Select a window without any borders (/freeglut only/). - | SRGBMode - -- ^ Select an sRGB mode window (/freeglut only/). - deriving ( Eq, Ord, Show ) - -marshalDisplayMode :: DisplayMode -> CUInt -marshalDisplayMode m = case m of - RGBAMode -> glut_RGBA - RGBMode -> glut_RGB - IndexMode -> glut_INDEX - LuminanceMode -> glut_LUMINANCE - WithAlphaComponent -> glut_ALPHA - WithAccumBuffer -> glut_ACCUM - WithDepthBuffer -> glut_DEPTH - WithStencilBuffer -> glut_STENCIL - WithAuxBuffers 1 -> glut_AUX1 - WithAuxBuffers 2 -> glut_AUX2 - WithAuxBuffers 3 -> glut_AUX3 - WithAuxBuffers 4 -> glut_AUX4 - WithAuxBuffers n -> - error ("marshalDisplayMode: illegal number of auxiliary buffers: " ++ show n) - SingleBuffered -> glut_SINGLE - DoubleBuffered -> glut_DOUBLE - Multisampling -> glut_MULTISAMPLE - WithSamplesPerPixel _ -> error ("marshalDisplayMode: this should not happen") - Stereoscopic -> glut_STEREO - Captionless -> glut_CAPTIONLESS - Borderless -> glut_BORDERLESS - SRGBMode -> glut_SRGB - --------------------------------------------------------------------------------- - --- | Controls the /initial display mode/ used when creating top-level windows, --- subwindows, and overlays to determine the OpenGL display mode for the --- to-be-created window or overlay. --- --- Note that 'RGBAMode' selects the RGBA color model, but it does not request any --- bits of alpha (sometimes called an /alpha buffer/ or /destination alpha/) --- be allocated. To request alpha, specify 'WithAlphaComponent'. The same --- applies to 'LuminanceMode'. - -initialDisplayMode :: StateVar [DisplayMode] -initialDisplayMode = makeStateVar getInitialDisplayMode setInitialDisplayMode - -getInitialDisplayMode :: IO [DisplayMode] -getInitialDisplayMode = do - mode <- simpleGet fromIntegral glut_INIT_DISPLAY_MODE - let displayModes = i2dms (mode .&. complement glut_MULTISAMPLE) - if mode .&. glut_MULTISAMPLE == 0 - then return displayModes - else do - n <- get samplesPerPixel - return $ WithSamplesPerPixel n : displayModes - -i2dms :: CUInt -> [DisplayMode] -i2dms bitfield | IndexMode `elem` modes || LuminanceMode `elem` modes = modes - | otherwise = RGBAMode : modes - where modes = i2dmsWithoutRGBA bitfield - -i2dmsWithoutRGBA :: CUInt -> [DisplayMode] -i2dmsWithoutRGBA bitfield = - [ c | c <- [ IndexMode, LuminanceMode, WithAlphaComponent, - WithAccumBuffer, WithDepthBuffer, WithStencilBuffer, - WithAuxBuffers 1, WithAuxBuffers 2, WithAuxBuffers 3, - WithAuxBuffers 4, SingleBuffered, DoubleBuffered, Multisampling, - Stereoscopic, Captionless, Borderless, SRGBMode ] - , (bitfield .&. marshalDisplayMode c) /= 0 ] - -setInitialDisplayMode :: [DisplayMode] -> IO () -setInitialDisplayMode modes = do - let (spps, transformedModes) = mapAccumR handleMultisampling [] modes - mapM_ (samplesPerPixel $=) spps - glutInitDisplayMode (toBitfield marshalDisplayMode transformedModes) - -handleMultisampling :: [Int] -> DisplayMode -> ([Int], DisplayMode) -handleMultisampling spps (WithSamplesPerPixel spp) = (spp : spps, Multisampling) -handleMultisampling spps mode = (spps, mode) - -toBitfield :: (Bits b) => (a -> b) -> [a] -> b -toBitfield marshal = foldl (.|.) 0 . map marshal - --- | Contains 'True' if the /current display mode/ is supported, 'False' --- otherwise. - -displayModePossible :: GettableStateVar Bool -displayModePossible = - makeGettableStateVar $ simpleGet (/= 0) glut_DISPLAY_MODE_POSSIBLE - --------------------------------------------------------------------------------- - -samplesPerPixel :: StateVar Int -samplesPerPixel = makeStateVar getSamplesPerPixel setSamplesPerPixel - -getSamplesPerPixel :: IO Int -getSamplesPerPixel = do - m <- multisamplingSupported - if m - then simpleGet fromIntegral (fromIntegral glut_MULTISAMPLE) - else return defaultSamplesPerPixels - -defaultSamplesPerPixels :: Int -defaultSamplesPerPixels = 4 - -setSamplesPerPixel :: Int -> IO () -setSamplesPerPixel spp = do - m <- multisamplingSupported - when m $ - glutSetOption (fromIntegral glut_MULTISAMPLE) (fromIntegral spp) - -multisamplingSupported :: IO Bool -multisamplingSupported = isKnown "glutGetModeValues" - where isKnown = fmap (/= nullFunPtr) . getAPIEntryInternal - --------------------------------------------------------------------------------- - --- | Capabilities for 'initialDisplayCapabilities', most of them are extensions --- of the constructors of 'DisplayMode'. - -data DisplayCapability - = DisplayRGBA -- ^ Number of bits of red, green, blue, and alpha in the RGBA - -- color buffer. Default is \"'IsAtLeast' @1@\" for red, - -- green, blue, and alpha capabilities, and \"'IsEqualTo' - -- @1@\" for the RGBA color model capability. - | DisplayRGB -- ^ Number of bits of red, green, and blue in the RGBA color - -- buffer and zero bits of alpha color buffer precision. - -- Default is \"'IsAtLeast' @1@\" for the red, green, and - -- blue capabilities, and \"'IsNotLessThan' @0@\" for alpha - -- capability, and \"'IsEqualTo' @1@\" for the RGBA color - -- model capability. - | DisplayRed -- ^ Red color buffer precision in bits. Default is - -- \"'IsAtLeast' @1@\". - | DisplayGreen -- ^ Green color buffer precision in bits. Default is - -- \"'IsAtLeast' @1@\". - | DisplayBlue -- ^ Blue color buffer precision in bits. Default is - -- \"'IsAtLeast' @1@\". - | DisplayIndex -- ^ Boolean if the color model is color index or not. True is - -- color index. Default is \"'IsAtLeast' @1@\". - | DisplayBuffer -- ^ Number of bits in the color index color buffer. Default - -- is \"'IsAtLeast' @1@\". - | DisplaySingle -- ^ Boolean indicate the color buffer is single buffered. - -- Default is \"'IsEqualTo' @1@\". - | DisplayDouble -- ^ Boolean indicating if the color buffer is double - -- buffered. Default is \"'IsEqualTo' @1@\". - | DisplayAccA -- ^ Red, green, blue, and alpha accumulation buffer precision - -- in bits. Default is \"'IsAtLeast' @1@\" for red, green, - -- blue, and alpha capabilities. - | DisplayAcc -- ^ Red, green, and green accumulation buffer precision in - -- bits and zero bits of alpha accumulation buffer precision. - -- Default is \"'IsAtLeast' @1@\" for red, green, and blue - -- capabilities, and \"'IsNotLessThan' @0@\" for the alpha - -- capability. - | DisplayAlpha -- ^ Alpha color buffer precision in bits. Default is - -- \"'IsAtLeast' @1@\". - | DisplayDepth -- ^ Number of bits of precsion in the depth buffer. Default - -- is \"'IsAtLeast' @12@\". - | DisplayStencil -- ^ Number of bits in the stencil buffer. Default is - -- \"'IsNotLessThan' @1@\". - | DisplaySamples -- ^ Indicates the number of multisamples to use based on - -- GLX\'s @SGIS_multisample@ extension (for antialiasing). - -- Default is \"'IsNotGreaterThan' @4@\". This default means - -- that a GLUT application can request multisampling if - -- available by simply specifying \"'With' 'DisplaySamples'\". - | DisplayStereo -- ^ Boolean indicating the color buffer is supports - -- OpenGL-style stereo. Default is \"'IsEqualTo' @1@\". - | DisplayLuminance -- ^ Number of bits of red in the RGBA and zero bits of green, - -- blue (alpha not specified) of color buffer precision. - -- Default is \"'IsAtLeast' @1@\" for the red capabilitis, - -- and \"'IsEqualTo' @0@\" for the green and blue - -- capabilities, and \"'IsEqualTo' @1@\" for the RGBA color - -- model capability, and, for X11, \"'IsEqualTo' @1@\" for - -- the 'DisplayXStaticGray' capability. SGI InfiniteReality (and - -- other future machines) support a 16-bit luminance (single - -- channel) display mode (an additional 16-bit alpha channel - -- can also be requested). The red channel maps to gray - -- scale and green and blue channels are not available. A - -- 16-bit precision luminance display mode is often - -- appropriate for medical imaging applications. Do not - -- expect many machines to support extended precision - -- luminance display modes. - | DisplayAux -- ^ (/freeglut only/) Number of auxiliary buffers. Default is - -- \"'IsEqualTo' @1@\". - | DisplayNum -- ^ A special capability name indicating where the value - -- represents the Nth frame buffer configuration matching - -- the description string. When not specified, - -- 'initialDisplayCapabilities' also uses the first - -- (best matching) configuration. 'Num' requires a relation - -- and numeric value. - | DisplayConformant -- ^ Boolean indicating if the frame buffer configuration is - -- conformant or not. Conformance information is based on - -- GLX\'s @EXT_visual_rating@ extension if supported. If the - -- extension is not supported, all visuals are assumed - -- conformant. Default is \"'IsEqualTo' @1@\". - | DisplaySlow -- ^ Boolean indicating if the frame buffer configuration is - -- slow or not. Slowness information is based on GLX\'s - -- @EXT_visual_rating@ extension if supported. If the - -- extension is not supported, all visuals are assumed fast. - -- Note that slowness is a relative designation relative to - -- other frame buffer configurations available. The intent - -- of the slow capability is to help programs avoid frame - -- buffer configurations that are slower (but perhaps higher - -- precision) for the current machine. Default is - -- \"'IsAtLeast' @0@\". This default means that slow visuals - -- are used in preference to fast visuals, but fast visuals - -- will still be allowed. - | DisplayWin32PFD -- ^ Only recognized on GLUT implementations for Win32, this - -- capability name matches the Win32 Pixel Format Descriptor - -- by number. 'DisplayWin32PFD' can only be used with 'Where'. - | DisplayXVisual -- ^ Only recongized on GLUT implementations for the X Window - -- System, this capability name matches the X visual ID by - -- number. 'DisplayXVisual' requires a relation and numeric value. - | DisplayXStaticGray -- ^ Only recongized on GLUT implementations for the X Window - -- System, boolean indicating if the frame buffer - -- configuration\'s X visual is of type @StaticGray@. - -- Default is \"'IsEqualTo' @1@\". - | DisplayXGrayScale -- ^ Only recongized on GLUT implementations for the X Window - -- System, boolean indicating if the frame buffer - -- configuration\'s X visual is of type @GrayScale@. Default - -- is \"'IsEqualTo' @1@\". - | DisplayXStaticColor -- ^ Only recongized on GLUT implementations for the X Window - -- System, boolean indicating if the frame buffer - -- configuration\'s X visual is of type @StaticColor@. - -- Default is \"'IsEqualTo' @1@\". - | DisplayXPseudoColor -- ^ Only recongized on GLUT implementations for the X Window - -- System, boolean indicating if the frame buffer - -- configuration\'s X visual is of type @PsuedoColor@. - -- Default is \"'IsEqualTo' @1@\". - | DisplayXTrueColor -- ^ Only recongized on GLUT implementations for the X Window - -- System, boolean indicating if the frame buffer - -- configuration\'s X visual is of type @TrueColor@. Default - -- is \"'IsEqualTo' @1@\". - | DisplayXDirectColor -- ^ Only recongized on GLUT implementations for the X Window - -- System, boolean indicating if the frame buffer - -- configuration\'s X visual is of type @DirectColor@. - -- Default is \"'IsEqualTo' @1@\". - deriving ( Eq, Ord, Show ) - -displayCapabilityToString :: DisplayCapability -> String -displayCapabilityToString x = case x of - DisplayRGBA -> "rgba" - DisplayRGB -> "rgb" - DisplayRed -> "red" - DisplayGreen -> "green" - DisplayBlue -> "blue" - DisplayIndex -> "index" - DisplayBuffer -> "buffer" - DisplaySingle -> "single" - DisplayDouble -> "double" - DisplayAccA -> "acca" - DisplayAcc -> "acc" - DisplayAlpha -> "alpha" - DisplayDepth -> "depth" - DisplayStencil -> "stencil" - DisplaySamples -> "samples" - DisplayStereo -> "stereo" - DisplayLuminance -> "luminance" - DisplayAux -> "aux" - DisplayNum -> "num" - DisplayConformant -> "conformant" - DisplaySlow -> "slow" - DisplayWin32PFD -> "win32pfd" - DisplayXVisual -> "xvisual" - DisplayXStaticGray -> "xstaticgray" - DisplayXGrayScale -> "xgrayscale" - DisplayXStaticColor -> "xstaticcolor" - DisplayXPseudoColor -> "xpseudocolor" - DisplayXTrueColor -> "xtruecolor" - DisplayXDirectColor -> "xdirectcolor" - --- | A single capability description for 'initialDisplayCapabilities'. - -data DisplayCapabilityDescription - = Where DisplayCapability Relation Int - -- ^ A description of a capability with a specific relation to a numeric - -- value. - | With DisplayCapability - -- ^ When the relation and numeric value are not specified, each capability - -- has a different default, see the different constructors of - -- 'DisplayCapability'. - deriving ( Eq, Ord, Show ) - -displayCapabilityDescriptionToString :: DisplayCapabilityDescription -> String -displayCapabilityDescriptionToString (Where c r i) = - displayCapabilityToString c ++ relationToString r ++ show i -displayCapabilityDescriptionToString (With c) = displayCapabilityToString c - --- | Controls the /initial display mode/ used when creating top-level windows, --- subwindows, and overlays to determine the OpenGL display mode for the --- to-be-created window or overlay. It is described by a list of zero or more --- capability descriptions, which are translated into a set of criteria used to --- select the appropriate frame buffer configuration. The criteria are matched --- in strict left to right order of precdence. That is, the first specified --- criterion (leftmost) takes precedence over the later criteria for non-exact --- criteria ('IsGreaterThan', 'IsLessThan', etc.). Exact criteria ('IsEqualTo', --- 'IsNotEqualTo') must match exactly so precedence is not relevant. --- --- Unspecified capability descriptions will result in unspecified criteria being --- generated. These unspecified criteria help 'initialDisplayCapabilities' --- behave sensibly with terse display mode descriptions. --- --- Here is an example using 'initialDisplayCapabilities': --- --- @ --- initialDisplayCapabilities $= [ With DisplayRGB, --- Where DisplayDepth IsAtLeast 16, --- With DisplaySamples, --- Where DisplayStencil IsNotLessThan 2, --- With DisplayDouble ] --- @ --- --- The above call requests a window with an RGBA color model (but requesting --- no bits of alpha), a depth buffer with at least 16 bits of precision but --- preferring more, multisampling if available, at least 2 bits of stencil --- (favoring less stencil to more as long as 2 bits are available), and double --- buffering. - -initialDisplayCapabilities :: SettableStateVar [DisplayCapabilityDescription] -initialDisplayCapabilities = - makeSettableStateVar $ \caps -> - withCString - (concat . intersperse " " . map displayCapabilityDescriptionToString $ - caps) - glutInitDisplayString - ------------------------------------------------------------------------------ - --- | How rendering context for new windows are created. - -data RenderingContext - = -- | Create a new context via @glXCreateContext@ or @wglCreateContext@ - -- (default). - CreateNewContext - | -- | Re-use the current rendering context. - UseCurrentContext - deriving ( Eq, Ord, Show ) - -marshalRenderingContext :: RenderingContext -> CInt -marshalRenderingContext CreateNewContext = glut_CREATE_NEW_CONTEXT -marshalRenderingContext UseCurrentContext = glut_USE_CURRENT_CONTEXT - -unmarshalRenderingContext :: CInt -> RenderingContext -unmarshalRenderingContext r - | r == glut_CREATE_NEW_CONTEXT = CreateNewContext - | r == glut_USE_CURRENT_CONTEXT = UseCurrentContext - | otherwise = error "unmarshalRenderingContext" - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Controls the creation of rendering contexts for new --- windows. - -renderingContext :: StateVar RenderingContext -renderingContext = - makeStateVar - (simpleGet unmarshalRenderingContext glut_RENDERING_CONTEXT) - (glutSetOption glut_RENDERING_CONTEXT . marshalRenderingContext) - ------------------------------------------------------------------------------ - --- | The kind of GLX rendering context used. Direct rendering provides a --- performance advantage in some implementations. However, direct rendering --- contexts cannot be shared outside a single process, and they may be unable --- to render to GLX pixmaps. - -data DirectRendering - = -- | Rendering is always done through the X server. This corresponds to - -- the command line argument @-indirect@, see 'initialize'. - ForceIndirectContext - | -- | Try to use direct rendering, silently using indirect rendering if this - -- is not possible. - AllowDirectContext - | -- | Try to use direct rendering, issue a warning and use indirect - -- rendering if this is not possible. - TryDirectContext - | -- | Try to use direct rendering, issue an error and terminate the program - -- if this is not possible.This corresponds to the command line argument - -- @-direct@, see 'initialize'. - ForceDirectContext - deriving ( Eq, Ord, Show ) - -marshalDirectRendering :: DirectRendering -> CInt -marshalDirectRendering x = case x of - ForceIndirectContext -> glut_FORCE_INDIRECT_CONTEXT - AllowDirectContext -> glut_ALLOW_DIRECT_CONTEXT - TryDirectContext -> glut_TRY_DIRECT_CONTEXT - ForceDirectContext -> glut_FORCE_DIRECT_CONTEXT - -unmarshalDirectRendering :: CInt -> DirectRendering -unmarshalDirectRendering x - | x == glut_FORCE_INDIRECT_CONTEXT = ForceIndirectContext - | x == glut_ALLOW_DIRECT_CONTEXT = AllowDirectContext - | x == glut_TRY_DIRECT_CONTEXT = TryDirectContext - | x == glut_FORCE_DIRECT_CONTEXT = ForceDirectContext - | otherwise = error ("unmarshalDirectRendering: illegal value " ++ show x) - ------------------------------------------------------------------------------ - --- | (/freeglut on X11 only/) Controls which kind of rendering context is --- created when a new one is required. - -directRendering :: StateVar DirectRendering -directRendering = - makeStateVar - (simpleGet unmarshalDirectRendering glut_DIRECT_RENDERING) - (glutSetOption glut_DIRECT_RENDERING . marshalDirectRendering) - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Controls the API major\/minor version of the OpenGL --- context. If a version less than or equal to 2.1 is requested, the context --- returned may implement any version no less than that requested and no --- greater than 2.1. If version 3.0 is requested, the context returned must --- implement exactly version 3.0. Versioning behavior once GL versions beyond --- 3.0 are defined will be defined by an amendment to the OpenGL specification --- to define dependencies on such GL versions. --- --- 'Graphics.Rendering.OpenGL.GL.StringQueries.glVersion' and --- 'Graphics.Rendering.OpenGL.GL.StringQueries.majorMinor' will return the --- actual version supported by a context. --- --- The default context version is (1, 0), which will typically return an --- OpenGL 2.1 context, if one is available. - -initialContextVersion :: StateVar (Int, Int) -initialContextVersion = makeStateVar getContextVersion setContextVersion - -getContextVersion :: IO (Int, Int) -getContextVersion = do - major <- simpleGet fromIntegral glut_INIT_MAJOR_VERSION - minor <- simpleGet fromIntegral glut_INIT_MINOR_VERSION - return (major, minor) - -setContextVersion :: (Int, Int) -> IO () -setContextVersion (major, minor) = - glutInitContextVersion (fromIntegral major) (fromIntegral minor) - ------------------------------------------------------------------------------ - --- | A flag affecting the rendering context to create, used in conjunction --- with 'initialContextFlags'. - -data ContextFlag - = -- | Debug contexts are intended for use during application development, - -- and provide additional runtime checking, validation, and logging - -- functionality while possibly incurring performance penalties. The - -- additional functionality provided by debug contexts may vary according - -- to the implementation. In some cases a debug context may be identical - -- to a non-debug context. - DebugContext - | -- | Forward-compatible contexts are defined only for OpenGL versions 3.0 - -- and later. They must not support functionality marked as /deprecated/ - -- by that version of the API, while a non-forward-compatible context must - -- support all functionality in that version, deprecated or not. - ForwardCompatibleContext - deriving ( Eq, Ord, Show ) - -marshalContextFlag :: ContextFlag -> CInt -marshalContextFlag x = case x of - DebugContext -> glut_DEBUG - ForwardCompatibleContext -> glut_FORWARD_COMPATIBLE - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Controls the set of flags for the rendering context. - -initialContextFlags :: StateVar [ContextFlag] -initialContextFlags = makeStateVar getContextFlags setContextFlags - -getContextFlags :: IO [ContextFlag] -getContextFlags = simpleGet i2cfs glut_INIT_FLAGS - -i2cfs :: CInt -> [ContextFlag] -i2cfs bitfield = - [ c | c <- [ DebugContext, ForwardCompatibleContext ] - , (fromIntegral bitfield .&. marshalContextFlag c) /= 0 ] - -setContextFlags :: [ContextFlag] -> IO () -setContextFlags = glutInitContextFlags . toBitfield marshalContextFlag - - ------------------------------------------------------------------------------ - --- | An OpenGL API profile, affecting the rendering context to create, used --- in conjunction with 'initialContextProfile'. - -data ContextProfile - = -- | The OpenGL /core/ profile, which all OpenGL 3.2 implementations - -- are required to support. - CoreProfile - | -- | The OpenGL /compatibility/ profile, which is optional for OpenGL - -- 3.2 implementations. - CompatibilityProfile - deriving ( Eq, Ord, Show ) - -marshalContextProfile :: ContextProfile -> CInt -marshalContextProfile x = case x of - CoreProfile -> glut_CORE_PROFILE - CompatibilityProfile -> glut_COMPATIBILITY_PROFILE - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Controls the set of profiles for the rendering context. - -initialContextProfile :: StateVar [ContextProfile] -initialContextProfile = makeStateVar getContextProfiles setContextProfiles - -getContextProfiles :: IO [ContextProfile] -getContextProfiles = simpleGet i2cps glut_INIT_PROFILE - -i2cps :: CInt -> [ContextProfile] -i2cps bitfield = - [ c | c <- [ CoreProfile, CompatibilityProfile ] - , (fromIntegral bitfield .&. marshalContextProfile c) /= 0 ] - -setContextProfiles :: [ContextProfile] -> IO () -setContextProfiles = glutInitContextProfile . toBitfield marshalContextProfile diff --git a/Graphics/UI/GLUT/Menu.hs b/Graphics/UI/GLUT/Menu.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Menu.hs +++ /dev/null @@ -1,246 +0,0 @@ -{-# OPTIONS_GHC -fno-cse #-} - --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Menu --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- GLUT supports simple cascading pop-up menus. They are designed to let a user --- select various modes within a program. The functionality is simple and --- minimalistic and is meant to be that way. Do not mistake GLUT\'s pop-up menu --- facility with an attempt to create a full-featured user interface. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Menu ( - Menu(..), MenuItem(..), MenuCallback, attachMenu, - numMenuItems -) where - -import Data.Array -import Data.IORef -import qualified Data.Map as Map ( empty, lookup, insert, delete ) -import Control.Monad -import Data.Map ( Map ) -import Data.StateVar -import Foreign.C.String -import Foreign.C.Types -import Foreign.Ptr -import Graphics.UI.GLUT.Callbacks.Registration -import Graphics.UI.GLUT.QueryUtils -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.Types - --------------------------------------------------------------------------------- - --- | A menu is simply a list of menu items. -newtype Menu = Menu [MenuItem] - --- | A single item within a menu can either be a plain menu entry or a sub-menu --- entry, allowing for arbitrarily deep nested menus. -data MenuItem - = MenuEntry String MenuCallback -- ^ A plain menu entry with an associated - -- callback, which is triggered when the - -- user selects the entry - | SubMenu String Menu -- ^ A sub-menu, which is cascaded when the - -- user selects the entry, allowing - -- sub-menu entries to be selected - -type MenuCallback = IO () - --- | Create a new pop-up menu for the /current window,/ attaching it to the --- given mouse button. A previously attached menu (if any), is detached before --- and won\'t receive callbacks anymore. --- --- It is illegal to call 'attachMenu' while any (sub-)menu is in use, i.e. --- popped up. --- --- /X Implementation Notes:/ If available, GLUT for X will take advantage of --- overlay planes for implementing pop-up menus. The use of overlay planes can --- eliminate display callbacks when pop-up menus are deactivated. The --- @SERVER_OVERLAY_VISUALS@ convention is used to determine if overlay visuals --- are available. - -attachMenu :: MouseButton -> Menu -> IO () -attachMenu mouseButton menu@(Menu items) = do - win <- getCurrentWindow "attachMenu" - let hook = MenuHook win mouseButton - detachMenu hook - unless (null items) $ do - (_, destructor) <- traverseMenu menu - addToMenuTable hook destructor - attachMenu_ mouseButton - -detachMenu :: MenuHook -> IO () -detachMenu hook@(MenuHook _ mouseButton) = do - maybeDestructor <- lookupInMenuTable hook - case maybeDestructor of - Nothing -> return () - Just destructor -> do detachMenu_ mouseButton - destructor - deleteFromMenuTable hook - -traverseMenu :: Menu -> IO (MenuID, Destructor) -traverseMenu (Menu items) = do - let callbackArray = listArray (1, length items) (map makeCallback items) - cb <- makeMenuFunc (\i -> callbackArray ! (fromIntegral i)) - menuID <- glutCreateMenu cb - destructors <- zipWithM addMenuItem items [1..] - let destructor = do sequence_ destructors - glutDestroyMenu menuID - freeHaskellFunPtr cb - return (menuID, destructor) - -makeCallback :: MenuItem -> MenuCallback -makeCallback (MenuEntry _ cb) = cb -makeCallback _ = error "shouldn't receive a callback for submenus" - -addMenuItem :: MenuItem -> Value -> IO Destructor -addMenuItem (MenuEntry s _) v = do - addMenuEntry s v - return $ glutRemoveMenuItem 1 -addMenuItem (SubMenu s m) _ = do - (menuID, destructor) <- saveExcursion (traverseMenu m) - addSubMenu s menuID - return $ do glutRemoveMenuItem 1 - destructor - --- Perform an action, saving/restoring the current menu around it -saveExcursion :: IO a -> IO a -saveExcursion act = do - menuID <- get currentMenu - returnValue <- act - when (isRealMenu menuID) $ - currentMenu $= menuID - return returnValue - --------------------------------------------------------------------------------- --- This seems to be a common Haskell hack nowadays: A plain old global variable --- with an associated mutator. Perhaps some language/library support is needed? - -{-# NOINLINE theMenuTable #-} -theMenuTable :: IORef MenuTable -theMenuTable = unsafePerformIO (newIORef emptyMenuTable) - -getMenuTable :: IO MenuTable -getMenuTable = readIORef theMenuTable - -modifyMenuTable :: (MenuTable -> MenuTable) -> IO () -modifyMenuTable = modifyIORef theMenuTable - --------------------------------------------------------------------------------- --- To facilitate cleanup, we have to keep track how to destroy menus which are --- currently attached in a window to a mouse button. - -data MenuHook = MenuHook Window MouseButton - deriving ( Eq, Ord ) - -type Destructor = IO () - -type MenuTable = Map MenuHook Destructor - -emptyMenuTable :: MenuTable -emptyMenuTable = Map.empty - -lookupInMenuTable :: MenuHook -> IO (Maybe Destructor) -lookupInMenuTable callbackID = - fmap (Map.lookup callbackID) getMenuTable - -deleteFromMenuTable :: MenuHook -> IO () -deleteFromMenuTable callbackID = - modifyMenuTable (Map.delete callbackID) - -addToMenuTable :: MenuHook -> Destructor -> IO () -addToMenuTable callbackID funPtr = - modifyMenuTable (Map.insert callbackID funPtr) - --------------------------------------------------------------------------------- - -type MenuID = CInt -type Value = CInt - --------------------------------------------------------------------------------- - --- | Controls the /current menu./ If no menus exist or the previous /current --- menu/ was destroyed, a pseudo menu is returned, see 'isRealMenu'. - -currentMenu :: StateVar MenuID -currentMenu = makeStateVar glutGetMenu glutSetMenu - --- | Returns 'True' if the given menu identifier refers to a real menu, not --- a pseudo one. - -isRealMenu :: MenuID -> Bool -isRealMenu = (/= 0) - --------------------------------------------------------------------------------- - --- | Add a menu entry to the bottom of the /current menu./ The given string will --- be displayed for the newly added menu entry. If the menu entry is selected by --- the user, the menu\'s callback will be called passing the given value as the --- callback\'s parameter. - -addMenuEntry :: String -> Value -> IO () -addMenuEntry name value = withCString name $ \n -> glutAddMenuEntry n value - --- | Add a sub-menu trigger to the bottom of the /current menu./ The given --- string will be displayed for the newly added sub-menu trigger. If the --- sub-menu trigger is entered, the sub-menu specified by the given menu --- identifier will be cascaded, allowing sub-menu menu items to be selected. - -addSubMenu :: String -> MenuID -> IO () -addSubMenu name menuID = withCString name $ \n -> glutAddSubMenu n menuID - --------------------------------------------------------------------------------- - -{- UNUSED --- | Change the specified menu entry in the /current menu/ into a menu entry. --- The given position determines which menu item should be changed and must be --- between 1 (the topmost menu item) and --- 'Graphics.UI.GLUT.State.getNumMenuItems' inclusive. The menu item to change --- does not have to be a menu entry already. The given string will be displayed --- for the newly changed menu entry. The given value will be returned to the --- menu\'s callback if this menu entry is selected. - -foreign import CALLCONV unsafe "glutChangeToMenuEntry" glutChangeToMenuEntry :: - Item -> CString -> Value -> IO () - --- | Change the specified menu item in the /current menu/ into a sub-menu --- trigger. The given position determines which menu item should be changed and --- must be between 1 and 'Graphics.UI.GLUT.State.getNumMenuItems' inclusive. The --- menu item to change does not have to be a sub-menu trigger already. The --- given name will be displayed for the newly changed sub-menu trigger. The --- given menu identifier names the sub-menu to cascade from the newly added --- sub-menu trigger. - -foreign import CALLCONV unsafe "glutChangeToSubMenu" glutChangeToSubMenu :: - Item -> CString -> MenuID -> IO () --} - --------------------------------------------------------------------------------- - --- | Attach a mouse button for the /current window/ to the identifier of the --- /current menu./ By attaching a menu identifier to a button, the named menu --- will be popped up when the user presses the specified button. Note that the --- menu is attached to the button by identifier, not by reference. - - -attachMenu_ :: MouseButton -> IO () -attachMenu_ = glutAttachMenu . marshalMouseButton - --- | Detach an attached mouse button from the /current window./ - -detachMenu_ :: MouseButton -> IO () -detachMenu_ = glutDetachMenu . marshalMouseButton - --------------------------------------------------------------------------------- - --- | Contains the number of menu items in the /current menu./ - -numMenuItems :: GettableStateVar Int -numMenuItems = makeGettableStateVar $ simpleGet fromIntegral glut_MENU_NUM_ITEMS diff --git a/Graphics/UI/GLUT/Objects.hs b/Graphics/UI/GLUT/Objects.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Objects.hs +++ /dev/null @@ -1,338 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Objects --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- GLUT includes a number of routines for generating easily recognizable 3D --- geometric objects. These routines reflect functionality available in the --- @aux@ toolkit described in the /OpenGL Programmer\'s Guide/ and are included --- in GLUT to allow the construction of simple GLUT programs that render --- recognizable objects. These routines can be implemented as pure OpenGL --- rendering routines. The routines do not generate display lists for the --- objects they create. The routines generate normals appropriate for lighting --- but do not generate texture coordinates (except for the teapot). --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Objects ( - -- * Rendering flavour - Flavour(..), - - -- * Object description - Object(..), - - -- * Type synonyms - Sides, Rings, NumLevels, - - -- * Rendering - renderObject -) where - -import 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.Raw - --------------------------------------------------------------------------------- - --- | Flavour of object rendering - -data Flavour - = -- | Object is rendered as a solid with shading and surface normals. - Solid - | -- | Object is rendered as a wireframe without surface normals. - Wireframe - deriving ( Eq, Ord, Show ) - --------------------------------------------------------------------------------- - --- | GLUT offers five types of objects: --- --- * The five Platonic solids, see --- . --- --- * A rhombic dodecahedron, see --- . --- --- * Approximations to rounded objects. --- --- * The classic teapot modeled by Martin Newell in 1975. Both surface normals --- and texture coordinates for the teapot are generated. The teapot is --- generated with OpenGL evaluators. --- --- * A Sierpinski sponge, see --- . - -data Object - = -- | A cube centered at the modeling coordinates origin with sides of the - -- given length. - Cube Height - | -- | A dodecahedron (12-sided regular solid) centered at the modeling - -- coordinates origin with a radius of @sqrt 3@. - Dodecahedron - | -- | A icosahedron (20-sided regular solid) centered at the modeling - -- coordinates origin with a radius of 1.0. - Icosahedron - | -- | Render a solid octahedron (8-sided regular solid) centered at the - -- modeling coordinates origin with a radius of 1.0. - Octahedron - | -- | Render a solid tetrahedron (4-sided regular solid) centered at the - -- modeling coordinates origin with a radius of @sqrt 3@. - Tetrahedron - | -- | (/freeglut only/) A rhombic dodecahedron whose corners are at most a - -- distance of one from the origin. The rhombic dodecahedron has faces - -- which are identical rhombi, but which have some vertices at which three - -- faces meet and some vertices at which four faces meet. The length of - -- each side is @(sqrt 3)\/2@. Vertices at which four faces meet are found - -- at @(0, 0, +\/-1)@ and @(+\/-(sqrt 2)\/2, +\/-(sqrt 2)\/2, 0)@. - RhombicDodecahedron - | -- | A sphere centered at the modeling coordinates origin of the specified - -- radius. The sphere is subdivided around the Z axis into slices - -- (similar to lines of longitude) and along the Z axis into stacks - -- (similar to lines of latitude). - Sphere' Radius Slices Stacks - | -- | A cone oriented along the Z axis. The base of the cone is placed at Z - -- = 0, and the top at Z = the given height. The cone is subdivided - -- around the Z axis into slices, and along the Z axis into stacks. - Cone Radius Height Slices Stacks - | -- |(/freeglut only/) A cylinder oriented along the Z axis. The base of the - -- cylinder is placed at Z = 0, and the top at Z = the given height. The - -- cylinder is subdivided around the Z axis into slices, and along the Z - -- axis into stacks. - Cylinder' Radius Height Slices Stacks - | -- | A torus (doughnut) centered at the modeling coordinates origin - -- whose axis is aligned with the Z axis. The torus is described by its - -- inner and outer radius, the number of sides for each radial section, - -- and the number of radial divisions (rings). - Torus Radius Radius Sides Rings - | -- | A teapot with a given relative size. - Teapot Height - | -- |(/freeglut only/) A Sierpinski sponge of a given level, where a level - -- 0 sponge is the same as a 'Tetrahedron'. - SierpinskiSponge NumLevels - deriving ( Eq, Ord, Show ) - --------------------------------------------------------------------------------- - -type Sides = GLint -type Rings = GLint -type NumLevels = GLint - --------------------------------------------------------------------------------- - --- | Render an object in the given flavour. - -renderObject :: Flavour -> Object -> IO () -renderObject Solid (Cube h) = solidCube h -renderObject Wireframe (Cube h) = wireCube h -renderObject Solid Dodecahedron = solidDodecahedron -renderObject Wireframe Dodecahedron = wireDodecahedron -renderObject Solid Icosahedron = solidIcosahedron -renderObject Wireframe Icosahedron = wireIcosahedron -renderObject Solid Octahedron = solidOctahedron -renderObject Wireframe Octahedron = wireOctahedron -renderObject Solid Tetrahedron = solidTetrahedron -renderObject Wireframe Tetrahedron = wireTetrahedron -renderObject Solid RhombicDodecahedron = glutSolidRhombicDodecahedron -renderObject Wireframe RhombicDodecahedron = glutWireRhombicDodecahedron -renderObject Solid (Sphere' r s t) = solidSphere r s t -renderObject Wireframe (Sphere' r s t) = wireSphere r s t -renderObject Solid (Cone r h s t) = solidCone r h s t -renderObject Wireframe (Cone r h s t) = wireCone r h s t -renderObject Solid (Cylinder' r h s t) = glutSolidCylinder r h s t -renderObject Wireframe (Cylinder' r h s t) = glutWireCylinder r h s t -renderObject Solid (Torus i o s r) = solidTorus i o s r -renderObject Wireframe (Torus i o s r) = wireTorus i o s r -renderObject Solid (Teapot h) = solidTeapot h -renderObject Wireframe (Teapot h) = wireTeapot h -renderObject Solid (SierpinskiSponge n) = solidSierpinskiSponge n -renderObject Wireframe (SierpinskiSponge n) = wireSierpinskiSponge n - --------------------------------------------------------------------------------- - --- | Render a solid cube centered at the modeling coordinates origin with sides --- of the given length. - -solidCube - :: Height -- ^ Length of the cube sides - -> IO () -solidCube = glutSolidCube - --- | Render a wireframe cube centered at the modeling coordinates origin with --- sides of the given length. - -wireCube - :: Height -- ^ Length of the cube sides - -> IO () -wireCube = glutWireCube - --------------------------------------------------------------------------------- - --- | Render a solid dodecahedron (12-sided regular solid) centered at the --- modeling coordinates origin with a radius of @sqrt 3@. - -solidDodecahedron :: IO () -solidDodecahedron = glutSolidDodecahedron - --- | Render a wireframe dodecahedron (12-sided regular solid) centered at the --- modeling coordinates origin with a radius of @sqrt 3@. - -wireDodecahedron :: IO () -wireDodecahedron = glutWireDodecahedron - --------------------------------------------------------------------------------- - --- | Render a solid icosahedron (20-sided regular solid) centered at the --- modeling coordinates origin with a radius of 1.0. - -wireIcosahedron :: IO () -wireIcosahedron = glutWireIcosahedron - --- | Render a wireframe icosahedron (20-sided regular solid) centered at the --- modeling coordinates origin with a radius of 1.0. - -solidIcosahedron :: IO () -solidIcosahedron = glutSolidIcosahedron - --------------------------------------------------------------------------------- - --- | Render a solid octahedron (8-sided regular solid) centered at the modeling --- coordinates origin with a radius of 1.0. - -solidOctahedron :: IO () -solidOctahedron = glutSolidOctahedron - --- | Render a wireframe octahedron (8-sided regular solid) centered at the --- modeling coordinates origin with a radius of 1.0. - -wireOctahedron :: IO () -wireOctahedron = glutWireOctahedron - --------------------------------------------------------------------------------- - --- | Render a solid tetrahedron (4-sided regular solid) centered at the modeling --- coordinates origin with a radius of @sqrt 3@. - -wireTetrahedron :: IO () -wireTetrahedron = glutWireTetrahedron - --- | Render a wireframe tetrahedron (4-sided regular solid) centered at the --- modeling coordinates origin with a radius of @sqrt 3@. - -solidTetrahedron :: IO () -solidTetrahedron = glutSolidTetrahedron - --------------------------------------------------------------------------------- - --- | Render a solid sphere centered at the modeling coordinates origin of the --- specified radius. The sphere is subdivided around the Z axis into slices --- and along the Z axis into stacks. - -solidSphere - :: Radius -- ^ Radius of the sphere. - -> Slices -- ^ Number of subdivisions (slices) around the Z axis, similar - -- to lines of longitude. - -> Stacks -- ^ The number of subdivisions (stacks) along the Z axis, - -- similar to lines of latitude. - -> IO () -solidSphere = glutSolidSphere - --- | Render a wireframe sphere centered at the modeling coordinates origin of --- the specified radius. The sphere is subdivided around the Z axis into slices --- and along the Z axis into stacks. - -wireSphere - :: Radius -- ^ Radius of the sphere. - -> Slices -- ^ Number of subdivisions (slices) around the Z axis, similar - -- to lines of longitude. - -> Stacks -- ^ The number of subdivisions (stacks) along the Z axis, - -- similar to lines of latitude. - -> IO () -wireSphere = glutWireSphere - --------------------------------------------------------------------------------- - --- | Render a solid cone oriented along the Z axis. The base of the cone is --- placed at Z = 0, and the top at Z = height. The cone is subdivided around the --- Z axis into slices, and along the Z axis into stacks. - -solidCone - :: Radius -- ^ Radius of the base of the cone. - -> Height -- ^ Height of the cone. - -> Slices -- ^ Number of subdivisions around the Z axis. - -> Stacks -- ^ The number of subdivisions along the Z axis. - -> IO () -solidCone = glutSolidCone - --- | Render a wireframe cone oriented along the Z axis. The base of the cone is --- placed at Z = 0, and the top at Z = height. The cone is subdivided around the --- Z axis into slices, and along the Z axis into stacks. - -wireCone - :: Radius -- ^ Radius of the base of the cone. - -> Height -- ^ Height of the cone. - -> Slices -- ^ Number of subdivisions around the Z axis. - -> Stacks -- ^ The number of subdivisions along the Z axis. - -> IO () -wireCone = glutWireCone - --------------------------------------------------------------------------------- - --- | Render a solid torus (doughnut) centered at the modeling coordinates origin --- whose axis is aligned with the Z axis. - -solidTorus - :: Radius -- ^ Inner radius of the torus. - -> Radius -- ^ Outer radius of the torus. - -> Slices -- ^ Number of sides for each radial section. - -> Stacks -- ^ Number of radial divisions for the torus. - -> IO () -solidTorus = glutSolidTorus - --- | Render a wireframe torus (doughnut) centered at the modeling coordinates --- origin whose axis is aligned with the Z axis. - -wireTorus - :: Radius -- ^ Inner radius of the torus. - -> Radius -- ^ Outer radius of the torus. - -> Slices -- ^ Number of sides for each radial section. - -> Stacks -- ^ Number of radial divisions for the torus. - -> IO () -wireTorus = glutWireTorus - --------------------------------------------------------------------------------- - --- | Render a solid teapot. - -solidTeapot - :: Height -- ^ Relative size of the teapot - -> IO () -solidTeapot = glutSolidTeapot - --- | Render a wireframe teapot. - -wireTeapot - :: Height -- ^ Relative size of the teapot - -> IO () -wireTeapot = glutWireTeapot - --------------------------------------------------------------------------------- - -solidSierpinskiSponge :: NumLevels -> IO () -solidSierpinskiSponge = sierpinskiSponge glutSolidSierpinskiSponge - -wireSierpinskiSponge :: NumLevels -> IO () -wireSierpinskiSponge = sierpinskiSponge glutWireSierpinskiSponge - --- for consistency, we hide the offset and scale on the Haskell side -sierpinskiSponge :: (CInt -> Ptr GLdouble -> Height -> IO ()) -> NumLevels -> IO () -sierpinskiSponge f n = - with (Vertex3 0 0 0) $ \offsetBuf -> - f (fromIntegral n) ((castPtr :: Ptr (Vertex3 GLdouble) -> Ptr GLdouble) offsetBuf) 1 diff --git a/Graphics/UI/GLUT/Overlay.hs b/Graphics/UI/GLUT/Overlay.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Overlay.hs +++ /dev/null @@ -1,167 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Overlay --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- When overlay hardware is available, GLUT provides a set of routines for --- establishing, using, and removing an overlay for GLUT windows. When an --- overlay is established, a separate OpenGL context is also established. A --- window\'s overlay OpenGL state is kept distinct from the normal planes\' --- OpenGL state. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Overlay ( - -- * Overlay creation and destruction - hasOverlay, overlayPossible, - - -- * Showing and hiding an overlay - overlayVisible, - - -- * Changing the /layer in use/ - Layer(..), layerInUse, - - -- * Re-displaying - postOverlayRedisplay -) where - -import Data.StateVar -import Graphics.Rendering.OpenGL ( GLenum ) -import Graphics.UI.GLUT.QueryUtils -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.Types - --------------------------------------------------------------------------------- - --- | Controls the overlay for the /current window/. The requested display mode --- for the overlay is determined by the /initial display mode/. --- 'overlayPossible' can be used to determine if an overlay is possible for the --- /current window/ with the current /initial display mode/. Do not attempt to --- establish an overlay when one is not possible; GLUT will terminate the --- program. --- --- When 'hasOverlay' is set to 'True' when an overlay already exists, the --- existing overlay is first removed, and then a new overlay is established. The --- state of the old overlay\'s OpenGL context is discarded. Implicitly, the --- window\'s /layer in use/ changes to the overlay immediately after the overlay --- is established. --- --- The initial display state of an overlay is shown, however the overlay is only --- actually shown if the overlay\'s window is shown. --- --- Setting 'hasOverlay' to 'False' is safe even if no overlay is currently --- established, nothing happens in this case. Implicitly, the window\'s /layer --- in use/ changes to the normal plane immediately once the overlay is removed. --- --- If the program intends to re-establish the overlay later, it is typically --- faster and less resource intensive to use 'overlayVisible' to simply change --- the display status of the overlay. --- --- /X Implementation Notes:/ GLUT for X uses the @SERVER_OVERLAY_VISUALS@ --- convention to determine if overlay visuals are available. While the --- convention allows for opaque overlays (no transparency) and overlays with the --- transparency specified as a bitmask, GLUT overlay management only provides --- access to transparent pixel overlays. --- --- Until RGBA overlays are better understood, GLUT only supports color index --- overlays. - -hasOverlay :: StateVar Bool -hasOverlay = makeStateVar getHasOverlay setHasOverlay - -setHasOverlay :: Bool -> IO () -setHasOverlay False = glutRemoveOverlay -setHasOverlay True = glutEstablishOverlay - -getHasOverlay :: IO Bool -getHasOverlay = layerGet (/= 0) glut_HAS_OVERLAY - --------------------------------------------------------------------------------- - --- | Contains 'True' if an overlay could be established for the /current window/ --- given the current /initial display mode/. If it contains 'False', --- 'setHasOverlay' will fail with a fatal error if called. - -overlayPossible :: GettableStateVar Bool -overlayPossible = makeGettableStateVar $ layerGet (/= 0) glut_OVERLAY_POSSIBLE - --------------------------------------------------------------------------------- - --- | Controls the visibility of the overlay of the /current window/. --- --- The effect of showing or hiding an overlay takes place immediately. Note that --- setting 'overlayVisible' to 'True' will not actually display the overlay --- unless the window is also shown (and even a shown window may be obscured by --- other windows, thereby obscuring the overlay). It is typically faster and --- less resource intensive to use the routines below to control the display --- status of an overlay as opposed to removing and re-establishing the overlay. - -overlayVisible :: SettableStateVar Bool -overlayVisible = - makeSettableStateVar $ \flag -> - if flag then glutShowOverlay else glutHideOverlay - --------------------------------------------------------------------------------- - --- | The /layer in use/. -data Layer - = Normal -- ^ The normal plane. - | Overlay -- ^ The overlay. - deriving ( Eq, Ord, Show ) - -marshalLayer :: Layer -> GLenum -marshalLayer x = case x of - Normal -> glut_NORMAL - Overlay -> glut_OVERLAY - -unmarshalLayer :: GLenum -> Layer -unmarshalLayer x - | x == glut_NORMAL = Normal - | x == glut_OVERLAY = Overlay - | otherwise = error ("unmarshalLayer: illegal value " ++ show x) - --------------------------------------------------------------------------------- - --- | Controls the per-window /layer in use/ for the /current window/, which can --- either be the normal plane or the overlay. Selecting the overlay should only --- be done if an overlay exists, however windows without an overlay may still --- set the /layer in use/ to 'Normal'. OpenGL commands for the window are --- directed to the current /layer in use/. - -layerInUse :: StateVar Layer -layerInUse = - makeStateVar getLayerInUse setLayerInUse - -setLayerInUse :: Layer -> IO () -setLayerInUse = glutUseLayer . marshalLayer - -getLayerInUse :: IO Layer -getLayerInUse = layerGet (unmarshalLayer . fromIntegral) glut_LAYER_IN_USE - --------------------------------------------------------------------------------- - --- | Mark the overlay of the given window (or the /current window/, if none is --- supplied) as needing to be redisplayed. The next iteration through --- 'Graphics.UI.GLUT.Begin.mainLoop', the window\'s overlay display callback --- (or simply the display callback if no overlay display callback is registered) --- will be called to redisplay the window\'s overlay plane. Multiple calls to --- 'postOverlayRedisplay' before the next display callback opportunity (or --- overlay display callback opportunity if one is registered) generate only a --- single redisplay. 'postOverlayRedisplay' may be called within a window\'s --- display or overlay display callback to re-mark that window for redisplay. --- --- Logically, overlay damage notification for a window is treated as a --- 'postOverlayRedisplay' on the damaged window. Unlike damage reported by the --- window system, 'postOverlayRedisplay' will not set to true the overlay\'s --- damaged status (see 'Graphics.UI.GLUT.State.damaged'). --- --- Also, see 'Graphics.UI.GLUT.Window.postRedisplay'. - -postOverlayRedisplay :: Maybe Window -> IO () -postOverlayRedisplay = - maybe glutPostOverlayRedisplay (\(Window win) -> glutPostWindowOverlayRedisplay win) diff --git a/Graphics/UI/GLUT/QueryUtils.hs b/Graphics/UI/GLUT/QueryUtils.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/QueryUtils.hs +++ /dev/null @@ -1,35 +0,0 @@ --- #hide --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.QueryUtils --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- This is a purely internal module with utilities to query GLUT state. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.QueryUtils ( - Getter, simpleGet, layerGet, deviceGet -) where - -import Foreign.C.Types -import Graphics.Rendering.OpenGL ( GLenum ) -import Graphics.UI.GLUT.Raw - --------------------------------------------------------------------------------- - -type PrimGetter = GLenum -> IO CInt -type Getter a = (CInt -> a) -> GLenum -> IO a - -makeGetter :: PrimGetter -> Getter a -makeGetter g f = fmap f . g - -simpleGet, layerGet, deviceGet :: Getter a -simpleGet = makeGetter glutGet -layerGet = makeGetter glutLayerGet -deviceGet = makeGetter glutDeviceGet diff --git a/Graphics/UI/GLUT/Raw.hs b/Graphics/UI/GLUT/Raw.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Raw.hs +++ /dev/null @@ -1,28 +0,0 @@ --- #hide ------------------------------------------------------------------------------ --- | --- Module : Graphics.UI.GLUT.Raw --- Copyright : (c) Sven Panne 2009 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- A convenience module, combining all raw GLUT modules. --- ------------------------------------------------------------------------------ - -module Graphics.UI.GLUT.Raw ( - module Graphics.UI.GLUT.Raw.APIEntry, - module Graphics.UI.GLUT.Raw.Callbacks, - module Graphics.UI.GLUT.Raw.Fonts, - module Graphics.UI.GLUT.Raw.Functions, - module Graphics.UI.GLUT.Raw.Tokens -) where - -import Graphics.UI.GLUT.Raw.APIEntry -import Graphics.UI.GLUT.Raw.Callbacks -import Graphics.UI.GLUT.Raw.Fonts -import Graphics.UI.GLUT.Raw.Functions -import Graphics.UI.GLUT.Raw.Tokens diff --git a/Graphics/UI/GLUT/Raw/APIEntry.hs b/Graphics/UI/GLUT/Raw/APIEntry.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Raw/APIEntry.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, CPP #-} --- #hide --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Raw.APIEntry --- Copyright : (c) Sven Panne 2002-2009 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : provisional --- Portability : portable --- --- This is a purely internal module for handling an OpenGL-like extension --- mechanism for GLUT. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Raw.APIEntry ( - Invoker, getAPIEntry, getAPIEntryInternal, - FunPtr, unsafePerformIO -) where - -import Foreign.C.String -import Foreign.Marshal.Error -import Foreign.Ptr -import System.IO.Unsafe - -#ifdef __HUGS__ -{-# CFILES cbits/HsGLUT.c #-} -#endif - --------------------------------------------------------------------------------- - -type Invoker a = FunPtr a -> a - --- | Retrieve a GLUT API entry by name. Throws a userError when no entry with --- the given name was found. -getAPIEntry :: String -> IO (FunPtr a) -getAPIEntry extensionEntry = - throwIfNullFunPtr ("unknown GLUT entry " ++ extensionEntry) $ - getAPIEntryInternal extensionEntry - -throwIfNullFunPtr :: String -> IO (FunPtr a) -> IO (FunPtr a) -throwIfNullFunPtr = throwIf (== nullFunPtr) . const - -getAPIEntryInternal :: String -> IO (FunPtr a) -getAPIEntryInternal extensionEntry = - withCString extensionEntry hs_GLUT_getProcAddress - -foreign import ccall unsafe "hs_GLUT_getProcAddress" - hs_GLUT_getProcAddress :: CString -> IO (FunPtr a) diff --git a/Graphics/UI/GLUT/Raw/Callbacks.hs b/Graphics/UI/GLUT/Raw/Callbacks.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Raw/Callbacks.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} --- #hide ------------------------------------------------------------------------------ --- | --- Module : Graphics.UI.GLUT.Raw.Callbacks --- Copyright : (c) Sven Panne 2009 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- All GLUT callbacks. --- ------------------------------------------------------------------------------ - -module Graphics.UI.GLUT.Raw.Callbacks ( - MenuFunc, makeMenuFunc, - ButtonBoxFunc, makeButtonBoxFunc, - CloseFunc, makeCloseFunc, - DialsFunc, makeDialsFunc, - DisplayFunc, makeDisplayFunc, - EntryFunc, makeEntryFunc, - IdleFunc, makeIdleFunc, - JoystickFunc, makeJoystickFunc, - KeyboardFunc, makeKeyboardFunc, - KeyboardUpFunc, makeKeyboardUpFunc, - MenuDestroyFunc, makeMenuDestroyFunc, - MenuStateFunc, makeMenuStateFunc, - MenuStatusFunc, makeMenuStatusFunc, - MotionFunc, makeMotionFunc, - MouseFunc, makeMouseFunc, - MouseWheelFunc, makeMouseWheelFunc, - OverlayDisplayFunc, makeOverlayDisplayFunc, - PassiveMotionFunc, makePassiveMotionFunc, - ReshapeFunc, makeReshapeFunc, - SpaceballButtonFunc, makeSpaceballButtonFunc, - SpaceballMotionFunc, makeSpaceballMotionFunc, - SpaceballRotateFunc, makeSpaceballRotateFunc, - SpecialFunc, makeSpecialFunc, - SpecialUpFunc, makeSpecialUpFunc, - TabletButtonFunc, makeTabletButtonFunc, - TabletMotionFunc, makeTabletMotionFunc, - TimerFunc, makeTimerFunc, - VisibilityFunc, makeVisibilityFunc, - WMCloseFunc, makeWMCloseFunc, - WindowStatusFunc, makeWindowStatusFunc -) where - -import Foreign.C.Types -import Foreign.Ptr - -type MenuFunc = CInt -> IO () - -foreign import ccall "wrapper" - makeMenuFunc :: MenuFunc -> IO (FunPtr MenuFunc) - -type ButtonBoxFunc = CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeButtonBoxFunc :: ButtonBoxFunc -> IO (FunPtr ButtonBoxFunc) - -type CloseFunc = IO () - -foreign import ccall "wrapper" - makeCloseFunc :: CloseFunc -> IO (FunPtr CloseFunc) - -type DialsFunc = CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeDialsFunc :: DialsFunc -> IO (FunPtr DialsFunc) - -type DisplayFunc = IO () - -foreign import ccall "wrapper" - makeDisplayFunc :: DisplayFunc -> IO (FunPtr DisplayFunc) - -type EntryFunc = CInt -> IO () - -foreign import ccall "wrapper" - makeEntryFunc :: EntryFunc -> IO (FunPtr EntryFunc) - -type IdleFunc = IO () - -foreign import ccall "wrapper" - makeIdleFunc :: IdleFunc -> IO (FunPtr IdleFunc) - -type JoystickFunc = CUInt -> CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeJoystickFunc :: JoystickFunc -> IO (FunPtr JoystickFunc) - -type KeyboardFunc = CUChar -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeKeyboardFunc :: KeyboardFunc -> IO (FunPtr KeyboardFunc) - -type KeyboardUpFunc = CUChar -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeKeyboardUpFunc :: KeyboardUpFunc -> IO (FunPtr KeyboardUpFunc) - -type MenuDestroyFunc = IO () - -foreign import ccall "wrapper" - makeMenuDestroyFunc :: MenuDestroyFunc -> IO (FunPtr MenuDestroyFunc) - -type MenuStateFunc = CInt -> IO () - -foreign import ccall "wrapper" - makeMenuStateFunc :: MenuStateFunc -> IO (FunPtr MenuStateFunc) - -type MenuStatusFunc = CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeMenuStatusFunc :: MenuStatusFunc -> IO (FunPtr MenuStatusFunc) - -type MotionFunc = CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeMotionFunc :: MotionFunc -> IO (FunPtr MotionFunc) - -type MouseFunc = CInt -> CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeMouseFunc :: MouseFunc -> IO (FunPtr MouseFunc) - -type MouseWheelFunc = CInt -> CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeMouseWheelFunc :: MouseWheelFunc -> IO (FunPtr MouseWheelFunc) - -type OverlayDisplayFunc = IO () - -foreign import ccall "wrapper" - makeOverlayDisplayFunc :: OverlayDisplayFunc -> IO (FunPtr OverlayDisplayFunc) - -type PassiveMotionFunc = CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makePassiveMotionFunc :: PassiveMotionFunc -> IO (FunPtr PassiveMotionFunc) - -type ReshapeFunc = CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeReshapeFunc :: ReshapeFunc -> IO (FunPtr ReshapeFunc) - -type SpaceballButtonFunc = CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeSpaceballButtonFunc :: SpaceballButtonFunc -> IO (FunPtr SpaceballButtonFunc) - -type SpaceballMotionFunc = CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeSpaceballMotionFunc :: SpaceballMotionFunc -> IO (FunPtr SpaceballMotionFunc) - -type SpaceballRotateFunc = CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeSpaceballRotateFunc :: SpaceballRotateFunc -> IO (FunPtr SpaceballRotateFunc) - -type SpecialFunc = CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeSpecialFunc :: SpecialFunc -> IO (FunPtr SpecialFunc) - -type SpecialUpFunc = CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeSpecialUpFunc :: SpecialUpFunc -> IO (FunPtr SpecialUpFunc) - -type TabletButtonFunc = CInt -> CInt -> CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeTabletButtonFunc :: TabletButtonFunc -> IO (FunPtr TabletButtonFunc) - -type TabletMotionFunc = CInt -> CInt -> IO () - -foreign import ccall "wrapper" - makeTabletMotionFunc :: TabletMotionFunc -> IO (FunPtr TabletMotionFunc) - -type TimerFunc = CInt -> IO () - -foreign import ccall "wrapper" - makeTimerFunc :: TimerFunc -> IO (FunPtr TimerFunc) - -type VisibilityFunc = CInt -> IO () - -foreign import ccall "wrapper" - makeVisibilityFunc :: VisibilityFunc -> IO (FunPtr VisibilityFunc) - -type WMCloseFunc = IO () - -foreign import ccall "wrapper" - makeWMCloseFunc :: WMCloseFunc -> IO (FunPtr WMCloseFunc) - -type WindowStatusFunc = CInt -> IO () - -foreign import ccall "wrapper" - makeWindowStatusFunc :: WindowStatusFunc -> IO (FunPtr WindowStatusFunc) diff --git a/Graphics/UI/GLUT/Raw/Fonts.hs b/Graphics/UI/GLUT/Raw/Fonts.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Raw/Fonts.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} --- #hide ------------------------------------------------------------------------------ --- | --- Module : Graphics.UI.GLUT.Raw.Fonts --- Copyright : (c) Sven Panne 2009 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- Our own functions to access font identifiers in a portable way. --- ------------------------------------------------------------------------------ - -module Graphics.UI.GLUT.Raw.Fonts ( - hs_GLUT_marshalBitmapFont, - hs_GLUT_marshalStrokeFont -) where - -import Foreign.C.Types -import Foreign.Ptr - -foreign import ccall unsafe "hs_GLUT_marshalBitmapFont" - hs_GLUT_marshalBitmapFont :: CInt -> IO (Ptr a) - -foreign import ccall unsafe "hs_GLUT_marshalStrokeFont" - hs_GLUT_marshalStrokeFont :: CInt -> IO (Ptr a) diff --git a/Graphics/UI/GLUT/Raw/Functions.hs b/Graphics/UI/GLUT/Raw/Functions.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Raw/Functions.hs +++ /dev/null @@ -1,311 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, CPP #-} --- #hide ------------------------------------------------------------------------------ --- | --- Module : Graphics.UI.GLUT.Raw.Functions --- Copyright : (c) Sven Panne 2009 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- All raw functions from GLUT and freeglut. --- ------------------------------------------------------------------------------ - -module Graphics.UI.GLUT.Raw.Functions ( - glutGetProcAddress, - glutGetColor, - glutStrokeHeight, - glutBitmapHeight, - glutBitmapLength, - glutBitmapWidth, - glutCreateMenu, - glutCreateSubWindow, - glutCreateWindow, - glutDeviceGet, - glutEnterGameMode, - glutExtensionSupported, - glutGameModeGet, - glutGet, - glutGetMenu, - glutGetModifiers, - glutGetWindow, - glutLayerGet, - glutStrokeLength, - glutStrokeWidth, - glutVideoResizeGet, - glutGetModeValues, - glutAddMenuEntry, - glutAddSubMenu, - glutAttachMenu, - glutBitmapCharacter, - glutBitmapString, - glutButtonBoxFunc, - glutChangeToMenuEntry, - glutChangeToSubMenu, - glutCloseFunc, - glutCopyColormap, - glutDestroyMenu, - glutDestroyWindow, - glutDetachMenu, - glutDialsFunc, - glutDisplayFunc, - glutEntryFunc, - glutEstablishOverlay, - glutExit, - glutForceJoystickFunc, - glutFullScreen, - glutFullScreenToggle, - glutGameModeString, - glutHideOverlay, - glutHideWindow, - glutIconifyWindow, - glutIdleFunc, - glutIgnoreKeyRepeat, - glutInit, - glutInitContextFlags, - glutInitContextVersion, - glutInitContextProfile, - glutInitDisplayMode, - glutInitDisplayString, - glutInitWindowPosition, - glutInitWindowSize, - glutJoystickFunc, - glutKeyboardFunc, - glutKeyboardUpFunc, - glutLeaveGameMode, - glutLeaveMainLoop, - glutMainLoop, - glutMainLoopEvent, - glutMenuDestroyFunc, - glutMenuStateFunc, - glutMenuStatusFunc, - glutMotionFunc, - glutMouseFunc, - glutMouseWheelFunc, - glutOverlayDisplayFunc, - glutPassiveMotionFunc, - glutPopWindow, - glutPositionWindow, - glutPostOverlayRedisplay, - glutPostRedisplay, - glutPostWindowOverlayRedisplay, - glutPostWindowRedisplay, - glutPushWindow, - glutRemoveMenuItem, - glutRemoveOverlay, - glutReportErrors, - glutReshapeFunc, - glutReshapeWindow, - glutSetColor, - glutSetCursor, - glutSetIconTitle, - glutSetKeyRepeat, - glutSetMenu, - glutSetMenuData, - glutSetOption, - glutSetWindow, - glutSetWindowData, - glutSetWindowTitle, - glutSetupVideoResizing, - glutShowOverlay, - glutShowWindow, - glutSolidCone, - glutSolidCube, - glutSolidCylinder, - glutSolidDodecahedron, - glutSolidIcosahedron, - glutSolidOctahedron, - glutSolidRhombicDodecahedron, - glutSolidSierpinskiSponge, - glutSolidSphere, - glutSolidTeapot, - glutSolidTetrahedron, - glutSolidTorus, - glutSpaceballButtonFunc, - glutSpaceballMotionFunc, - glutSpaceballRotateFunc, - glutSpecialFunc, - glutSpecialUpFunc, - glutStopVideoResizing, - glutStrokeCharacter, - glutStrokeString, - glutSwapBuffers, - glutTabletButtonFunc, - glutTabletMotionFunc, - glutTimerFunc, - glutUseLayer, - glutVideoPan, - glutVideoResize, - glutVisibilityFunc, - glutWMCloseFunc, - glutWarpPointer, - glutWindowStatusFunc, - glutWireCone, - glutWireCube, - glutWireCylinder, - glutWireDodecahedron, - glutWireIcosahedron, - glutWireOctahedron, - glutWireRhombicDodecahedron, - glutWireSierpinskiSponge, - glutWireSphere, - glutWireTeapot, - glutWireTetrahedron, - glutWireTorus, - glutGetMenuData, - glutGetWindowData -) where - -import Foreign.C.Types -import Foreign.Ptr -import Graphics.Rendering.OpenGL.Raw.Core31.TypesInternal -import Graphics.UI.GLUT.Raw.APIEntry -import Graphics.UI.GLUT.Raw.Callbacks - -#include "HsGLUTExt.h" - -API_ENTRY(glutGetProcAddress,Ptr CChar -> IO (FunPtr a)) -API_ENTRY(glutGetColor,CInt -> CInt -> IO GLfloat) -API_ENTRY(glutStrokeHeight,Ptr a -> IO GLfloat) -API_ENTRY(glutBitmapHeight,Ptr a -> IO CInt) -API_ENTRY(glutBitmapLength,Ptr a -> Ptr CUChar -> IO CInt) -API_ENTRY(glutBitmapWidth,Ptr a -> CInt -> IO CInt) -API_ENTRY(glutCreateMenu,FunPtr MenuFunc -> IO CInt) -API_ENTRY(glutCreateSubWindow,CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt) -API_ENTRY(glutCreateWindow,Ptr CChar -> IO CInt) -API_ENTRY(glutDeviceGet,GLenum -> IO CInt) -API_ENTRY(glutEnterGameMode,IO CInt) -API_ENTRY(glutExtensionSupported,Ptr CChar -> IO CInt) -API_ENTRY(glutGameModeGet,GLenum -> IO CInt) -API_ENTRY(glutGet,GLenum -> IO CInt) -API_ENTRY(glutGetMenu,IO CInt) -API_ENTRY(glutGetModifiers,IO CInt) -API_ENTRY(glutGetWindow,IO CInt) -API_ENTRY(glutLayerGet,GLenum -> IO CInt) -API_ENTRY(glutStrokeLength,Ptr a -> Ptr CUChar -> IO CInt) -API_ENTRY(glutStrokeWidth,Ptr a -> CInt -> IO CInt) -API_ENTRY(glutVideoResizeGet,GLenum -> IO CInt) -API_ENTRY(glutGetModeValues,GLenum -> Ptr CInt -> IO (Ptr CInt)) -API_ENTRY(glutAddMenuEntry,Ptr CChar -> CInt -> IO ()) -API_ENTRY(glutAddSubMenu,Ptr CChar -> CInt -> IO ()) -API_ENTRY(glutAttachMenu,CInt -> IO ()) -API_ENTRY(glutBitmapCharacter,Ptr a -> CInt -> IO ()) -API_ENTRY(glutBitmapString,Ptr a -> Ptr CUChar -> IO ()) -API_ENTRY(glutButtonBoxFunc,FunPtr ButtonBoxFunc -> IO ()) -API_ENTRY(glutChangeToMenuEntry,CInt -> Ptr CChar -> CInt -> IO ()) -API_ENTRY(glutChangeToSubMenu,CInt -> Ptr CChar -> CInt -> IO ()) -API_ENTRY(glutCloseFunc,FunPtr CloseFunc -> IO ()) -API_ENTRY(glutCopyColormap,CInt -> IO ()) -API_ENTRY(glutDestroyMenu,CInt -> IO ()) -API_ENTRY(glutDestroyWindow,CInt -> IO ()) -API_ENTRY(glutDetachMenu,CInt -> IO ()) -API_ENTRY(glutDialsFunc,FunPtr DialsFunc -> IO ()) -API_ENTRY(glutDisplayFunc,FunPtr DisplayFunc -> IO ()) -API_ENTRY(glutEntryFunc,FunPtr EntryFunc -> IO ()) -API_ENTRY_SAFE(glutEstablishOverlay,IO ()) -API_ENTRY(glutExit,IO ()) -API_ENTRY(glutForceJoystickFunc,IO ()) -API_ENTRY(glutFullScreen,IO ()) -API_ENTRY(glutFullScreenToggle,IO ()) -API_ENTRY(glutGameModeString,Ptr CChar -> IO ()) -API_ENTRY_SAFE(glutHideOverlay,IO ()) -API_ENTRY(glutHideWindow,IO ()) -API_ENTRY(glutIconifyWindow,IO ()) -API_ENTRY(glutIdleFunc,FunPtr IdleFunc -> IO ()) -API_ENTRY(glutIgnoreKeyRepeat,CInt -> IO ()) -API_ENTRY(glutInit,Ptr CInt -> Ptr (Ptr CChar) -> IO ()) -API_ENTRY(glutInitContextFlags,CInt -> IO ()) -API_ENTRY(glutInitContextVersion,CInt -> CInt -> IO ()) -API_ENTRY(glutInitContextProfile,CInt -> IO ()) -API_ENTRY(glutInitDisplayMode,CUInt -> IO ()) -API_ENTRY(glutInitDisplayString,Ptr CChar -> IO ()) -API_ENTRY(glutInitWindowPosition,CInt -> CInt -> IO ()) -API_ENTRY(glutInitWindowSize,CInt -> CInt -> IO ()) -API_ENTRY(glutJoystickFunc,FunPtr JoystickFunc -> CInt -> IO ()) -API_ENTRY(glutKeyboardFunc,FunPtr KeyboardFunc -> IO ()) -API_ENTRY(glutKeyboardUpFunc,FunPtr KeyboardUpFunc -> IO ()) -API_ENTRY(glutLeaveGameMode,IO ()) -API_ENTRY_SAFE(glutLeaveMainLoop,IO ()) -API_ENTRY_SAFE(glutMainLoop,IO ()) -API_ENTRY_SAFE(glutMainLoopEvent,IO ()) -API_ENTRY(glutMenuDestroyFunc,FunPtr MenuDestroyFunc -> IO ()) -API_ENTRY(glutMenuStateFunc,FunPtr MenuStateFunc -> IO ()) -API_ENTRY(glutMenuStatusFunc,FunPtr MenuStatusFunc -> IO ()) -API_ENTRY(glutMotionFunc,FunPtr MotionFunc -> IO ()) -API_ENTRY(glutMouseFunc,FunPtr MouseFunc -> IO ()) -API_ENTRY(glutMouseWheelFunc,FunPtr MouseWheelFunc -> IO ()) -API_ENTRY(glutOverlayDisplayFunc,FunPtr OverlayDisplayFunc -> IO ()) -API_ENTRY(glutPassiveMotionFunc,FunPtr PassiveMotionFunc -> IO ()) -API_ENTRY(glutPopWindow,IO ()) -API_ENTRY(glutPositionWindow,CInt -> CInt -> IO ()) -API_ENTRY_SAFE(glutPostOverlayRedisplay,IO ()) -API_ENTRY(glutPostRedisplay,IO ()) -API_ENTRY_SAFE(glutPostWindowOverlayRedisplay,CInt -> IO ()) -API_ENTRY(glutPostWindowRedisplay,CInt -> IO ()) -API_ENTRY(glutPushWindow,IO ()) -API_ENTRY(glutRemoveMenuItem,CInt -> IO ()) -API_ENTRY_SAFE(glutRemoveOverlay,IO ()) -API_ENTRY(glutReportErrors,IO ()) -API_ENTRY(glutReshapeFunc,FunPtr ReshapeFunc -> IO ()) -API_ENTRY(glutReshapeWindow,CInt -> CInt -> IO ()) -API_ENTRY(glutSetColor,CInt -> GLfloat -> GLfloat -> GLfloat -> IO ()) -API_ENTRY(glutSetCursor,CInt -> IO ()) -API_ENTRY(glutSetIconTitle,Ptr CChar -> IO ()) -API_ENTRY(glutSetKeyRepeat,CInt -> IO ()) -API_ENTRY(glutSetMenu,CInt -> IO ()) -API_ENTRY(glutSetMenuData,Ptr a -> IO ()) -API_ENTRY(glutSetOption,GLenum -> CInt -> IO ()) -API_ENTRY(glutSetWindow,CInt -> IO ()) -API_ENTRY(glutSetWindowData,Ptr a -> IO ()) -API_ENTRY(glutSetWindowTitle,Ptr CChar -> IO ()) -API_ENTRY(glutSetupVideoResizing,IO ()) -API_ENTRY_SAFE(glutShowOverlay,IO ()) -API_ENTRY(glutShowWindow,IO ()) -API_ENTRY(glutSolidCone,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(glutSolidCube,GLdouble -> IO ()) -API_ENTRY(glutSolidCylinder,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(glutSolidDodecahedron,IO ()) -API_ENTRY(glutSolidIcosahedron,IO ()) -API_ENTRY(glutSolidOctahedron,IO ()) -API_ENTRY(glutSolidRhombicDodecahedron,IO ()) -API_ENTRY(glutSolidSierpinskiSponge,CInt -> Ptr GLdouble -> GLdouble -> IO ()) -API_ENTRY(glutSolidSphere,GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(glutSolidTeapot,GLdouble -> IO ()) -API_ENTRY(glutSolidTetrahedron,IO ()) -API_ENTRY(glutSolidTorus,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(glutSpaceballButtonFunc,FunPtr SpaceballButtonFunc -> IO ()) -API_ENTRY(glutSpaceballMotionFunc,FunPtr SpaceballMotionFunc -> IO ()) -API_ENTRY(glutSpaceballRotateFunc,FunPtr SpaceballRotateFunc -> IO ()) -API_ENTRY(glutSpecialFunc,FunPtr SpecialFunc -> IO ()) -API_ENTRY(glutSpecialUpFunc,FunPtr SpecialUpFunc -> IO ()) -API_ENTRY(glutStopVideoResizing,IO ()) -API_ENTRY(glutStrokeCharacter,Ptr a -> CInt -> IO ()) -API_ENTRY(glutStrokeString,Ptr a -> Ptr CUChar -> IO ()) -API_ENTRY(glutSwapBuffers,IO ()) -API_ENTRY(glutTabletButtonFunc,FunPtr TabletButtonFunc -> IO ()) -API_ENTRY(glutTabletMotionFunc,FunPtr TabletMotionFunc -> IO ()) -API_ENTRY(glutTimerFunc,CUInt -> FunPtr TimerFunc -> CInt -> IO ()) -API_ENTRY_SAFE(glutUseLayer,GLenum -> IO ()) -API_ENTRY(glutVideoPan,CInt -> CInt -> CInt -> CInt -> IO ()) -API_ENTRY(glutVideoResize,CInt -> CInt -> CInt -> CInt -> IO ()) -API_ENTRY(glutVisibilityFunc,FunPtr VisibilityFunc -> IO ()) -API_ENTRY(glutWMCloseFunc,FunPtr WMCloseFunc -> IO ()) -API_ENTRY(glutWarpPointer,CInt -> CInt -> IO ()) -API_ENTRY(glutWindowStatusFunc,FunPtr WindowStatusFunc -> IO ()) -API_ENTRY(glutWireCone,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(glutWireCube,GLdouble -> IO ()) -API_ENTRY(glutWireCylinder,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(glutWireDodecahedron,IO ()) -API_ENTRY(glutWireIcosahedron,IO ()) -API_ENTRY(glutWireOctahedron,IO ()) -API_ENTRY(glutWireRhombicDodecahedron,IO ()) -API_ENTRY(glutWireSierpinskiSponge,CInt -> Ptr GLdouble -> GLdouble -> IO ()) -API_ENTRY(glutWireSphere,GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(glutWireTeapot,GLdouble -> IO ()) -API_ENTRY(glutWireTetrahedron,IO ()) -API_ENTRY(glutWireTorus,GLdouble -> GLdouble -> GLint -> GLint -> IO ()) -API_ENTRY(glutGetMenuData,IO (Ptr a)) -API_ENTRY(glutGetWindowData,IO (Ptr a)) diff --git a/Graphics/UI/GLUT/Raw/Tokens.hs b/Graphics/UI/GLUT/Raw/Tokens.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Raw/Tokens.hs +++ /dev/null @@ -1,613 +0,0 @@ --- #hide ------------------------------------------------------------------------------ --- | --- Module : Graphics.UI.GLUT.Raw.Tokens --- Copyright : (c) Sven Panne 2009 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- All tokens from GLUT and freeglut. --- ------------------------------------------------------------------------------ - -module Graphics.UI.GLUT.Raw.Tokens where - -import Foreign.C.Types -import Graphics.Rendering.OpenGL ( GLenum ) - -glut_ACCUM :: CUInt -glut_ACCUM = 0x0004 - -glut_ACTION_CONTINUE_EXECUTION :: CInt -glut_ACTION_CONTINUE_EXECUTION = 2 - -glut_ACTION_EXIT :: CInt -glut_ACTION_EXIT = 0 - -glut_ACTION_GLUTMAINLOOP_RETURNS :: CInt -glut_ACTION_GLUTMAINLOOP_RETURNS = 1 - -glut_ACTION_ON_WINDOW_CLOSE :: GLenum -glut_ACTION_ON_WINDOW_CLOSE = 0x01F9 - -glut_ACTIVE_ALT :: CInt -glut_ACTIVE_ALT = 0x0004 - -glut_ACTIVE_CTRL :: CInt -glut_ACTIVE_CTRL = 0x0002 - -glut_ACTIVE_SHIFT :: CInt -glut_ACTIVE_SHIFT = 0x0001 - -glut_ALLOW_DIRECT_CONTEXT :: CInt -glut_ALLOW_DIRECT_CONTEXT = 1 - -glut_ALPHA :: CUInt -glut_ALPHA = 0x0008 - -glut_AUX :: GLenum -glut_AUX = 0x1000 - -glut_AUX1 :: CUInt -glut_AUX1 = 0x1000 - -glut_AUX2 :: CUInt -glut_AUX2 = 0x2000 - -glut_AUX3 :: CUInt -glut_AUX3 = 0x4000 - -glut_AUX4 :: CUInt -glut_AUX4 = 0x8000 - -glut_BLUE :: CInt -glut_BLUE = 0x0002 - -glut_BORDERLESS :: CUInt -glut_BORDERLESS = 0x0800 - -glut_CAPTIONLESS :: CUInt -glut_CAPTIONLESS = 0x0400 - -glut_CORE_PROFILE :: CInt -glut_CORE_PROFILE = 0x0001 - -glut_COMPATIBILITY_PROFILE :: CInt -glut_COMPATIBILITY_PROFILE = 0x0002 - -glut_CREATE_NEW_CONTEXT :: CInt -glut_CREATE_NEW_CONTEXT = 0 - -glut_CURSOR_BOTTOM_LEFT_CORNER :: CInt -glut_CURSOR_BOTTOM_LEFT_CORNER = 0x0013 - -glut_CURSOR_BOTTOM_RIGHT_CORNER :: CInt -glut_CURSOR_BOTTOM_RIGHT_CORNER = 0x0012 - -glut_CURSOR_BOTTOM_SIDE :: CInt -glut_CURSOR_BOTTOM_SIDE = 0x000D - -glut_CURSOR_CROSSHAIR :: CInt -glut_CURSOR_CROSSHAIR = 0x0009 - -glut_CURSOR_CYCLE :: CInt -glut_CURSOR_CYCLE = 0x0005 - -glut_CURSOR_DESTROY :: CInt -glut_CURSOR_DESTROY = 0x0003 - -glut_CURSOR_FULL_CROSSHAIR :: CInt -glut_CURSOR_FULL_CROSSHAIR = 0x0066 - -glut_CURSOR_HELP :: CInt -glut_CURSOR_HELP = 0x0004 - -glut_CURSOR_INFO :: CInt -glut_CURSOR_INFO = 0x0002 - -glut_CURSOR_INHERIT :: CInt -glut_CURSOR_INHERIT = 0x0064 - -glut_CURSOR_LEFT_ARROW :: CInt -glut_CURSOR_LEFT_ARROW = 0x0001 - -glut_CURSOR_LEFT_RIGHT :: CInt -glut_CURSOR_LEFT_RIGHT = 0x000B - -glut_CURSOR_LEFT_SIDE :: CInt -glut_CURSOR_LEFT_SIDE = 0x000E - -glut_CURSOR_NONE :: CInt -glut_CURSOR_NONE = 0x0065 - -glut_CURSOR_RIGHT_ARROW :: CInt -glut_CURSOR_RIGHT_ARROW = 0x0000 - -glut_CURSOR_RIGHT_SIDE :: CInt -glut_CURSOR_RIGHT_SIDE = 0x000F - -glut_CURSOR_SPRAY :: CInt -glut_CURSOR_SPRAY = 0x0006 - -glut_CURSOR_TEXT :: CInt -glut_CURSOR_TEXT = 0x0008 - -glut_CURSOR_TOP_LEFT_CORNER :: CInt -glut_CURSOR_TOP_LEFT_CORNER = 0x0010 - -glut_CURSOR_TOP_RIGHT_CORNER :: CInt -glut_CURSOR_TOP_RIGHT_CORNER = 0x0011 - -glut_CURSOR_TOP_SIDE :: CInt -glut_CURSOR_TOP_SIDE = 0x000C - -glut_CURSOR_UP_DOWN :: CInt -glut_CURSOR_UP_DOWN = 0x000A - -glut_CURSOR_WAIT :: CInt -glut_CURSOR_WAIT = 0x0007 - -glut_DEBUG :: CInt -glut_DEBUG = 0x0001 - -glut_DEPTH :: CUInt -glut_DEPTH = 0x0010 - -glut_DEVICE_IGNORE_KEY_REPEAT :: GLenum -glut_DEVICE_IGNORE_KEY_REPEAT = 0x0262 - -glut_DEVICE_KEY_REPEAT :: GLenum -glut_DEVICE_KEY_REPEAT = 0x0263 - -glut_DIRECT_RENDERING :: GLenum -glut_DIRECT_RENDERING = 0x01FE - -glut_DISPLAY_MODE_POSSIBLE :: GLenum -glut_DISPLAY_MODE_POSSIBLE = 0x0190 - -glut_DOUBLE :: CUInt -glut_DOUBLE = 0x0002 - -glut_DOWN :: CInt -glut_DOWN = 0x0000 - -glut_ELAPSED_TIME :: GLenum -glut_ELAPSED_TIME = 0x02BC - -glut_ENTERED :: CInt -glut_ENTERED = 0x0001 - -glut_FORCE_DIRECT_CONTEXT :: CInt -glut_FORCE_DIRECT_CONTEXT = 3 - -glut_FORCE_INDIRECT_CONTEXT :: CInt -glut_FORCE_INDIRECT_CONTEXT = 0 - -glut_FORWARD_COMPATIBLE :: CInt -glut_FORWARD_COMPATIBLE = 0x0002 - -glut_FULLY_COVERED :: CInt -glut_FULLY_COVERED = 0x0003 - -glut_FULLY_RETAINED :: CInt -glut_FULLY_RETAINED = 0x0001 - -glut_FULL_SCREEN :: GLenum -glut_FULL_SCREEN = 0x01FF - -glut_GAME_MODE_ACTIVE :: GLenum -glut_GAME_MODE_ACTIVE = 0x0000 - -glut_GAME_MODE_DISPLAY_CHANGED :: GLenum -glut_GAME_MODE_DISPLAY_CHANGED = 0x0006 - -glut_GAME_MODE_HEIGHT :: GLenum -glut_GAME_MODE_HEIGHT = 0x0003 - -glut_GAME_MODE_PIXEL_DEPTH :: GLenum -glut_GAME_MODE_PIXEL_DEPTH = 0x0004 - -glut_GAME_MODE_POSSIBLE :: GLenum -glut_GAME_MODE_POSSIBLE = 0x0001 - -glut_GAME_MODE_REFRESH_RATE :: GLenum -glut_GAME_MODE_REFRESH_RATE = 0x0005 - -glut_GAME_MODE_WIDTH :: GLenum -glut_GAME_MODE_WIDTH = 0x0002 - -glut_GREEN :: CInt -glut_GREEN = 0x0001 - -glut_HAS_DIAL_AND_BUTTON_BOX :: GLenum -glut_HAS_DIAL_AND_BUTTON_BOX = 0x025B - -glut_HAS_JOYSTICK :: GLenum -glut_HAS_JOYSTICK = 0x0264 - -glut_HAS_KEYBOARD :: GLenum -glut_HAS_KEYBOARD = 0x0258 - -glut_HAS_MOUSE :: GLenum -glut_HAS_MOUSE = 0x0259 - -glut_HAS_OVERLAY :: GLenum -glut_HAS_OVERLAY = 0x0322 - -glut_HAS_SPACEBALL :: GLenum -glut_HAS_SPACEBALL = 0x025A - -glut_HAS_TABLET :: GLenum -glut_HAS_TABLET = 0x025C - -glut_HIDDEN :: CInt -glut_HIDDEN = 0x0000 - -glut_INDEX :: CUInt -glut_INDEX = 0x0001 - -glut_INIT_DISPLAY_MODE :: GLenum -glut_INIT_DISPLAY_MODE = 0x01F8 - -glut_INIT_FLAGS :: GLenum -glut_INIT_FLAGS = 0x0202 - -glut_INIT_MAJOR_VERSION :: GLenum -glut_INIT_MAJOR_VERSION = 0x0200 - -glut_INIT_MINOR_VERSION :: GLenum -glut_INIT_MINOR_VERSION = 0x0201 - -glut_INIT_PROFILE :: GLenum -glut_INIT_PROFILE = 0x0203 - -glut_INIT_STATE :: GLenum -glut_INIT_STATE = 0x007C - -glut_INIT_WINDOW_HEIGHT :: GLenum -glut_INIT_WINDOW_HEIGHT = 0x01F7 - -glut_INIT_WINDOW_WIDTH :: GLenum -glut_INIT_WINDOW_WIDTH = 0x01F6 - -glut_INIT_WINDOW_X :: GLenum -glut_INIT_WINDOW_X = 0x01F4 - -glut_INIT_WINDOW_Y :: GLenum -glut_INIT_WINDOW_Y = 0x01F5 - -glut_JOYSTICK_AXES :: GLenum -glut_JOYSTICK_AXES = 0x0267 - -glut_JOYSTICK_BUTTONS :: GLenum -glut_JOYSTICK_BUTTONS = 0x0266 - -glut_JOYSTICK_BUTTON_A :: CUInt -glut_JOYSTICK_BUTTON_A = 0x0001 - -glut_JOYSTICK_BUTTON_B :: CUInt -glut_JOYSTICK_BUTTON_B = 0x0002 - -glut_JOYSTICK_BUTTON_C :: CUInt -glut_JOYSTICK_BUTTON_C = 0x0004 - -glut_JOYSTICK_BUTTON_D :: CUInt -glut_JOYSTICK_BUTTON_D = 0x0008 - -glut_JOYSTICK_POLL_RATE :: GLenum -glut_JOYSTICK_POLL_RATE = 0x0268 - -glut_KEY_BEGIN :: CInt -glut_KEY_BEGIN = 0x006E - -glut_KEY_DELETE :: CInt -glut_KEY_DELETE = 0x006F - -glut_KEY_DOWN :: CInt -glut_KEY_DOWN = 0x0067 - -glut_KEY_END :: CInt -glut_KEY_END = 0x006B - -glut_KEY_F1 :: CInt -glut_KEY_F1 = 0x0001 - -glut_KEY_F10 :: CInt -glut_KEY_F10 = 0x000A - -glut_KEY_F11 :: CInt -glut_KEY_F11 = 0x000B - -glut_KEY_F12 :: CInt -glut_KEY_F12 = 0x000C - -glut_KEY_F2 :: CInt -glut_KEY_F2 = 0x0002 - -glut_KEY_F3 :: CInt -glut_KEY_F3 = 0x0003 - -glut_KEY_F4 :: CInt -glut_KEY_F4 = 0x0004 - -glut_KEY_F5 :: CInt -glut_KEY_F5 = 0x0005 - -glut_KEY_F6 :: CInt -glut_KEY_F6 = 0x0006 - -glut_KEY_F7 :: CInt -glut_KEY_F7 = 0x0007 - -glut_KEY_F8 :: CInt -glut_KEY_F8 = 0x0008 - -glut_KEY_F9 :: CInt -glut_KEY_F9 = 0x0009 - -glut_KEY_HOME :: CInt -glut_KEY_HOME = 0x006A - -glut_KEY_INSERT :: CInt -glut_KEY_INSERT = 0x006C - -glut_KEY_LEFT :: CInt -glut_KEY_LEFT = 0x0064 - -glut_KEY_NUM_LOCK :: CInt -glut_KEY_NUM_LOCK = 0x006D - -glut_KEY_PAGE_DOWN :: CInt -glut_KEY_PAGE_DOWN = 0x0069 - -glut_KEY_PAGE_UP :: CInt -glut_KEY_PAGE_UP = 0x0068 - -glut_KEY_REPEAT_DEFAULT :: CInt -glut_KEY_REPEAT_DEFAULT = 0x0002 - -glut_KEY_REPEAT_OFF :: CInt -glut_KEY_REPEAT_OFF = 0x0000 - -glut_KEY_REPEAT_ON :: CInt -glut_KEY_REPEAT_ON = 0x0001 - -glut_KEY_RIGHT :: CInt -glut_KEY_RIGHT = 0x0066 - -glut_KEY_UP :: CInt -glut_KEY_UP = 0x0065 - -glut_LAYER_IN_USE :: GLenum -glut_LAYER_IN_USE = 0x0321 - -glut_LEFT :: CInt -glut_LEFT = 0x0000 - -glut_LEFT_BUTTON :: CInt -glut_LEFT_BUTTON = 0x0000 - -glut_LUMINANCE :: CUInt -glut_LUMINANCE = 0x0200 - -glut_MENU_IN_USE :: CInt -glut_MENU_IN_USE = 0x0001 - -glut_MENU_NOT_IN_USE :: CInt -glut_MENU_NOT_IN_USE = 0x0000 - -glut_MENU_NUM_ITEMS :: GLenum -glut_MENU_NUM_ITEMS = 0x012C - -glut_MIDDLE_BUTTON :: CInt -glut_MIDDLE_BUTTON = 0x0001 - -glut_MULTISAMPLE :: CUInt -glut_MULTISAMPLE = 0x0080 - -glut_NORMAL :: GLenum -glut_NORMAL = 0x0000 - -glut_NORMAL_DAMAGED :: GLenum -glut_NORMAL_DAMAGED = 0x0324 - -glut_NOT_VISIBLE :: CInt -glut_NOT_VISIBLE = 0x0000 - -glut_NUM_BUTTON_BOX_BUTTONS :: GLenum -glut_NUM_BUTTON_BOX_BUTTONS = 0x025F - -glut_NUM_DIALS :: GLenum -glut_NUM_DIALS = 0x0260 - -glut_NUM_MOUSE_BUTTONS :: GLenum -glut_NUM_MOUSE_BUTTONS = 0x025D - -glut_NUM_SPACEBALL_BUTTONS :: GLenum -glut_NUM_SPACEBALL_BUTTONS = 0x025E - -glut_NUM_TABLET_BUTTONS :: GLenum -glut_NUM_TABLET_BUTTONS = 0x0261 - -glut_OVERLAY :: GLenum -glut_OVERLAY = 0x0001 - -glut_OVERLAY_DAMAGED :: GLenum -glut_OVERLAY_DAMAGED = 0x0325 - -glut_OVERLAY_POSSIBLE :: GLenum -glut_OVERLAY_POSSIBLE = 0x0320 - -glut_OWNS_JOYSTICK :: GLenum -glut_OWNS_JOYSTICK = 0x0265 - -glut_PARTIALLY_RETAINED :: CInt -glut_PARTIALLY_RETAINED = 0x0002 - -glut_RED :: CInt -glut_RED = 0x0000 - -glut_RENDERING_CONTEXT :: GLenum -glut_RENDERING_CONTEXT = 0x01FD - -glut_RGB :: CUInt -glut_RGB = 0x0000 - -glut_RGBA :: CUInt -glut_RGBA = 0x0000 - -glut_RIGHT_BUTTON :: CInt -glut_RIGHT_BUTTON = 0x0002 - -glut_SCREEN_HEIGHT :: GLenum -glut_SCREEN_HEIGHT = 0x00C9 - -glut_SCREEN_HEIGHT_MM :: GLenum -glut_SCREEN_HEIGHT_MM = 0x00CB - -glut_SCREEN_WIDTH :: GLenum -glut_SCREEN_WIDTH = 0x00C8 - -glut_SCREEN_WIDTH_MM :: GLenum -glut_SCREEN_WIDTH_MM = 0x00CA - -glut_SINGLE :: CUInt -glut_SINGLE = 0x0000 - -glut_SRGB :: CUInt -glut_SRGB = 0x1000 - -glut_STENCIL :: CUInt -glut_STENCIL = 0x0020 - -glut_STEREO :: CUInt -glut_STEREO = 0x0100 - -glut_TRANSPARENT_INDEX :: GLenum -glut_TRANSPARENT_INDEX = 0x0323 - -glut_TRY_DIRECT_CONTEXT :: CInt -glut_TRY_DIRECT_CONTEXT = 2 - -glut_UP :: CInt -glut_UP = 0x0001 - -glut_USE_CURRENT_CONTEXT :: CInt -glut_USE_CURRENT_CONTEXT = 1 - -glut_VERSION :: GLenum -glut_VERSION = 0x01FC - -glut_VIDEO_RESIZE_HEIGHT :: GLenum -glut_VIDEO_RESIZE_HEIGHT = 0x038D - -glut_VIDEO_RESIZE_HEIGHT_DELTA :: GLenum -glut_VIDEO_RESIZE_HEIGHT_DELTA = 0x0389 - -glut_VIDEO_RESIZE_IN_USE :: GLenum -glut_VIDEO_RESIZE_IN_USE = 0x0385 - -glut_VIDEO_RESIZE_POSSIBLE :: GLenum -glut_VIDEO_RESIZE_POSSIBLE = 0x0384 - -glut_VIDEO_RESIZE_WIDTH :: GLenum -glut_VIDEO_RESIZE_WIDTH = 0x038C - -glut_VIDEO_RESIZE_WIDTH_DELTA :: GLenum -glut_VIDEO_RESIZE_WIDTH_DELTA = 0x0388 - -glut_VIDEO_RESIZE_X :: GLenum -glut_VIDEO_RESIZE_X = 0x038A - -glut_VIDEO_RESIZE_X_DELTA :: GLenum -glut_VIDEO_RESIZE_X_DELTA = 0x0386 - -glut_VIDEO_RESIZE_Y :: GLenum -glut_VIDEO_RESIZE_Y = 0x038B - -glut_VIDEO_RESIZE_Y_DELTA :: GLenum -glut_VIDEO_RESIZE_Y_DELTA = 0x0387 - -glut_VISIBLE :: CInt -glut_VISIBLE = 0x0001 - -glut_WINDOW_ACCUM_ALPHA_SIZE :: GLenum -glut_WINDOW_ACCUM_ALPHA_SIZE = 0x0072 - -glut_WINDOW_ACCUM_BLUE_SIZE :: GLenum -glut_WINDOW_ACCUM_BLUE_SIZE = 0x0071 - -glut_WINDOW_ACCUM_GREEN_SIZE :: GLenum -glut_WINDOW_ACCUM_GREEN_SIZE = 0x0070 - -glut_WINDOW_ACCUM_RED_SIZE :: GLenum -glut_WINDOW_ACCUM_RED_SIZE = 0x006F - -glut_WINDOW_ALPHA_SIZE :: GLenum -glut_WINDOW_ALPHA_SIZE = 0x006E - -glut_WINDOW_BLUE_SIZE :: GLenum -glut_WINDOW_BLUE_SIZE = 0x006D - -glut_WINDOW_BORDER_WIDTH :: GLenum -glut_WINDOW_BORDER_WIDTH = 0x01FA - -glut_WINDOW_BUFFER_SIZE :: GLenum -glut_WINDOW_BUFFER_SIZE = 0x0068 - -glut_WINDOW_COLORMAP_SIZE :: GLenum -glut_WINDOW_COLORMAP_SIZE = 0x0077 - -glut_WINDOW_CURSOR :: GLenum -glut_WINDOW_CURSOR = 0x007A - -glut_WINDOW_DEPTH_SIZE :: GLenum -glut_WINDOW_DEPTH_SIZE = 0x006A - -glut_WINDOW_DOUBLEBUFFER :: GLenum -glut_WINDOW_DOUBLEBUFFER = 0x0073 - -glut_WINDOW_FORMAT_ID :: GLenum -glut_WINDOW_FORMAT_ID = 0x007B - -glut_WINDOW_GREEN_SIZE :: GLenum -glut_WINDOW_GREEN_SIZE = 0x006C - -glut_WINDOW_HEADER_HEIGHT :: GLenum -glut_WINDOW_HEADER_HEIGHT = 0x01FB - -glut_WINDOW_HEIGHT :: GLenum -glut_WINDOW_HEIGHT = 0x0067 - -glut_WINDOW_NUM_CHILDREN :: GLenum -glut_WINDOW_NUM_CHILDREN = 0x0076 - -glut_WINDOW_NUM_SAMPLES :: GLenum -glut_WINDOW_NUM_SAMPLES = 0x0078 - -glut_WINDOW_PARENT :: GLenum -glut_WINDOW_PARENT = 0x0075 - -glut_WINDOW_RED_SIZE :: GLenum -glut_WINDOW_RED_SIZE = 0x006B - -glut_WINDOW_RGBA :: GLenum -glut_WINDOW_RGBA = 0x0074 - -glut_WINDOW_STENCIL_SIZE :: GLenum -glut_WINDOW_STENCIL_SIZE = 0x0069 - -glut_WINDOW_STEREO :: GLenum -glut_WINDOW_STEREO = 0x0079 - -glut_WINDOW_WIDTH :: GLenum -glut_WINDOW_WIDTH = 0x0066 - -glut_WINDOW_X :: GLenum -glut_WINDOW_X = 0x0064 - -glut_WINDOW_Y :: GLenum -glut_WINDOW_Y = 0x0065 diff --git a/Graphics/UI/GLUT/State.hs b/Graphics/UI/GLUT/State.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/State.hs +++ /dev/null @@ -1,381 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.State --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- GLUT maintains a considerable amount of programmer visible state. Some (but --- not all) of this state may be directly retrieved. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.State ( - -- * State of all windows - windowBorderWidth, windowHeaderHeight, - - -- * State of the /current window/ - rgba, - BufferDepth, rgbaBufferDepths, colorBufferDepth, - doubleBuffered, stereo, - accumBufferDepths, depthBufferDepth, stencilBufferDepth, - SampleCount, sampleCount, formatID, - fullScreenMode, - - -- * GLUT state pertaining to the layers of the /current window/ - damaged, - - -- * Timing - elapsedTime, - - -- * Device information - - -- $DeviceInformation - screenSize, screenSizeMM, - hasKeyboard, - ButtonCount, numMouseButtons, - numSpaceballButtons, - DialCount, numDialsAndButtons, - numTabletButtons, - AxisCount, PollRate, joystickInfo, - supportedNumAuxBuffers, supportedSamplesPerPixel, - - -- * GLUT information - glutVersion, initState -) where - -import Control.Monad -import 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.Overlay -import Graphics.UI.GLUT.QueryUtils -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.Window - --------------------------------------------------------------------------------- - --- | Contains 'True' when the current layer of the /current window/ is in RGBA --- mode, 'False' means color index mode. - -rgba :: GettableStateVar Bool -rgba = makeGettableStateVar$ simpleGet i2b glut_WINDOW_RGBA - --- | Bit depth of a buffer - -type BufferDepth = Int - --- | Contains the number of red, green, blue, and alpha bits in the color buffer --- of the /current window\'s/ current layer (0 in color index mode). - -rgbaBufferDepths :: - GettableStateVar (BufferDepth, BufferDepth, BufferDepth, BufferDepth) -rgbaBufferDepths = makeGettableStateVar $ do - r <- simpleGet fromIntegral glut_WINDOW_RED_SIZE - g <- simpleGet fromIntegral glut_WINDOW_GREEN_SIZE - b <- simpleGet fromIntegral glut_WINDOW_BLUE_SIZE - a <- simpleGet fromIntegral glut_WINDOW_ALPHA_SIZE - return (r, g, b, a) - --- | Contains the total number of bits in the color buffer of the /current --- window\'s/ current layer. For an RGBA layer, this is the sum of the red, --- green, blue, and alpha bits. For an color index layer, this is the number --- of bits of the color indexes. - -colorBufferDepth :: GettableStateVar BufferDepth -colorBufferDepth = - makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_BUFFER_SIZE - --- | Contains 'True' when the current layer of the /current window/ is double --- buffered, 'False' otherwise. - -doubleBuffered :: GettableStateVar Bool -doubleBuffered = makeGettableStateVar $ simpleGet i2b glut_WINDOW_DOUBLEBUFFER - --- | Contains 'True' when the current layer of the /current window/ is stereo, --- 'False' otherwise. - -stereo :: GettableStateVar Bool -stereo = makeGettableStateVar $ simpleGet i2b glut_WINDOW_STEREO - --- | Contains the number of red, green, blue, and alpha bits in the accumulation --- buffer of the /current window\'s/ current layer (0 in color index mode). - -accumBufferDepths :: - GettableStateVar (BufferDepth, BufferDepth, BufferDepth, BufferDepth) -accumBufferDepths = makeGettableStateVar $ do - r <- simpleGet fromIntegral glut_WINDOW_ACCUM_RED_SIZE - g <- simpleGet fromIntegral glut_WINDOW_ACCUM_GREEN_SIZE - b <- simpleGet fromIntegral glut_WINDOW_ACCUM_BLUE_SIZE - a <- simpleGet fromIntegral glut_WINDOW_ACCUM_ALPHA_SIZE - return (r, g, b, a) - --- | Contains the number of bits in the depth buffer of the /current window\'s/ --- current layer. - -depthBufferDepth :: GettableStateVar BufferDepth -depthBufferDepth = - makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_DEPTH_SIZE - --- | Contains the number of bits in the stencil buffer of the /current --- window\'s/ current layer. - -stencilBufferDepth :: GettableStateVar BufferDepth -stencilBufferDepth = - makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_STENCIL_SIZE - --- | Number of samples for multisampling - -type SampleCount = Int - --- | Contains the number of samples for multisampling for the /current window./ - -sampleCount :: GettableStateVar SampleCount -sampleCount = - makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_NUM_SAMPLES - --- | Contains the window system dependent format ID for the current layer of the --- /current window/. On X11 GLUT implementations, this is the X visual ID. On --- Win32 GLUT implementations, this is the Win32 Pixel Format Descriptor number. --- This value is returned for debugging, benchmarking, and testing ease. - -formatID :: GettableStateVar Int -formatID = makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_FORMAT_ID - --------------------------------------------------------------------------------- - --- | (/freeglut only/) Contains 'True' if the /current window/ is in full screen --- mode, 'False' otherwise. - -fullScreenMode :: StateVar Bool -fullScreenMode = makeStateVar getFullScreenMode setFullScreenMode - -getFullScreenMode :: IO Bool -getFullScreenMode = simpleGet i2b glut_FULL_SCREEN - -setFullScreenMode :: Bool -> IO () -setFullScreenMode newMode = do - oldMode <- getFullScreenMode - unless (newMode == oldMode) fullScreenToggle - --------------------------------------------------------------------------------- - --- | Contains the number of milliseconds since --- 'Graphics.UI.GLUT.Initialization.initialize' was called. - -elapsedTime :: GettableStateVar Int -elapsedTime = makeGettableStateVar $ simpleGet fromIntegral glut_ELAPSED_TIME - --------------------------------------------------------------------------------- - --- | Contains 'True' if the given plane of the /current window/ has been --- damaged (by window system activity) since the last display callback was --- triggered. Calling 'Graphics.UI.GLUT.Window.postRedisplay' or --- 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay' will not set this 'True'. - -damaged :: Layer -> GettableStateVar Bool -damaged l = makeGettableStateVar $ layerGet isDamaged (marshalDamagedLayer l) - where isDamaged d = d /= 0 && d /= -1 - marshalDamagedLayer x = case x of - Normal -> glut_NORMAL_DAMAGED - Overlay -> glut_OVERLAY_DAMAGED - --------------------------------------------------------------------------------- - --- $DeviceInformation --- If a device is not available, the following state variables contain --- 'Nothing', otherwise they return 'Just' the specific device information. --- Only a screen is always assumed. - --------------------------------------------------------------------------------- - --- | The size of the screen in pixels. - -screenSize :: GettableStateVar Size -screenSize = - makeGettableStateVar $ do - wpx <- simpleGet fromIntegral glut_SCREEN_WIDTH - hpx <- simpleGet fromIntegral glut_SCREEN_HEIGHT - return $ Size wpx hpx - --- | The size of the screen in millimeters. - -screenSizeMM :: GettableStateVar Size -screenSizeMM = - makeGettableStateVar $ do - wmm <- simpleGet fromIntegral glut_SCREEN_WIDTH_MM - hmm <- simpleGet fromIntegral glut_SCREEN_HEIGHT_MM - return $ Size wmm hmm - --------------------------------------------------------------------------------- - --- | Contains 'True' if a keyboard is present, 'False' otherwise. - -hasKeyboard :: GettableStateVar Bool -hasKeyboard = makeGettableStateVar $ deviceGet i2b glut_HAS_KEYBOARD - --------------------------------------------------------------------------------- - --- | Number of buttons of an input device - -type ButtonCount = Int - --- | Contains 'Just' the number of buttons of an attached mouse or 'Nothing' if --- there is none. - -numMouseButtons :: GettableStateVar (Maybe ButtonCount) -numMouseButtons = - getDeviceInfo glut_HAS_MOUSE $ - deviceGet fromIntegral glut_NUM_MOUSE_BUTTONS - --------------------------------------------------------------------------------- - --- | Contains 'Just' the number of buttons of the attached Spaceball or 'Nothing' --- if there is none. - -numSpaceballButtons :: GettableStateVar (Maybe ButtonCount) -numSpaceballButtons = - getDeviceInfo glut_HAS_SPACEBALL $ - deviceGet fromIntegral glut_NUM_SPACEBALL_BUTTONS - --------------------------------------------------------------------------------- - --- | Number of dials of a dial and button box - -type DialCount = Int - --- | Contains 'Just' the number of dials and buttons of an attached dial & --- button box or 'Nothing' if there is none. - -numDialsAndButtons :: GettableStateVar (Maybe (DialCount, ButtonCount)) -numDialsAndButtons = - getDeviceInfo glut_HAS_DIAL_AND_BUTTON_BOX $ do - d <- deviceGet fromIntegral glut_NUM_DIALS - b <- deviceGet fromIntegral glut_NUM_BUTTON_BOX_BUTTONS - return (d, b) - --------------------------------------------------------------------------------- - --- | Contains 'Just' the number of buttons of an attached tablet or 'Nothing' if --- there is none. - -numTabletButtons :: GettableStateVar (Maybe ButtonCount) -numTabletButtons = - getDeviceInfo glut_HAS_TABLET $ - deviceGet fromIntegral glut_NUM_TABLET_BUTTONS - --------------------------------------------------------------------------------- - --- | Number of axes of a joystick - -type AxisCount = Int - --- | The a rate at which a joystick is polled (in milliseconds) - -type PollRate = Int - --- | Contains 'Just' the number of buttons of an attached joystick, the number --- of joystick axes, and the rate at which the joystick is polled. Contains --- 'Nothing' if there is no joystick attached. - -joystickInfo :: GettableStateVar (Maybe (ButtonCount, PollRate, AxisCount)) -joystickInfo = - getDeviceInfo glut_HAS_JOYSTICK $ do - b <- deviceGet fromIntegral glut_JOYSTICK_BUTTONS - a <- deviceGet fromIntegral glut_JOYSTICK_AXES - r <- deviceGet fromIntegral glut_JOYSTICK_POLL_RATE - return (b, a, r) - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Contains a list of the number of auxiliary buffers --- supported, in increasing order. - -supportedNumAuxBuffers :: GettableStateVar [Int] -supportedNumAuxBuffers = getModeValues glut_AUX - --- | (/freeglut only/) Contains a list of the number of samples per pixel --- supported for multisampling, in increasing order. - -supportedSamplesPerPixel :: GettableStateVar [SampleCount] -supportedSamplesPerPixel = getModeValues (fromIntegral glut_MULTISAMPLE) - -getModeValues :: Integral a => GLenum -> GettableStateVar [a] -getModeValues what = makeGettableStateVar $ - alloca $ \sizeBuffer -> do - valuesBuffer <- glutGetModeValues what sizeBuffer - size <- peek sizeBuffer - fmap (map fromIntegral) $ peekArray (fromIntegral size) valuesBuffer - --------------------------------------------------------------------------------- --- Convenience unmarshalers - -i2b :: CInt -> Bool -i2b = (/= 0) - --------------------------------------------------------------------------------- - -getDeviceInfo :: GLenum -> IO a -> GettableStateVar (Maybe a) -getDeviceInfo dev act = - makeGettableStateVar $ do - hasDevice <- deviceGet i2b dev - if hasDevice then fmap Just act else return Nothing - ------------------------------------------------------------------------------ - --- | Contains version of GLUT in the form of --- @/flavour/ /major/./minor/./patchlevel/@, where @/flavour/@ is one of --- @GLUT@, @freeglut@ or @OpenGLUT@. - -glutVersion :: GettableStateVar String -glutVersion = makeGettableStateVar $ do - let isGLUT = isUnknown "glutSetOption" - isFreeglut = isUnknown "glutSetWindowStayOnTop" - isUnknown = fmap (== nullFunPtr) . getAPIEntryInternal - showVersionPart x = shows (x `mod` 100) - showVersion v = showVersionPart (v `div` 10000) . showChar '.' . - showVersionPart (v `div` 100) . showChar '.' . - showVersionPart v - g <- isGLUT - if g - then return "GLUT 3.7" -- ToDo: just guessing - else do f <- isFreeglut - v <- simpleGet id glut_VERSION - let prefix = if f then "freeglut" else "OpenGLUT" - return $ showString prefix . showChar ' ' . showVersion v $ "" - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Contains the thickness of the sizing border around the --- perimeter of a window that can be resized, in pixels. - -windowBorderWidth :: GettableStateVar Int -windowBorderWidth = - makeGettableStateVar (simpleGet fromIntegral glut_WINDOW_BORDER_WIDTH) - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Contains the height of the header\/caption area of a --- window in pixels. - -windowHeaderHeight :: GettableStateVar Int -windowHeaderHeight = - makeGettableStateVar (simpleGet fromIntegral glut_WINDOW_HEADER_HEIGHT) - ------------------------------------------------------------------------------ - --- | (/freeglut only/) Contains 'True' if GLUT has been initialized --- with 'Graphics.UI.GLUT.Initialization.initialize' or --- 'Graphics.UI.GLUT.Initialization.getArgsAndInitialize' has and not yet --- been de-initialized with 'Graphics.UI.GLUT.Initialization.exit'. Contains --- 'False' otherwise. - -initState :: GettableStateVar Bool -initState = makeGettableStateVar$ simpleGet i2b glut_INIT_STATE diff --git a/Graphics/UI/GLUT/Types.hs b/Graphics/UI/GLUT/Types.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Types.hs +++ /dev/null @@ -1,104 +0,0 @@ --- #hide --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Types --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- This is a purely internal module with miscellaneous types which don\'t really --- have a good place elsewhere. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Types ( - Window(..), -- constructor used only internally - Relation(..), - relationToString, -- used only internally - MouseButton(..), - marshalMouseButton, unmarshalMouseButton -- used only internally -) where - -import Foreign.C.Types -import Graphics.UI.GLUT.Raw - --------------------------------------------------------------------------------- - --- | An opaque identifier for a top-level window or a subwindow. - -newtype Window = Window CInt - deriving ( Eq, Ord, Show ) - --------------------------------------------------------------------------------- - --- | A relation between a 'Graphics.UI.GLUT.Initialization.DisplayCapability' --- and a numeric value. - -data Relation - = IsEqualTo -- ^ Equal. - | IsNotEqualTo -- ^ Not equal. - | IsLessThan -- ^ Less than and preferring larger difference (the least - -- is best). - | IsNotGreaterThan -- ^ Less than or equal and preferring larger difference - -- (the least is best). - | IsGreaterThan -- ^ Greater than and preferring larger differences (the - -- most is best). - | IsAtLeast -- ^ Greater than or equal and preferring more instead of - -- less. This relation is useful for allocating - -- resources like color precision or depth buffer - -- precision where the maximum precision is generally - -- preferred. Contrast with 'IsNotLessThan' relation. - | IsNotLessThan -- ^ Greater than or equal but preferring less instead of - -- more. This relation is useful for allocating - -- resources such as stencil bits or auxillary color - -- buffers where you would rather not over-allocate. - deriving ( Eq, Ord, Show ) - -relationToString :: Relation -> String -relationToString IsEqualTo = "=" -relationToString IsNotEqualTo = "!=" -relationToString IsLessThan = "<" -relationToString IsNotGreaterThan = "<=" -relationToString IsGreaterThan = ">" -relationToString IsAtLeast = ">=" -relationToString IsNotLessThan = "~" - --------------------------------------------------------------------------------- - --- | Mouse buttons, including a wheel - -data MouseButton - = LeftButton - | MiddleButton - | RightButton - | WheelUp - | WheelDown - | AdditionalButton Int - deriving ( Eq, Ord, Show ) - -marshalMouseButton :: MouseButton -> CInt -marshalMouseButton x = case x of - LeftButton -> glut_LEFT_BUTTON - MiddleButton -> glut_MIDDLE_BUTTON - RightButton -> glut_RIGHT_BUTTON - WheelUp -> glut_WHEEL_UP - WheelDown -> glut_WHEEL_DOWN - AdditionalButton b -> fromIntegral b - -unmarshalMouseButton :: CInt -> MouseButton -unmarshalMouseButton x - | x == glut_LEFT_BUTTON = LeftButton - | x == glut_MIDDLE_BUTTON = MiddleButton - | x == glut_RIGHT_BUTTON = RightButton - | x == glut_WHEEL_UP = WheelUp - | x == glut_WHEEL_DOWN = WheelDown - | otherwise = AdditionalButton (fromIntegral x) - -glut_WHEEL_UP :: CInt -glut_WHEEL_UP = 3 - -glut_WHEEL_DOWN :: CInt -glut_WHEEL_DOWN = 4 diff --git a/Graphics/UI/GLUT/Window.hs b/Graphics/UI/GLUT/Window.hs deleted file mode 100644 --- a/Graphics/UI/GLUT/Window.hs +++ /dev/null @@ -1,492 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Graphics.UI.GLUT.Window --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/GLUT/LICENSE) --- --- Maintainer : sven.panne@aedion.de --- Stability : stable --- Portability : portable --- --- GLUT supports two types of windows: top-level windows and subwindows. Both --- types support OpenGL rendering and GLUT callbacks. There is a single --- identifier space for both types of windows. --- --------------------------------------------------------------------------------- - -module Graphics.UI.GLUT.Window ( - -- * Window identifiers - Window, - - -- * Creating and destroying (sub-)windows - - -- $CreatingAndDestroyingSubWindows - createWindow, createSubWindow, destroyWindow, - parentWindow, numSubWindows, - - -- * Manipulating the /current window/ - currentWindow, - - -- * Re-displaying and double buffer management - postRedisplay, swapBuffers, - - -- * Changing the window geometry - - -- $ChangingTheWindowGeometry - windowPosition, windowSize, fullScreen, fullScreenToggle, - - -- * Manipulating the stacking order - - -- $ManipulatingTheStackingOrder - pushWindow, popWindow, - - -- * Managing a window\'s display status - WindowStatus(..), windowStatus, - - -- * Changing the window\/icon title - - -- $ChangingTheWindowIconTitle - windowTitle, iconTitle, - - -- * Cursor management - Cursor(..), cursor, pointerPosition -) where - -import Data.StateVar -import Foreign.C.String -import Foreign.C.Types -import Graphics.Rendering.OpenGL ( Position(..), Size(..) ) -import Graphics.UI.GLUT.QueryUtils -import Graphics.UI.GLUT.Raw -import Graphics.UI.GLUT.Types - --------------------------------------------------------------------------------- - --- $CreatingAndDestroyingSubWindows --- Each created window has a unique associated OpenGL context. State changes to --- a window\'s associated OpenGL context can be done immediately after the --- window is created. --- --- The /display state/ of a window is initially for the window to be shown. But --- the window\'s /display state/ is not actually acted upon until --- 'Graphics.UI.GLUT.Begin.mainLoop' is entered. This means until --- 'Graphics.UI.GLUT.Begin.mainLoop' is called, rendering to a created window is --- ineffective because the window can not yet be displayed. --- --- The value returned by 'createWindow' and 'createSubWindow' is a unique --- identifier for the window, which can be used with 'currentWindow'. - --- | Create a top-level window. The given name will be provided to the window --- system as the window\'s name. The intent is that the window system will label --- the window with the name.Implicitly, the /current window/ is set to the newly --- created window. --- --- /X Implementation Notes:/ The proper X Inter-Client Communication Conventions --- Manual (ICCCM) top-level properties are established. The @WM_COMMAND@ --- property that lists the command line used to invoke the GLUT program is only --- established for the first window created. - -createWindow - :: String -- ^ The window name - -> IO Window -- ^ The identifier for the newly created window -createWindow name = fmap Window $ withCString name glutCreateWindow - --------------------------------------------------------------------------------- - --- | Create a subwindow of the identified window with the given relative --- position and size. Implicitly, the /current window/ is set to the --- newly created subwindow. Subwindows can be nested arbitrarily deep. - -createSubWindow - :: Window -- ^ Identifier of the subwindow\'s parent window. - -> Position -- ^ Window position in pixels relative to parent window\'s - -- origin. - -> Size -- ^ Window size in pixels - -> IO Window -- ^ The identifier for the newly created subwindow -createSubWindow (Window win) (Position x y) (Size w h) = - fmap Window $ - glutCreateSubWindow win - (fromIntegral x) (fromIntegral y) - (fromIntegral w) (fromIntegral h) - --------------------------------------------------------------------------------- - --- | Contains the /current window\'s/ parent. If the /current window/ is a --- top-level window, 'Nothing' is returned. - -parentWindow :: GettableStateVar (Maybe Window) -parentWindow = - makeGettableStateVar $ - getWindow (simpleGet Window glut_WINDOW_PARENT) - --------------------------------------------------------------------------------- - --- | Contains the number of subwindows the /current window/ has, not counting --- children of children. - -numSubWindows :: GettableStateVar Int -numSubWindows = - makeGettableStateVar $ - simpleGet fromIntegral glut_WINDOW_NUM_CHILDREN - --------------------------------------------------------------------------------- - --- | Destroy the specified window and the window\'s associated OpenGL context, --- logical colormap (if the window is color index), and overlay and related --- state (if an overlay has been established). Any subwindows of the destroyed --- window are also destroyed by 'destroyWindow'. If the specified window was the --- /current window/, the /current window/ becomes invalid ('currentWindow' will --- contain 'Nothing'). - -destroyWindow :: Window -> IO () -destroyWindow (Window win) = glutDestroyWindow win - --------------------------------------------------------------------------------- - --- | Controls the /current window/. It does /not/ affect the /layer in use/ for --- the window; this is done using 'Graphics.UI.GLUT.Overlay.layerInUse'. --- Contains 'Nothing' if no windows exist or the previously /current window/ was --- destroyed. Setting the /current window/ to 'Nothing' is a no-op. - -currentWindow :: StateVar (Maybe Window) -currentWindow = - makeStateVar - (getWindow (fmap Window glutGetWindow)) - (maybe (return ()) (\(Window win) -> glutSetWindow win)) - -getWindow :: IO Window -> IO (Maybe Window) -getWindow act = do - win <- act - return $ if win == Window 0 then Nothing else Just win - --------------------------------------------------------------------------------- - --- | Mark the normal plane of given window (or the /current window/, if none --- is supplied) as needing to be redisplayed. The next iteration through --- 'Graphics.UI.GLUT.Begin.mainLoop', the window\'s display callback will be --- called to redisplay the window\'s normal plane. Multiple calls to --- 'postRedisplay' before the next display callback opportunity generates only a --- single redisplay callback. 'postRedisplay' may be called within a window\'s --- display or overlay display callback to re-mark that window for redisplay. --- --- Logically, normal plane damage notification for a window is treated as a --- 'postRedisplay' on the damaged window. Unlike damage reported by the window --- system, 'postRedisplay' will /not/ set to true the normal plane\'s damaged --- status (see 'Graphics.UI.GLUT.State.damaged'). --- --- Also, see 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay'. - -postRedisplay :: Maybe Window -> IO () -postRedisplay = maybe glutPostRedisplay (\(Window win) -> glutPostWindowRedisplay win) - --- | Mark the normal plane of the given window as needing to be redisplayed, --- otherwise the same as 'postRedisplay'. --- --- The advantage of this routine is that it saves the cost of using --- 'currentWindow' (entailing an expensive OpenGL context switch), which is --- particularly useful when multiple windows need redisplays posted at the same --- time. - --------------------------------------------------------------------------------- - --- | Perform a buffer swap on the /layer in use/ for the /current window/. --- Specifically, 'swapBuffers' promotes the contents of the back buffer of the --- /layer in use/ of the /current window/ to become the contents of the front --- buffer. The contents of the back buffer then become undefined. The update --- typically takes place during the vertical retrace of the monitor, rather than --- immediately after 'swapBuffers' is called. --- --- An implicit 'Graphics.Rendering.OpenGL.GL.FlushFinish.flush' is done by --- 'swapBuffers' before it returns. Subsequent OpenGL commands can be issued --- immediately after calling 'swapBuffers', but are not executed until the --- buffer exchange is completed. --- --- If the /layer in use/ is not double buffered, 'swapBuffers' has no effect. - -swapBuffers :: IO () -swapBuffers = glutSwapBuffers - --------------------------------------------------------------------------------- - --- $ChangingTheWindowGeometry --- Note that the requests by 'windowPosition', 'windowSize', and 'fullScreen' --- are not processed immediately. A request is executed after returning to the --- main event loop. This allows multiple requests to the same window to be --- coalesced. --- --- 'windowPosition' and 'windowSize' requests on a window will disable the full --- screen status of the window. - --------------------------------------------------------------------------------- - --- | Controls the position of the /current window/. For top-level windows, --- parameters of 'Position' are pixel offsets from the screen origin. For --- subwindows, the parameters are pixel offsets from the window\'s parent window --- origin. --- --- In the case of top-level windows, setting 'windowPosition' is considered only --- a request for positioning the window. The window system is free to apply its --- own policies to top-level window placement. The intent is that top-level --- windows should be repositioned according to the value of 'windowPosition'. - -windowPosition :: StateVar Position -windowPosition = makeStateVar getWindowPosition setWindowPosition - -setWindowPosition :: Position -> IO () -setWindowPosition (Position x y) = - glutPositionWindow (fromIntegral x) (fromIntegral y) - -getWindowPosition :: IO Position -getWindowPosition = do - x <- simpleGet fromIntegral glut_WINDOW_X - y <- simpleGet fromIntegral glut_WINDOW_Y - return $ Position x y - --------------------------------------------------------------------------------- - --- | Controls the size of the /current window/. The parameters of 'Size' are --- size extents in pixels. The width and height must be positive values. --- --- In the case of top-level windows, setting 'windowSize' is considered only a --- request for sizing the window. The window system is free to apply its own --- policies to top-level window sizing. The intent is that top-level windows --- should be reshaped according to the value of 'windowSize'. Whether a reshape --- actually takes effect and, if so, the reshaped dimensions are reported to the --- program by a reshape callback. - -windowSize :: StateVar Size -windowSize = makeStateVar getWindowSize setWindowSize - -setWindowSize :: Size -> IO () -setWindowSize (Size w h) = - glutReshapeWindow (fromIntegral w) (fromIntegral h) - -getWindowSize :: IO Size -getWindowSize = do - w <- simpleGet fromIntegral glut_WINDOW_WIDTH - h <- simpleGet fromIntegral glut_WINDOW_HEIGHT - return $ Size w h - --------------------------------------------------------------------------------- - --- | Request that the /current window/ be made full screen. The exact semantics --- of what full screen means may vary by window system. The intent is to make --- the window as large as possible and disable any window decorations or borders --- added the window system. The window width and height are not guaranteed to be --- the same as the screen width and height, but that is the intent of making a --- window full screen. --- --- 'fullScreen' is defined to work only on top-level windows. --- --- /X Implementation Notes:/ In the X implementation of GLUT, full screen is --- implemented by sizing and positioning the window to cover the entire screen --- and posting the @_MOTIF_WM_HINTS@ property on the window requesting --- absolutely no decorations. Non-Motif window managers may not respond to --- @_MOTIF_WM_HINTS@. - -fullScreen :: IO () -fullScreen = glutFullScreen - --------------------------------------------------------------------------------- - --- | (/freeglut only/) Toggle between windowed and full screen mode. - -fullScreenToggle :: IO () -fullScreenToggle = glutFullScreenToggle - --------------------------------------------------------------------------------- - --- $ManipulatingTheStackingOrder --- 'pushWindow' and 'popWindow' work on both top-level windows and subwindows. --- The effect of pushing and popping windows does not take place immediately. --- Instead the push or pop is saved for execution upon return to the GLUT event --- loop. Subsequent pop or push requests on a window replace the previously --- saved request for that window. The effect of pushing and popping top-level --- windows is subject to the window system\'s policy for restacking windows. - --- | Change the stacking order of the /current window/ relative to its siblings --- (lowering it). - -pushWindow :: IO () -pushWindow = glutPushWindow - --- | Change the stacking order of the /current window/ relative to its siblings, --- bringing the /current window/ closer to the top. - -popWindow :: IO () -popWindow = glutPopWindow - --------------------------------------------------------------------------------- - --- | The display status of a window. - -data WindowStatus - = Shown - | Hidden - | Iconified - deriving ( Eq, Ord, Show ) - --- | Controls the display status of the /current window/. --- --- Note that the effect of showing, hiding, and iconifying windows does not take --- place immediately. Instead the requests are saved for execution upon return --- to the GLUT event loop. Subsequent show, hide, or iconification requests on a --- window replace the previously saved request for that window. The effect of --- hiding, showing, or iconifying top-level windows is subject to the window --- system\'s policy for displaying windows. Subwindows can\'t be iconified. - -windowStatus :: SettableStateVar WindowStatus -windowStatus = makeSettableStateVar setStatus - where setStatus Shown = glutShowWindow - setStatus Hidden = glutHideWindow - setStatus Iconified = glutIconifyWindow - --------------------------------------------------------------------------------- - --- $ChangingTheWindowIconTitle --- 'windowTitle' and 'iconTitle' should be set only when the /current --- window/ is a top-level window. Upon creation of a top-level window, the --- window and icon names are determined by the name given to 'createWindow'. --- Once created, setting 'windowTitle' and 'iconTitle' can change the window and --- icon names respectively of top-level windows. Each call requests the window --- system change the title appropriately. Requests are not buffered or --- coalesced. The policy by which the window and icon name are displayed is --- window system dependent. - --- | Controls the window title of the /current top-level window/. - -windowTitle :: SettableStateVar String -windowTitle = - makeSettableStateVar $ \name -> - withCString name glutSetWindowTitle - --- | Controls the icon title of the /current top-level window/. - -iconTitle :: SettableStateVar String -iconTitle = - makeSettableStateVar $ \name -> - withCString name glutSetIconTitle - --------------------------------------------------------------------------------- - --- | The different cursor images GLUT supports. - -data Cursor - = RightArrow -- ^ Arrow pointing up and to the right. - | LeftArrow -- ^ Arrow pointing up and to the left. - | Info -- ^ Pointing hand. - | Destroy -- ^ Skull & cross bones. - | Help -- ^ Question mark. - | Cycle -- ^ Arrows rotating in a circle. - | Spray -- ^ Spray can. - | Wait -- ^ Wrist watch. - | Text -- ^ Insertion point cursor for text. - | Crosshair -- ^ Simple cross-hair. - | UpDown -- ^ Bi-directional pointing up & down. - | LeftRight -- ^ Bi-directional pointing left & right. - | TopSide -- ^ Arrow pointing to top side. - | BottomSide -- ^ Arrow pointing to bottom side. - | LeftSide -- ^ Arrow pointing to left side. - | RightSide -- ^ Arrow pointing to right side. - | TopLeftCorner -- ^ Arrow pointing to top-left corner. - | TopRightCorner -- ^ Arrow pointing to top-right corner. - | BottomRightCorner -- ^ Arrow pointing to bottom-left corner. - | BottomLeftCorner -- ^ Arrow pointing to bottom-right corner. - | Inherit -- ^ Use parent\'s cursor. - | None -- ^ Invisible cursor. - | FullCrosshair -- ^ Full-screen cross-hair cursor (if possible, otherwise 'Crosshair'). - deriving ( Eq, Ord, Show ) - -marshalCursor :: Cursor -> CInt -marshalCursor x = case x of - RightArrow -> glut_CURSOR_RIGHT_ARROW - LeftArrow -> glut_CURSOR_LEFT_ARROW - Info -> glut_CURSOR_INFO - Destroy -> glut_CURSOR_DESTROY - Help -> glut_CURSOR_HELP - Cycle -> glut_CURSOR_CYCLE - Spray -> glut_CURSOR_SPRAY - Wait -> glut_CURSOR_WAIT - Text -> glut_CURSOR_TEXT - Crosshair -> glut_CURSOR_CROSSHAIR - UpDown -> glut_CURSOR_UP_DOWN - LeftRight -> glut_CURSOR_LEFT_RIGHT - TopSide -> glut_CURSOR_TOP_SIDE - BottomSide -> glut_CURSOR_BOTTOM_SIDE - LeftSide -> glut_CURSOR_LEFT_SIDE - RightSide -> glut_CURSOR_RIGHT_SIDE - TopLeftCorner -> glut_CURSOR_TOP_LEFT_CORNER - TopRightCorner -> glut_CURSOR_TOP_RIGHT_CORNER - BottomRightCorner -> glut_CURSOR_BOTTOM_RIGHT_CORNER - BottomLeftCorner -> glut_CURSOR_BOTTOM_LEFT_CORNER - Inherit -> glut_CURSOR_INHERIT - None -> glut_CURSOR_NONE - FullCrosshair -> glut_CURSOR_FULL_CROSSHAIR - -unmarshalCursor :: CInt -> Cursor -unmarshalCursor x - | x == glut_CURSOR_RIGHT_ARROW = RightArrow - | x == glut_CURSOR_LEFT_ARROW = LeftArrow - | x == glut_CURSOR_INFO = Info - | x == glut_CURSOR_DESTROY = Destroy - | x == glut_CURSOR_HELP = Help - | x == glut_CURSOR_CYCLE = Cycle - | x == glut_CURSOR_SPRAY = Spray - | x == glut_CURSOR_WAIT = Wait - | x == glut_CURSOR_TEXT = Text - | x == glut_CURSOR_CROSSHAIR = Crosshair - | x == glut_CURSOR_UP_DOWN = UpDown - | x == glut_CURSOR_LEFT_RIGHT = LeftRight - | x == glut_CURSOR_TOP_SIDE = TopSide - | x == glut_CURSOR_BOTTOM_SIDE = BottomSide - | x == glut_CURSOR_LEFT_SIDE = LeftSide - | x == glut_CURSOR_RIGHT_SIDE = RightSide - | x == glut_CURSOR_TOP_LEFT_CORNER = TopLeftCorner - | x == glut_CURSOR_TOP_RIGHT_CORNER = TopRightCorner - | x == glut_CURSOR_BOTTOM_RIGHT_CORNER = BottomRightCorner - | x == glut_CURSOR_BOTTOM_LEFT_CORNER = BottomLeftCorner - | x == glut_CURSOR_INHERIT = Inherit - | x == glut_CURSOR_NONE = None - | x == glut_CURSOR_FULL_CROSSHAIR = FullCrosshair - | otherwise = error ("unmarshalCursor: illegal value " ++ show x) - --------------------------------------------------------------------------------- - --- | Change the cursor image of the /current window/. Each call requests the --- window system change the cursor appropriately. The cursor image when a window --- is created is 'Inherit'. The exact cursor images used are implementation --- dependent. The intent is for the image to convey the meaning of the cursor --- name. For a top-level window, 'Inherit' uses the default window system --- cursor. --- --- /X Implementation Notes:/ GLUT for X uses SGI\'s @_SGI_CROSSHAIR_CURSOR@ --- convention to access a full-screen cross-hair cursor if possible. - -cursor :: StateVar Cursor -cursor = makeStateVar getCursor setCursor - -setCursor :: Cursor -> IO () -setCursor = glutSetCursor . marshalCursor - -getCursor :: IO Cursor -getCursor = simpleGet unmarshalCursor glut_WINDOW_CURSOR - --------------------------------------------------------------------------------- - --- | Setting 'pointerPosition' warps the window system\'s pointer to a new --- location relative to the origin of the /current window/ by the specified --- pixel offset, which may be negative. The warp is done immediately. --- --- If the pointer would be warped outside the screen\'s frame buffer region, the --- location will be clamped to the nearest screen edge. The window system is --- allowed to further constrain the pointer\'s location in window system --- dependent ways. --- --- Good advice from Xlib\'s @XWarpPointer@ man page: \"There is seldom any --- reason for calling this function. The pointer should normally be left to the --- user.\" - -pointerPosition :: SettableStateVar Position -pointerPosition = - makeSettableStateVar $ \(Position x y) -> - glutWarpPointer (fromIntegral x) (fromIntegral y) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2002-2005, Sven Panne +Copyright (c) 2002-2018, Sven Panne All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,4 +0,0 @@ -To build this package using Cabal directly from darcs, you must run -"autoreconf" before the usual Cabal build steps (configure/build/install). -autoreconf is included in the GNU autoconf tools. There is no need to run -the "configure" script: the "setup configure" step will do this for you. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +[![Hackage](https://img.shields.io/hackage/v/GLUT.svg)](https://hackage.haskell.org/package/GLUT) +[![Stackage LTS](https://www.stackage.org/package/GLUT/badge/lts)](https://www.stackage.org/lts/package/GLUT) +[![Stackage nightly](https://www.stackage.org/package/GLUT/badge/nightly)](https://www.stackage.org/nightly/package/GLUT) +[![Build Status](https://img.shields.io/travis/haskell-opengl/GLUT/master.svg)](https://travis-ci.org/haskell-opengl/GLUT) diff --git a/cbits/HsGLUT.c b/cbits/HsGLUT.c --- a/cbits/HsGLUT.c +++ b/cbits/HsGLUT.c @@ -1,82 +1,30 @@ /* ----------------------------------------------------------------------------- * * Module : C support for Graphics.UI.GLUT.Raw - * Copyright : (c) Sven Panne 2002-2009 - * License : BSD-style (see the file LICENSE) + * Copyright : (c) Sven Panne 2002-2018 + * License : BSD3 * - * Maintainer : sven.panne@aedion.de - * Stability : provisional + * Maintainer : Sven Panne + * Stability : stable * Portability : portable * * -------------------------------------------------------------------------- */ -#if defined(_MSC_VER) || defined(__CYGWIN__) || defined(__MINGW32__) || defined(__WATCOMC__) - -#define GLUT_STROKE_ROMAN ((void *)0x0000) -#define GLUT_STROKE_MONO_ROMAN ((void *)0x0001) -#define GLUT_BITMAP_9_BY_15 ((void *)0x0002) -#define GLUT_BITMAP_8_BY_13 ((void *)0x0003) -#define GLUT_BITMAP_TIMES_ROMAN_10 ((void *)0x0004) -#define GLUT_BITMAP_TIMES_ROMAN_24 ((void *)0x0005) -#define GLUT_BITMAP_HELVETICA_10 ((void *)0x0006) -#define GLUT_BITMAP_HELVETICA_12 ((void *)0x0007) -#define GLUT_BITMAP_HELVETICA_18 ((void *)0x0008) - -#else - -extern void* glutStrokeRoman; -extern void* glutStrokeMonoRoman; -extern void* glutBitmap9By15; -extern void* glutBitmap8By13; -extern void* glutBitmapTimesRoman10; -extern void* glutBitmapTimesRoman24; -extern void* glutBitmapHelvetica10; -extern void* glutBitmapHelvetica12; -extern void* glutBitmapHelvetica18; - -#define GLUT_STROKE_ROMAN ((void *)&glutStrokeRoman) -#define GLUT_STROKE_MONO_ROMAN ((void *)&glutStrokeMonoRoman) -#define GLUT_BITMAP_9_BY_15 ((void *)&glutBitmap9By15) -#define GLUT_BITMAP_8_BY_13 ((void *)&glutBitmap8By13) -#define GLUT_BITMAP_TIMES_ROMAN_10 ((void *)&glutBitmapTimesRoman10) -#define GLUT_BITMAP_TIMES_ROMAN_24 ((void *)&glutBitmapTimesRoman24) -#define GLUT_BITMAP_HELVETICA_10 ((void *)&glutBitmapHelvetica10) -#define GLUT_BITMAP_HELVETICA_12 ((void *)&glutBitmapHelvetica12) -#define GLUT_BITMAP_HELVETICA_18 ((void *)&glutBitmapHelvetica18) - -#endif - -void* -hs_GLUT_marshalBitmapFont(int fontID) -{ - switch (fontID) { - case 0 : return GLUT_BITMAP_8_BY_13; - case 1 : return GLUT_BITMAP_9_BY_15; - case 2 : return GLUT_BITMAP_TIMES_ROMAN_10; - case 3 : return GLUT_BITMAP_TIMES_ROMAN_24; - case 4 : return GLUT_BITMAP_HELVETICA_10; - case 5 : return GLUT_BITMAP_HELVETICA_12; - case 6 : return GLUT_BITMAP_HELVETICA_18; - } - return (void*)0; -} - -void* -hs_GLUT_marshalStrokeFont(int fontID) -{ - switch (fontID) { - case 0 : return GLUT_STROKE_ROMAN; - case 1 : return GLUT_STROKE_MONO_ROMAN; - } - return (void*)0; -} - -/* -------------------------------------------------------------------------- */ #if defined(USE_GETPROCADDRESS) #define WIN32_LEAN_AND_MEAN #include +static LPCTSTR libNames[] = { + /* Try to load freeglut first, it has a few extra features compared to classic + GLUT. */ + TEXT("freeglut"), + /* The MinGW-w64 version of freeglut prefixes "lib" onto the DLL name. */ + TEXT("libfreeglut"), + /* If no freeglut version is found, try plain old glut32 instead. */ + TEXT("glut32") +}; + void* hs_GLUT_getProcAddress(const char *name) { @@ -84,71 +32,122 @@ static HMODULE handle = NULL; if (firstTime) { + int i, numNames = (int)(sizeof(libNames) / sizeof(libNames[0])); firstTime = 0; - handle = LoadLibrary(TEXT("glut32")); + for (i = 0; (!handle) && (i < numNames); ++i) { + handle = LoadLibrary(libNames[i]); + } } return handle ? GetProcAddress(handle, name) : NULL; } /* -------------------------------------------------------------------------- */ -#elif defined(USE_NSADDRESSOFSYMBOL) +#elif defined(USE_DLSYM) -#include #include -#include +#include +static const char* libNames[] = { +#ifdef __APPLE__ + /* Try to use freeglut, checking the LD_LIBRARY_PATH */ + "libglut.dylib", + /* Try public framework path first. */ + "/Library/Frameworks/GLUT.framework/GLUT", + /* If the public path failed, try the system framework path. */ + "/System/Library/Frameworks/GLUT.framework/GLUT" +#else + "libglut.so", "libglut.so.3" +#endif +}; + void* hs_GLUT_getProcAddress(const char *name) { - NSSymbol symbol; + static int firstTime = 1; + static void *handle = NULL; - /* Prepend a '_' for the Unix C symbol mangling convention */ - char* symbolName = (char*)malloc(strlen(name) + 2); - if (!symbolName) { - return NULL; + if (firstTime) { + int i, numNames = (int)(sizeof(libNames) / sizeof(libNames[0])); + firstTime = 0; + for (i = 0; (!handle) && (i < numNames); ++i) { + handle = dlopen(libNames[i], RTLD_LAZY | RTLD_GLOBAL); + } } - symbolName[0] = '_'; - strcpy(symbolName + 1, name); - if (!NSIsSymbolNameDefined(symbolName)) { - free(symbolName); - return NULL; - } + return handle ? dlsym(handle, name) : NULL; +} - symbol = NSLookupAndBindSymbol(symbolName); - free(symbolName); - if (!symbol) { - return NULL; - } +/* -------------------------------------------------------------------------- */ +#else - return NSAddressOfSymbol(symbol); -} +#error "Don't know how to retrieve GLUT entries" +#endif + /* -------------------------------------------------------------------------- */ -#elif defined(USE_DLSYM) -#include -#include +/* Note: This #if below is in sync with freeglut_std.h, classic GLUT simply used + #if defined(_WIN32). */ +#if defined(_MSC_VER) || defined(__CYGWIN__) || defined(__MINGW32__) || defined(__WATCOMC__) +#define INIT_FONT(name,num) hs_##name = ((void*)(num)) +#else +#define INIT_FONT(name,num) hs_##name = hs_GLUT_getProcAddress(#name) +#endif void* -hs_GLUT_getProcAddress(const char *name) +hs_GLUT_marshalBitmapFont(int fontID) { static int firstTime = 1; - static void *handle = NULL; + static void *hs_glutBitmap9By15 = NULL; + static void *hs_glutBitmap8By13 = NULL; + static void *hs_glutBitmapTimesRoman10 = NULL; + static void *hs_glutBitmapTimesRoman24 = NULL; + static void *hs_glutBitmapHelvetica10 = NULL; + static void *hs_glutBitmapHelvetica12 = NULL; + static void *hs_glutBitmapHelvetica18 = NULL; if (firstTime) { firstTime = 0; - /* Get a handle for our executable. */ - handle = dlopen(NULL, RTLD_LAZY); + + INIT_FONT(glutBitmap9By15, 0x0002); + INIT_FONT(glutBitmap8By13, 0x0003); + INIT_FONT(glutBitmapTimesRoman10, 0x0004); + INIT_FONT(glutBitmapTimesRoman24, 0x0005); + INIT_FONT(glutBitmapHelvetica10, 0x0006); + INIT_FONT(glutBitmapHelvetica12, 0x0007); + INIT_FONT(glutBitmapHelvetica18, 0x0008); } - return handle ? dlsym(handle, name) : NULL; + switch (fontID) { + case 0 : return hs_glutBitmap8By13; + case 1 : return hs_glutBitmap9By15; + case 2 : return hs_glutBitmapTimesRoman10; + case 3 : return hs_glutBitmapTimesRoman24; + case 4 : return hs_glutBitmapHelvetica10; + case 5 : return hs_glutBitmapHelvetica12; + case 6 : return hs_glutBitmapHelvetica18; + } + return (void*)0; } -/* -------------------------------------------------------------------------- */ -#else +void* +hs_GLUT_marshalStrokeFont(int fontID) +{ + static int firstTime = 1; + static void *hs_glutStrokeRoman = NULL; + static void *hs_glutStrokeMonoRoman = NULL; -#error "Don't know how to retrieve GLUT entries" + if (firstTime) { + firstTime = 0; -#endif + INIT_FONT(glutStrokeRoman, 0x0000); + INIT_FONT(glutStrokeMonoRoman, 0x0001); + } + + switch (fontID) { + case 0 : return hs_glutStrokeRoman; + case 1 : return hs_glutStrokeMonoRoman; + } + return (void*)0; +} diff --git a/examples/00-README b/examples/00-README new file mode 100644 --- /dev/null +++ b/examples/00-README @@ -0,0 +1,24 @@ +This directory contains OpenGL example programs from various sources: + + * BOGLP: Contains some examples from the book "Beginning OpenGL Game + Programming", 2nd ed., by Benstead/Astle/Hawkins. + + * Misc: Contains a few random examples from e.g. the Mesa sources. + + * OrangeBook: Contains an example from the book "OpenGL Shading Language", + 3rd ed, by Rost/Licea-Kane/Ginsburg/Kessenich/Lichtenbelt/Malan/Weiblen. + + * RedBook4: Contains all examples from the book "OpenGL Programming Guide: + The Official Guide to Learning OpenGL, Version 1.4", 4th ed., by + Shreiner/Woo/Neider/Davis. + + * RedBook8: Contains various examples from the book "OpenGL Programming + Guide: The Official Guide to Learning OpenGL, Version 4.3", 8th ed., by + Shreiner/Sellers/Kessenich/Licea-Kane. + +If you have 'make' and 'ghc' installed, you can just issue 'make' at any +directory level to compile the examples. 'make clean' cleans up afterwards, and +you can use '-j [N]' for parallel builds. Directly loading the examples into +e.g. ghci is possible, too, just ':load' an example and run it via 'main'. For +some examples, you might have to extend the search path like '-i../common', see +the corresponding Makefile. diff --git a/examples/BOGLGP/00-README b/examples/BOGLGP/00-README new file mode 100644 --- /dev/null +++ b/examples/BOGLGP/00-README @@ -0,0 +1,2 @@ +This directory contains some examples from the book "Beginning OpenGL Game +Programming", 2nd ed., by Benstead/Astle/Hawkins. diff --git a/examples/BOGLGP/Chapter01/OnYourOwn1.hs b/examples/BOGLGP/Chapter01/OnYourOwn1.hs --- a/examples/BOGLGP/Chapter01/OnYourOwn1.hs +++ b/examples/BOGLGP/Chapter01/OnYourOwn1.hs @@ -1,6 +1,6 @@ {- OnYourOwn1.hs (adapted from Simple.cpp which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2004-2005 + Copyright (c) Sven Panne 2004-2018 This file is part of HOpenGL and distributed under a BSD-style license See the file libraries/GLUT/LICENSE -} @@ -15,13 +15,13 @@ main :: IO () main = do -- Setup the basic GLUT stuff - getArgsAndInitialize + _ <- getArgsAndInitialize initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] -- Create the window initialWindowSize $= Size 1024 768 initialWindowPosition $= Position 100 150 - createWindow "BOGLGP - Chapter 1 - On Your Own 1" + _ <- createWindow "BOGLGP - Chapter 1 - On Your Own 1" initialize diff --git a/examples/BOGLGP/Chapter01/Simple.hs b/examples/BOGLGP/Chapter01/Simple.hs --- a/examples/BOGLGP/Chapter01/Simple.hs +++ b/examples/BOGLGP/Chapter01/Simple.hs @@ -1,6 +1,6 @@ {- Simple.hs (adapted from Simple.cpp which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2004-2005 + Copyright (c) Sven Panne 2004-2018 This file is part of HOpenGL and distributed under a BSD-style license See the file libraries/GLUT/LICENSE -} @@ -15,13 +15,13 @@ main :: IO () main = do -- Setup the basic GLUT stuff - getArgsAndInitialize + _ <- getArgsAndInitialize initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] -- Create the window initialWindowSize $= Size 1024 768 initialWindowPosition $= Position 100 150 - createWindow "BOGLGP - Chapter 1 - Simple" + _ <- createWindow "BOGLGP - Chapter 1 - Simple" initialize diff --git a/examples/BOGLGP/Chapter02/OnYourOwn1.hs b/examples/BOGLGP/Chapter02/OnYourOwn1.hs --- a/examples/BOGLGP/Chapter02/OnYourOwn1.hs +++ b/examples/BOGLGP/Chapter02/OnYourOwn1.hs @@ -1,6 +1,6 @@ {- OnYourOwn1.hs (adapted from OpenGLApplication which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2004-2005 + Copyright (c) Sven Panne 2004-2018 This file is part of HOpenGL and distributed under a BSD-style license See the file libraries/GLUT/LICENSE -} @@ -45,7 +45,7 @@ addCapability GameModeHeight (Just (windowHeight opts)) . addCapability GameModeBitsPerPlane (bpp opts) . addCapability GameModeRefreshRate (refreshRate opts)) [] - enterGameMode + _ <- enterGameMode maybeWin <- get currentWindow if isJust maybeWin then cursor $= None @@ -57,7 +57,7 @@ windowedMode opts = do initialWindowSize $= Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) - createWindow "BOGLGP - Chapter 2 - On Your Own 1" + _ <- createWindow "BOGLGP - Chapter 2 - On Your Own 1" return () -------------------------------------------------------------------------------- diff --git a/examples/BOGLGP/Chapter02/OpenGLApplication.hs b/examples/BOGLGP/Chapter02/OpenGLApplication.hs --- a/examples/BOGLGP/Chapter02/OpenGLApplication.hs +++ b/examples/BOGLGP/Chapter02/OpenGLApplication.hs @@ -1,6 +1,6 @@ {- OpenGLApplication.hs (adapted from OpenGLApplication which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2004-2005 + Copyright (c) Sven Panne 2004-2018 This file is part of HOpenGL and distributed under a BSD-style license See the file libraries/GLUT/LICENSE -} @@ -45,7 +45,7 @@ addCapability GameModeHeight (Just (windowHeight opts)) . addCapability GameModeBitsPerPlane (bpp opts) . addCapability GameModeRefreshRate (refreshRate opts)) [] - enterGameMode + _ <- enterGameMode maybeWin <- get currentWindow if isJust maybeWin then cursor $= None @@ -57,7 +57,7 @@ windowedMode opts = do initialWindowSize $= Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) - createWindow "BOGLGP - Chapter 2 - OpenGL Application" + _ <- createWindow "BOGLGP - Chapter 2 - OpenGL Application" return () -------------------------------------------------------------------------------- diff --git a/examples/BOGLGP/Chapter03/Lines.hs b/examples/BOGLGP/Chapter03/Lines.hs --- a/examples/BOGLGP/Chapter03/Lines.hs +++ b/examples/BOGLGP/Chapter03/Lines.hs @@ -1,6 +1,6 @@ {- Lines.hs (adapted from Lines which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2004-2005 + Copyright (c) Sven Panne 2004-2018 This file is part of HOpenGL and distributed under a BSD-style license See the file libraries/GLUT/LICENSE -} @@ -45,7 +45,7 @@ addCapability GameModeHeight (Just (windowHeight opts)) . addCapability GameModeBitsPerPlane (bpp opts) . addCapability GameModeRefreshRate (refreshRate opts)) [] - enterGameMode + _ <- enterGameMode maybeWin <- get currentWindow if isJust maybeWin then cursor $= None @@ -57,7 +57,7 @@ windowedMode opts = do initialWindowSize $= Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) - createWindow "BOGLGP - Chapter 3 - Lines" + _ <- createWindow "BOGLGP - Chapter 3 - Lines" return () -------------------------------------------------------------------------------- diff --git a/examples/BOGLGP/Chapter03/OnYourOwn1.hs b/examples/BOGLGP/Chapter03/OnYourOwn1.hs --- a/examples/BOGLGP/Chapter03/OnYourOwn1.hs +++ b/examples/BOGLGP/Chapter03/OnYourOwn1.hs @@ -1,6 +1,6 @@ {- OnYourOwn1.hs (adapted from OnYourOwn1 which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2005 + Copyright (c) Sven Panne 2018 This file is part of HOpenGL and distributed under a BSD-style license See the file libraries/GLUT/LICENSE -} @@ -45,7 +45,7 @@ addCapability GameModeHeight (Just (windowHeight opts)) . addCapability GameModeBitsPerPlane (bpp opts) . addCapability GameModeRefreshRate (refreshRate opts)) [] - enterGameMode + _ <- enterGameMode maybeWin <- get currentWindow if isJust maybeWin then cursor $= None @@ -57,7 +57,7 @@ windowedMode opts = do initialWindowSize $= Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) - createWindow "BOGLGP - Chapter 3 - On Your Own 1" + _ <- createWindow "BOGLGP - Chapter 3 - On Your Own 1" return () -------------------------------------------------------------------------------- diff --git a/examples/BOGLGP/Chapter03/Points.hs b/examples/BOGLGP/Chapter03/Points.hs --- a/examples/BOGLGP/Chapter03/Points.hs +++ b/examples/BOGLGP/Chapter03/Points.hs @@ -1,6 +1,6 @@ {- Points.hs (adapted from Points which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2004-2005 + Copyright (c) Sven Panne 2004-2018 This file is part of HOpenGL and distributed under a BSD-style license See the file libraries/GLUT/LICENSE -} @@ -45,7 +45,7 @@ addCapability GameModeHeight (Just (windowHeight opts)) . addCapability GameModeBitsPerPlane (bpp opts) . addCapability GameModeRefreshRate (refreshRate opts)) [] - enterGameMode + _ <- enterGameMode maybeWin <- get currentWindow if isJust maybeWin then cursor $= None @@ -57,7 +57,7 @@ windowedMode opts = do initialWindowSize $= Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) - createWindow "BOGLGP - Chapter 3 - Points" + _ <- createWindow "BOGLGP - Chapter 3 - Points" return () -------------------------------------------------------------------------------- diff --git a/examples/BOGLGP/Chapter03/Polygons.hs b/examples/BOGLGP/Chapter03/Polygons.hs --- a/examples/BOGLGP/Chapter03/Polygons.hs +++ b/examples/BOGLGP/Chapter03/Polygons.hs @@ -1,6 +1,6 @@ {- Polygons.hs (adapted from Polygons which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2004-2005 + Copyright (c) Sven Panne 2004-2018 This file is part of HOpenGL and distributed under a BSD-style license See the file libraries/GLUT/LICENSE -} @@ -45,7 +45,7 @@ addCapability GameModeHeight (Just (windowHeight opts)) . addCapability GameModeBitsPerPlane (bpp opts) . addCapability GameModeRefreshRate (refreshRate opts)) [] - enterGameMode + _ <- enterGameMode maybeWin <- get currentWindow if isJust maybeWin then cursor $= None @@ -57,7 +57,7 @@ windowedMode opts = do initialWindowSize $= Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) - createWindow "BOGLGP - Chapter 3 - Polygons" + _ <- createWindow "BOGLGP - Chapter 3 - Polygons" return () -------------------------------------------------------------------------------- diff --git a/examples/BOGLGP/Chapter03/TrianglesQuads.hs b/examples/BOGLGP/Chapter03/TrianglesQuads.hs --- a/examples/BOGLGP/Chapter03/TrianglesQuads.hs +++ b/examples/BOGLGP/Chapter03/TrianglesQuads.hs @@ -1,6 +1,6 @@ {- TrianglesQuads.hs (adapted from TrianglesQuads which is (c) 2004 Astle/Hawkins) - Copyright (c) Sven Panne 2004-2005 + Copyright (c) Sven Panne 2004-2018 This file is part of HOpenGL and distributed under a BSD-style license See the file libraries/GLUT/LICENSE -} @@ -45,7 +45,7 @@ addCapability GameModeHeight (Just (windowHeight opts)) . addCapability GameModeBitsPerPlane (bpp opts) . addCapability GameModeRefreshRate (refreshRate opts)) [] - enterGameMode + _ <- enterGameMode maybeWin <- get currentWindow if isJust maybeWin then cursor $= None @@ -57,7 +57,7 @@ windowedMode opts = do initialWindowSize $= Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts)) - createWindow "BOGLGP - Chapter 3 - TrianglesQuads" + _ <- createWindow "BOGLGP - Chapter 3 - TrianglesQuads" return () -------------------------------------------------------------------------------- @@ -252,7 +252,7 @@ renderPrimitive TriangleFan $ do -- center vertex of fan vertex (Vertex3 0 0 (0 :: GLfloat)) - + -- bottom side for [ 3, 2 .. 0 ] $ \x -> vertex (Vertex3 x 0 3) diff --git a/examples/Misc/00-README b/examples/Misc/00-README new file mode 100644 --- /dev/null +++ b/examples/Misc/00-README @@ -0,0 +1,1 @@ +This directory contains a few random examples from e.g. the Mesa sources. diff --git a/examples/Misc/ARBOcclude.hs b/examples/Misc/ARBOcclude.hs --- a/examples/Misc/ARBOcclude.hs +++ b/examples/Misc/ARBOcclude.hs @@ -1,6 +1,6 @@ {- ARBOcclude.hs (adapted from arbocclude.c which is (c) Brian Paul) - Copyright (c) Sven Panne 2002-2005 + Copyright (c) Sven Panne 2002-2018 This file is part of HOpenGL and distributed under a BSD-style license See the file libraries/GLUT/LICENSE -} @@ -182,12 +182,12 @@ initialWindowPosition $= Position 0 0 initialWindowSize $= Size 400 400 initialDisplayMode $= [ RGBMode, DoubleBuffered, WithDepthBuffer ] - createWindow progName + _ <- createWindow progName state <- makeState reshapeCallback $= Just (\size -> viewport $= (Position 0 0, size)) keyboardMouseCallback $= Just (keyboard state) setIdleCallback state - [ occQuery ] <- genObjectNames 1 + occQuery <- genObjectName displayCallback $= display occQuery state myInit mainLoop diff --git a/examples/Misc/ColorTriangle/ColorTriangle.hs b/examples/Misc/ColorTriangle/ColorTriangle.hs new file mode 100644 --- /dev/null +++ b/examples/Misc/ColorTriangle/ColorTriangle.hs @@ -0,0 +1,101 @@ +{- + ColorTriangle.hs (adapted from triangles.cpp which is (c) The Red Book + Authors.) + Copyright (c) Sven Panne 2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file GLUT/LICENSE + + A variation of Triangles.hs, adding colors to vertices via interleaved vertex + attributes. +-} + +import Control.Monad +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable +import Graphics.UI.GLUT +import Prelude hiding ( init ) +import LoadShaders + +bufferOffset :: Integral a => a -> Ptr b +bufferOffset = plusPtr nullPtr . fromIntegral + +data Descriptor = Descriptor VertexArrayObject ArrayIndex NumArrayIndices + +data ColoredVertex = ColoredVertex (Vertex2 GLfloat) (Color3 GLfloat) + +instance Storable ColoredVertex where + sizeOf ~(ColoredVertex v c) = sizeOf v + sizeOf c + alignment ~(ColoredVertex v _) = alignment v + peek ptr = do v <- peek (castPtr ptr) + c <- peekByteOff (castPtr ptr) (sizeOf v) + return $ ColoredVertex v c + poke ptr (ColoredVertex v c) = do poke (castPtr ptr) v + pokeByteOff (castPtr ptr) (sizeOf v) c + +init :: IO Descriptor +init = do + triangles <- genObjectName + bindVertexArrayObject $= Just triangles + + let vertices = [ + -- Triangle 1 + ColoredVertex (Vertex2 (-0.90) (-0.90)) (Color3 1 0 0), + ColoredVertex (Vertex2 0.85 (-0.90)) (Color3 0 1 0), + ColoredVertex (Vertex2 (-0.90) 0.85 ) (Color3 0 0 1), + -- Triangle 2 + ColoredVertex (Vertex2 0.90 (-0.85)) (Color3 0 1 1), + ColoredVertex (Vertex2 0.90 0.90 ) (Color3 1 0 1), + ColoredVertex (Vertex2 (-0.85) 0.90 ) (Color3 1 1 0)] + numVertices = length vertices + vertexSize = sizeOf (head vertices) + + arrayBuffer <- genObjectName + bindBuffer ArrayBuffer $= Just arrayBuffer + withArray vertices $ \ptr -> do + let size = fromIntegral (numVertices * vertexSize) + bufferData ArrayBuffer $= (size, ptr, StaticDraw) + + program <- loadShaders [ + ShaderInfo VertexShader (FileSource "color_triangles.vert"), + ShaderInfo FragmentShader (FileSource "color_triangles.frag")] + currentProgram $= Just program + + let firstIndex = 0 + vPosition = AttribLocation 0 + vColor = AttribLocation 1 + vertexAttribPointer vPosition $= + (ToFloat, + VertexArrayDescriptor 2 Float (fromIntegral vertexSize) + (bufferOffset (firstIndex * vertexSize))) + vertexAttribArray vPosition $= Enabled + let colorOffset = case head vertices of ~(ColoredVertex v _) -> sizeOf v + vertexAttribPointer vColor $= + (ToFloat, + VertexArrayDescriptor 3 Float (fromIntegral vertexSize) + (bufferOffset ((firstIndex * vertexSize) + + fromIntegral colorOffset))) + vertexAttribArray vColor $= Enabled + + return $ + Descriptor triangles (fromIntegral firstIndex) (fromIntegral numVertices) + +display :: Descriptor -> DisplayCallback +display (Descriptor triangles firstIndex numVertices) = do + clear [ ColorBuffer ] + bindVertexArrayObject $= Just triangles + drawArrays Triangles firstIndex numVertices + flush + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ RGBAMode ] + initialWindowSize $= Size 512 512 + initialContextVersion $= (4, 3) + initialContextFlags $= [ DebugContext ] + initialContextProfile $= [ CoreProfile ] + _ <- createWindow progName + descriptor <- init + displayCallback $= display descriptor + mainLoop diff --git a/examples/Misc/ColorTriangle/color_triangles.frag b/examples/Misc/ColorTriangle/color_triangles.frag new file mode 100644 --- /dev/null +++ b/examples/Misc/ColorTriangle/color_triangles.frag @@ -0,0 +1,10 @@ +#version 430 core + +in vec4 color; +out vec4 fColor; + +void +main() +{ + fColor = color; +} diff --git a/examples/Misc/ColorTriangle/color_triangles.vert b/examples/Misc/ColorTriangle/color_triangles.vert new file mode 100644 --- /dev/null +++ b/examples/Misc/ColorTriangle/color_triangles.vert @@ -0,0 +1,12 @@ +#version 430 core + +layout(location = 0) in vec4 vPosition; +layout(location = 1) in vec4 vColor; +out vec4 color; + +void +main() +{ + gl_Position = vPosition; + color = vColor; +} diff --git a/examples/Misc/ExtractContours.hs b/examples/Misc/ExtractContours.hs --- a/examples/Misc/ExtractContours.hs +++ b/examples/Misc/ExtractContours.hs @@ -1,6 +1,6 @@ {- ExtractContours.hs (adapted from tess.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 + Copyright (c) Sven Panne 2002-2018 This file is part of HOpenGL and distributed under a BSD-style license See the file libraries/GLUT/LICENSE @@ -23,7 +23,7 @@ -- resolve overloading, not needed in "real" programs let color3f = color :: Color3 GLfloat -> IO () color3f (Color3 1 1 1) - mapM callList displayLists + mapM_ callList displayLists flush -- 'Float' is a dummy, any marshalable type would do @@ -109,7 +109,7 @@ (progName, _args) <- getArgsAndInitialize initialDisplayMode $= [ SingleBuffered, RGBMode ] initialWindowSize $= Size 500 500 - createWindow progName + _ <- createWindow progName displayLists <- myInit displayCallback $= display displayLists reshapeCallback $= Just reshape diff --git a/examples/Misc/Gears.hs b/examples/Misc/Gears.hs --- a/examples/Misc/Gears.hs +++ b/examples/Misc/Gears.hs @@ -1,7 +1,7 @@ {- Gears.hs (adapted from gears.c which is (c) Brian Paul) Copyright (c) Shawn P. Garbett 2004 - Further hacked by Sven Panne + Further hacked by Sven Panne This file is part of HOpenGL and distributed under a BSD-style license See the file libraries/GLUT/LICENSE @@ -289,7 +289,7 @@ initialWindowPosition $= Position 0 0 initialWindowSize $= Size 300 300 - createWindow "Gears" + _ <- createWindow "Gears" state <- makeState gearsAndAuto <- myInit args diff --git a/examples/Misc/Pitfall14.hs b/examples/Misc/Pitfall14.hs --- a/examples/Misc/Pitfall14.hs +++ b/examples/Misc/Pitfall14.hs @@ -1,6 +1,6 @@ {- Pitfall14 - Copyright (c) Sven Panne 2002-2005 + Copyright (c) Sven Panne 2002-2018 This file is part of HOpenGL and distributed under a BSD-style license See the file libraries/GLUT/LICENSE @@ -17,7 +17,7 @@ main = do (progName, _args) <- getArgsAndInitialize initialDisplayMode $= [ SingleBuffered, RGBMode ] - createWindow progName + _ <- createWindow progName currentColor $= Color4 1 1 1 1 materialAmbient Front $= Color4 0.1 0.1 0.1 1 diff --git a/examples/Misc/SmoothOpenGL3.hs b/examples/Misc/SmoothOpenGL3.hs --- a/examples/Misc/SmoothOpenGL3.hs +++ b/examples/Misc/SmoothOpenGL3.hs @@ -1,22 +1,31 @@ +{-# LANGUAGE CPP #-} {- SmoothOpenGL3.hs (adapted from freeglut's smooth_opengl3.c example) - Copyright (c) Sven Panne 2009 + Copyright (c) Sven Panne 2018 This file is part of HOpenGL and distributed under a BSD-style license See the file LICENSE -} import Control.Monad +import qualified Data.ByteString as B import Data.List import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable -import Graphics.Rendering.OpenGL.Raw.Core31 +#if MIN_VERSION_OpenGLRaw(3,0,0) +import Graphics.GL +#else +import Graphics.Rendering.OpenGL.Raw +#define GL_FALSE gl_FALSE +#define GL_TRUE gl_TRUE +#endif import Graphics.UI.GLUT import System.Exit import System.IO data State = State { vertexBufferName :: BufferObject, + vertexArrayObject :: VertexArrayObject, fgProjectionMatrixIndex :: UniformLocation, fgColorIndex :: AttribLocation , fgVertexIndex :: AttribLocation, @@ -27,7 +36,7 @@ where reportError e = hPutStrLn stderr (showError e ++ " detected in " ++ functionName) showError (Error category message) = - "GL error" ++ show category ++ " (" ++ message ++ ")" + "GL error " ++ show category ++ " (" ++ message ++ ")" varray :: [GLfloat] varray = [ @@ -60,15 +69,15 @@ initBuffer :: IO BufferObject initBuffer = do - [bufferObject] <- genObjectNames 1 + bufferObject <- genObjectName bindBuffer ArrayBuffer $= Just bufferObject withArray varray $ \buffer -> bufferData ArrayBuffer $= (fromIntegral sizeOfVarray, buffer, StaticDraw) checkError "initBuffer" return bufferObject -vertexShaderSource :: String -vertexShaderSource = unlines [ +vertexShaderSource :: B.ByteString +vertexShaderSource = packUtf8 . unlines $ [ "#version 140", "uniform mat4 fg_ProjectionMatrix;", "in vec4 fg_Color;", @@ -80,8 +89,8 @@ " gl_Position = fg_ProjectionMatrix * fg_Vertex;", "}" ] -fragmentShaderSource :: String -fragmentShaderSource = unlines [ +fragmentShaderSource :: B.ByteString +fragmentShaderSource = packUtf8 . unlines $ [ "#version 140", "smooth in vec4 fg_SmoothColor;", "out vec4 fg_FragColor;", @@ -97,31 +106,31 @@ unless status $ hPutStrLn stderr . ((message ++ " log: ") ++) =<< get (getInfoLog object) -compileAndCheck :: Shader s => s -> IO () +compileAndCheck :: Shader -> IO () compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile" -compileShaderSource :: Shader s => [String] -> IO s -compileShaderSource source = do - [shader] <- genObjectNames 1 - shaderSource shader $= source +compileShaderSource :: ShaderType -> B.ByteString -> IO Shader +compileShaderSource st source = do + shader <- createShader st + shaderSourceBS shader $= source compileAndCheck shader return shader linkAndCheck :: Program -> IO () linkAndCheck = checked linkProgram linkStatus programInfoLog "link" -createProgram :: [VertexShader] -> [FragmentShader] -> IO Program -createProgram vertexShaders fragmentShaders = do - [program] <- genObjectNames 1 - attachedShaders program $= (vertexShaders, fragmentShaders) +createProgramUsing :: [Shader] -> IO Program +createProgramUsing shaders = do + program <- createProgram + attachedShaders program $= shaders linkAndCheck program return program initShader :: IO (UniformLocation, AttribLocation, AttribLocation) initShader = do - vertexShader <- compileShaderSource [vertexShaderSource] - fragmentShader <- compileShaderSource [fragmentShaderSource] - program <- createProgram [vertexShader] [fragmentShader] + vertexShader <- compileShaderSource VertexShader vertexShaderSource + fragmentShader <- compileShaderSource FragmentShader fragmentShaderSource + program <- createProgramUsing [vertexShader, fragmentShader] currentProgram $= Just program projectionMatrixIndex <- get (uniformLocation program "fg_ProjectionMatrix") @@ -142,12 +151,15 @@ myInit :: IO State myInit = do + vao <- genObjectName + bindVertexArrayObject $= Just vao bufferObject <- initBuffer (projectionMatrixIndex, colorIndex, vertexIndex) <- initShader initRendering m <- newMatrix ColumnMajor (replicate 16 0) return $ State { vertexBufferName = bufferObject, + vertexArrayObject = vao, fgProjectionMatrixIndex = projectionMatrixIndex, fgColorIndex = colorIndex, fgVertexIndex = vertexIndex, @@ -155,7 +167,8 @@ dumpInfo :: IO () dumpInfo = do - let dump message var = putStrLn . ((message ++ ": ") ++) =<< get var + let dump :: String -> GettableStateVar String -> IO () + dump message var = putStrLn . ((message ++ ": ") ++) =<< get var dump "Vendor" vendor dump "Renderer" renderer dump "Version" glVersion @@ -173,6 +186,7 @@ triangle state = do withMatrix (projectionMatrix state) $ \order buffer -> uniformMatrix4fv (fgProjectionMatrixIndex state) 1 (order == RowMajor) buffer + bindVertexArrayObject $= Just (vertexArrayObject state) bindBuffer ArrayBuffer $= Just (vertexBufferName state) vertexAttribPointer (fgColorIndex state) $= (ToFloat, vertexArrayDescriptor numColorComponents 0) @@ -186,8 +200,8 @@ uniformMatrix4fv location count = glUniformMatrix4fv (uniformLocationToGLint location) count . marshalGLboolean where marshalGLboolean x = fromIntegral $ case x of - False -> gl_FALSE - True -> gl_TRUE + False -> GL_FALSE + True -> GL_TRUE -- MEGA HACK because UniformLocation is abstract uniformLocationToGLint = read . head . tail . words . show @@ -257,7 +271,7 @@ initialContextFlags $= [ ForwardCompatibleContext, DebugContext ] initialWindowSize $= Size 500 500 initialWindowPosition $= Position 100 100 - createWindow progName + _ <- createWindow progName dumpInfo state <- myInit displayCallback $= display state diff --git a/examples/Misc/Triangulate.hs b/examples/Misc/Triangulate.hs --- a/examples/Misc/Triangulate.hs +++ b/examples/Misc/Triangulate.hs @@ -1,6 +1,6 @@ {- Triangulate.hs (adapted from tess.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 + Copyright (c) Sven Panne 2002-2018 This file is part of HOpenGL and distributed under a BSD-style license See the file libraries/GLUT/LICENSE @@ -24,7 +24,7 @@ -- resolve overloading, not needed in "real" programs let color3f = color :: Color3 GLfloat -> IO () color3f (Color3 1 1 1) - mapM callList displayLists + mapM_ callList displayLists flush -- 'Float' is a dummy, any marshalable type would do @@ -114,7 +114,7 @@ (progName, _args) <- getArgsAndInitialize initialDisplayMode $= [ SingleBuffered, RGBMode ] initialWindowSize $= Size 500 500 - createWindow progName + _ <- createWindow progName displayLists <- myInit displayCallback $= display displayLists reshapeCallback $= Just reshape diff --git a/examples/OrangeBook/00-README b/examples/OrangeBook/00-README new file mode 100644 --- /dev/null +++ b/examples/OrangeBook/00-README @@ -0,0 +1,2 @@ +This directory contains an example from the book "OpenGL Shading Language", 3rd +ed, by Rost/Licea-Kane/Ginsburg/Kessenich/Lichtenbelt/Malan/Weiblen. diff --git a/examples/OrangeBook/ogl2brick/Brick.hs b/examples/OrangeBook/ogl2brick/Brick.hs --- a/examples/OrangeBook/ogl2brick/Brick.hs +++ b/examples/OrangeBook/ogl2brick/Brick.hs @@ -1,14 +1,19 @@ +{-# LANGUAGE CPP #-} {- Brick.hs (adapted from ogl2brick.c which is (c) 3Dlabs Inc. Ltd.) - Copyright (c) Sven Panne 2006 + Copyright (c) Sven Panne 2018 This file is part of HOpenGL and distributed under a BSD-style license See the file libraries/GLUT/LICENSE -} +#if !MIN_VERSION_base(4,8,0) import Prelude hiding ( sum ) -import Control.Applicative -import Control.Monad import Data.Foldable ( Foldable, sum ) +#endif +import Control.Applicative +import Control.Exception ( IOException, catch ) +import Control.Monad ( when, unless ) +import qualified Data.ByteString as B import Data.IORef import System.Exit import Graphics.UI.GLUT @@ -288,11 +293,11 @@ unless ("GL_ARB_shading_language_100" `elem` extensions) $ ioError (userError "No GLSL support found.") -readAndCompileShader :: Shader s => FilePath -> IO s -readAndCompileShader filePath = do - src <- readFile filePath - [shader] <- genObjectNames 1 - shaderSource shader $= [src] +readAndCompileShader :: ShaderType -> FilePath -> IO Shader +readAndCompileShader st filePath = do + src <- B.readFile filePath + shader <- createShader st + shaderSourceBS shader $= src compileShader shader reportErrors ok <- get (compileStatus shader) @@ -303,10 +308,10 @@ ioError (userError "shader compilation failed") return shader -installBrickShaders :: [VertexShader] -> [FragmentShader] -> IO () -installBrickShaders vs fs = do - [brickProg] <- genObjectNames 1 - attachedShaders brickProg $= (vs, fs) +installBrickShaders :: [Shader] -> IO () +installBrickShaders shaders = do + brickProg <- createProgram + attachedShaders brickProg $= shaders linkProgram brickProg reportErrors ok <- get (linkStatus brickProg) @@ -319,9 +324,9 @@ currentProgram $= Just brickProg let setUniform var val = do - location <- get (uniformLocation brickProg var) - reportErrors - uniform location $= val + location <- get (uniformLocation brickProg var) + reportErrors + uniform location $= val setUniform "BrickColor" (Color3 1.0 0.3 (0.2 :: GLfloat)) setUniform "MortarColor" (Color3 0.85 0.86 (0.84 :: GLfloat)) @@ -331,10 +336,10 @@ main :: IO () main = do - getArgsAndInitialize + _ <- getArgsAndInitialize initialDisplayMode $= [ RGBMode, WithDepthBuffer, DoubleBuffered ] initialWindowSize $= Size 500 500 - createWindow "3Dlabs Brick Shader" + _ <- createWindow "3Dlabs Brick Shader" -- Note: We don't use an idle callback, we redisplay more intelligently. state <- makeState @@ -344,13 +349,13 @@ motionCallback $= Just (motion state) addTimerCallback timerFrequencyMillis (timer state) - catch + Control.Exception.catch (do checkGLSLSupport - vs <- readAndCompileShader "Brick.vert" - fs <- readAndCompileShader "Brick.frag" - installBrickShaders [vs] [fs]) + vs <- readAndCompileShader VertexShader "Brick.vert" + fs <- readAndCompileShader FragmentShader "Brick.frag" + installBrickShaders [vs, fs]) (\exception -> do - print exception + print (exception :: IOException) putStrLn "Using fixed function pipeline." materialDiffuse Front $= Color4 1 0.3 0.2 1 materialSpecular Front $= Color4 0.3 0.3 0.3 1 diff --git a/examples/RedBook/00-README b/examples/RedBook/00-README deleted file mode 100644 --- a/examples/RedBook/00-README +++ /dev/null @@ -1,189 +0,0 @@ -This file lists the programs that are referenced in the OpenGL Programming -Guide, Fourth Edition, by chapter. For each program, the version of OpenGL -that is required is listed with the program. - -Chapter 1: Introduction to OpenGL - - Hello.hs (1.0) - Double.hs (1.0) - -Chapter 2: State Management and Drawing Geometric Objects - - Lines.hs (1.0) - Polys.hs (1.0) - VArray.hs (1.1) - MVArray.hs (1.4) - -Chapter 3: Viewing - - Cube.hs (1.0) - Model.hs (1.0) - Clip.hs (1.0) - Planet.hs (1.0) - Robot.hs (1.0) - UnProject.hs (1.1) - -Chapter 4: Color - - Smooth.hs (1.0) - -Chapter 5: Lighting - - Light.hs (1.0) - MoveLight.hs (1.0) - Material.hs (1.0) - ColorMat.hs (1.1) - Scene.hs (1.0) - -Chapter 6: Blending, Antialiasing, Fog, and Polygon Offset - - BlendEqn.hs (1.3 or ARB_imaging_subset) - Alpha.hs (1.0) - Alpha3D.hs (1.1) - AARGB.hs (1.1) - AAIndex.hs (1.1) - Multisamp.hs (1.3) - Fog.hs (1.0) - FogIndex.hs (1.0) - FogCoord.hs (1.4) - PointP.hs (1.4) - PolyOff.hs (1.1) - -Chapter 7: Display Lists - - Torus.hs (1.0) - DList.hs (1.0) - Stroke.hs (1.0) - -Chapter 8: Drawing Pixels, Bitmaps, Fonts, and Images - - DrawF.hs (1.0) - Font.hs (1.0) - Image.hs (1.1) - ColorTable.hs (ARB_imaging_subset) - Convolution.hs (ARB_imaging_subset) - ColorMatrix.hs (ARB_imaging_subset) - Histogram.hs (ARB_imaging_subset) - Minmax.hs (ARB_imaging_subset) - -Chapter 9: Texture Mapping - - Checker.hs (1.0) - TexSub.hs (1.1) - Texture3D.hs (1.2) - Mipmap.hs (1.0) - TexBind.hs (1.1) - TexGen.hs (1.1) - CubeMap.hs (1.3) - MultiTex.hs (1.3 or ARB_multitexture) - Combiner.hs (1.3) - ShadowMap.hs (1.4) - Wrap.hs (1.0) - TexProx.hs (1.1) - -Chapter 10: The Framebuffer - - Stencil.hs (1.0) - AccPersp.hs (1.0) - AccAnti.hs (1.0) - DOF.hs (1.0) - -Chapter 11: Tessellators and Quadrics - - Tess.hs (1.1) - TessWind.hs (1.1) - Quadric.hs (1.1) - -Chapter 12: Evaluators and NURBS - - BezCurve.hs (1.1) - BezSurf.hs (1.1) - BezMesh.hs (1.1) - TextureSurf.hs (1.1) - Surface.hs (1.1) - SurfPoints.hs (1.2) - Trim.hs (1.1) - -Chapter 13: Selection and Feedback - - Select.hs (1.1) - PickSquare.hs (1.0) - PickDepth.hs (1.0) - Feedback.hs (1.0) - -Chapter 14: Now That You Know - - - -Color Plates: - - Teapots.hs (1.1) - -Some remarks regarding the style of the programs: - -To ease comparisons, the Haskell programs in this directory try to stay as -close to the original examples in C as possible. Consequently, they should -not be considered as examples for the best way to implement things in -Haskell. - -The Haskell OpenGL binding uses overloading quite extensively, which makes -its use quite flexible, e.g.: - - class Vertex a where - vertex :: a -> IO () - vertexv :: Ptr a -> IO () - -This single class subsumes all 24 vertex specification calls in OpenGL's C -binding, i.e. glVertex{234}{sifd}[v](), with the help of the following -class and instances: - - class VertexComponent a -- an opaque class - - VertexComponent GLshort - VertexComponent GLint - VertexComponent GLfloat - VertexComponent GLdouble - - VertexComponent a => Vertex (Vertex2 a) - VertexComponent a => Vertex (Vertex3 a) - VertexComponent a => Vertex (Vertex4 a) - -There is a small inconvenience with this when used in "toy" programs: -Haskell's numeric literals are overloaded, too, so the programmer's help is -needed to disambiguate the type of expressions like: - - vertex (Vertex3 0 0 1) - -Let's assume we mean the equivalent of glVertex3f() here. One can either -use an explicitly typed helper function: - - let vertex3f = vertex :: Vertex3 GLfloat -> IO () - in vertex3f (Vertex3 0 0 1) - -This comes in handy when there are a lot of uses of vertex3f. An -alternative is to use a type annotation for the literal: - - vertex (Vertex3 0 0 (1 :: GLfloat)) - -or a type annotation for the vertex: - - vertex (Vertex3 0 0 1 :: Vertex3 GLfloat) - -This is largely a matter of taste and normally not a problem in "real" -programs with type signatures for functions. - -Sometimes different callbacks need to share some state, which is done via -global variables in the C examples. To achieve a unified presentation, all -Haskell examples use a `State' type for this purpose, which collects the -different parts of the global state, i.e. one or more IORefs. There are -alternatives for modeling this, which should be considered in own programs, -depending on the use cases: - - * Separate IORefs: This makes it explicit which parts of the program need - which parts of the state. - - * A single IORef/MVar containing all the state: This enables one to change - the whole state atomically, which is often quite handy in multithreaded - programs. - - * A custom monad: This can hide all the state threading behind the scenes. diff --git a/examples/RedBook/AAIndex.hs b/examples/RedBook/AAIndex.hs deleted file mode 100644 --- a/examples/RedBook/AAIndex.hs +++ /dev/null @@ -1,104 +0,0 @@ -{- - AAIndex.hs (adapted from aaindex.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws shows how to draw anti-aliased lines in color index - mode. It draws two diagonal lines to form an X; when 'r' is typed in the - window, the lines are rotated in opposite directions. --} - -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { rotAngle :: IORef Int } - -makeState :: IO State -makeState = do - r <- newIORef 0 - return $ State { rotAngle = r } - -rampSize, ramp1Start, ramp2Start :: GLint -rampSize = 16 -ramp1Start = 32 -ramp2Start = 48 - --- Initialize antialiasing for color index mode, including loading a green color --- ramp starting at ramp1Start, and a blue color ramp starting at ramp2Start. --- The ramps must be a multiple of 16. -myInit :: IO () -myInit = do - flip mapM_ [ 0 .. rampSize - 1 ] $ \i -> do - let shade = fromIntegral i / fromIntegral rampSize - colorMapEntry (Index1 (ramp1Start + i)) $= Color3 0 shade 0 - colorMapEntry (Index1 (ramp2Start + i)) $= Color3 0 0 shade - - lineSmooth $= Enabled - hint LineSmooth $= DontCare - lineWidth $= 1.5 - - clearIndex $= Index1 (fromIntegral ramp1Start) - --- Draw 2 diagonal lines to form an X -display :: State -> DisplayCallback -display state = do - r <- get (rotAngle state) - clear [ ColorBuffer ] - - -- resolve overloading, not needed in "real" programs - let vertex2f = vertex :: Vertex2 GLfloat -> IO () - - index (Index1 ramp1Start) - preservingMatrix $ do - rotate (-(fromIntegral r :: GLfloat)) (Vector3 0 0 0.1) - renderPrimitive Lines $ do - vertex2f (Vertex2 (-0.5) 0.5) - vertex2f (Vertex2 0.5 (-0.5)) - - index (Index1 ramp2Start) - preservingMatrix $ do - rotate (fromIntegral r :: GLfloat) (Vector3 0 0 0.1) - renderPrimitive Lines $ do - vertex2f (Vertex2 0.5 0.5) - vertex2f (Vertex2 (-0.5) (-0.5)) - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho2D (-1) 1 (-1*hf/wf) (1*hf/wf) - else ortho2D (-1*wf/hf) (1*wf/hf) (-1) 1 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case toLower c of - 'r' -> do rotAngle state $~ ((`mod` 360) . (+ 30)); postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ = return () - --- Main Loop --- Open window with initial window size, title bar, --- color index display mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, IndexMode ] - initialWindowSize $= Size 200 200 - createWindow progName - state <- makeState - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - displayCallback $= display state - mainLoop diff --git a/examples/RedBook/AARGB.hs b/examples/RedBook/AARGB.hs deleted file mode 100644 --- a/examples/RedBook/AARGB.hs +++ /dev/null @@ -1,104 +0,0 @@ -{- - AARGB.hs (adapted from aargb.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws shows how to draw anti-aliased lines. It draws two - diagonal lines to form an X; when 'r' is typed in the window, the lines are - rotated in opposite directions. --} - -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { rotAngle :: IORef Int } - -makeState :: IO State -makeState = do - r <- newIORef 0 - return $ State { rotAngle = r } - --- Initialize antialiasing for RGBA mode, including alpha blending, hint, and --- line width. Print out implementation specific info on line width granularity --- and width. -myInit :: IO () -myInit = do - g <- get smoothLineWidthGranularity - putStrLn ("smoothLineWidthGranularity is " ++ show g) - - r <- get smoothLineWidthRange - putStrLn ("smoothLineWidthRange is " ++ show r) - - lineSmooth $= Enabled - - blend $= Enabled - blendFunc $= (SrcAlpha, OneMinusSrcAlpha) - hint LineSmooth $= DontCare - lineWidth $= 1.5 - - clearColor $= Color4 0 0 0 0 - --- Draw 2 diagonal lines to form an X -display :: State -> DisplayCallback -display state = do - r <- get (rotAngle state) - clear [ ColorBuffer ] - - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - vertex2f = vertex :: Vertex2 GLfloat -> IO () - - color3f (Color3 0 1 0) - preservingMatrix $ do - rotate (-(fromIntegral r :: GLfloat)) (Vector3 0 0 0.1) - renderPrimitive Lines $ do - vertex2f (Vertex2 (-0.5) 0.5) - vertex2f (Vertex2 0.5 (-0.5)) - - color3f (Color3 0 0 1) - preservingMatrix $ do - rotate (fromIntegral r :: GLfloat) (Vector3 0 0 0.1) - renderPrimitive Lines $ do - vertex2f (Vertex2 0.5 0.5) - vertex2f (Vertex2 (-0.5) (-0.5)) - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho2D (-1) 1 (-1*hf/wf) (1*hf/wf) - else ortho2D (-1*wf/hf) (1*wf/hf) (-1) 1 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case toLower c of - 'r' -> do rotAngle state $~ ((`mod` 360) . (+ 30)); postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ = return () - --- Main Loop --- Open window with initial window size, title bar, --- RGBA display mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 200 200 - createWindow progName - state <- makeState - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - displayCallback $= display state - mainLoop diff --git a/examples/RedBook/AccAnti.hs b/examples/RedBook/AccAnti.hs deleted file mode 100644 --- a/examples/RedBook/AccAnti.hs +++ /dev/null @@ -1,132 +0,0 @@ -{- - AccAnti.hs (adapted from accanti.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Use the accumulation buffer to do full-scene antialiasing on a scene with - orthographic parallel projection. --} - -import Data.List ( genericLength ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a --- gaussian distribution around the origin. Use these to do model jittering for --- scene anti-aliasing and view volume jittering for depth of field effects. Use --- in conjunction with the accwindow routine. -j8 :: [Vector2 GLdouble] -j8 = [ - Vector2 (-0.334818) 0.435331 , - Vector2 0.286438 (-0.393495), - Vector2 0.459462 0.141540 , - Vector2 (-0.414498) (-0.192829), - Vector2 (-0.183790) 0.082102 , - Vector2 (-0.079263) (-0.317383), - Vector2 0.102254 0.299133 , - Vector2 0.164216 (-0.054399) ] - --- Initialize lighting and other values. -myInit :: IO () -myInit = do - materialAmbient Front $= Color4 1 1 1 1 - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 50 - position (Light 0) $= Vertex4 0 0 10 1 - lightModelAmbient $= Color4 0.2 0.2 0.2 1 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - shadeModel $= Flat - - clearColor $= Color4 0 0 0 0 - clearAccum $= Color4 0 0 0 0 - -displayObjects :: IO () -displayObjects = do - -- resolve overloading, not needed in "real" programs - let translatef = translate :: Vector3 GLfloat -> IO () - rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () - - preservingMatrix $ do - rotatef 30 (Vector3 1 0 0) - - preservingMatrix $ do - translatef (Vector3 (-0.80) 0.35 0) - rotatef 100 (Vector3 1 0 0) - materialDiffuse Front $= Color4 0.7 0.7 0 1 - renderObject Solid (Torus 0.275 0.85 16 16) - - preservingMatrix $ do - translatef (Vector3 (-0.75) (-0.50) 0) - rotatef 45 (Vector3 0 0 1) - rotatef 45 (Vector3 1 0 0) - materialDiffuse Front $= Color4 0 0.7 0.7 1 - renderObject Solid (Cube 1.5) - - preservingMatrix $ do - translatef (Vector3 0.75 0.60 0) - rotatef 30 (Vector3 1 0 0) - materialDiffuse Front $= Color4 0.7 0 0.7 1 - renderObject Solid (Sphere' 1 16 16) - - preservingMatrix $ do - translatef (Vector3 0.70 (-0.90) 0.25) - materialDiffuse Front $= Color4 0.7 0.4 0.4 1 - renderObject Solid Octahedron - --- display draws 5 teapots into the accumulation buffer several times; each time --- with a jittered perspective. The focal point is at z = 5.0, so the gold --- teapot will stay in focus. The amount of jitter is adjusted by the magnitude --- of the accPerspective jitter; in this example, 0.33. In this example, the --- teapots are drawn 8 times. -display :: DisplayCallback -display = do - (_, Size w h) <- get viewport - clear [ AccumBuffer ] - - flip mapM_ j8 $ \(Vector2 x y) -> do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - -- Note that 4.5 is the distance in world space between left and right - -- and bottom and top. This formula converts fractional pixel movement - -- to world coordinates. - translate (Vector3 (x*4.5/fromIntegral w) (y*4.5/fromIntegral h) 0) - displayObjects - accum Accum (recip (genericLength j8)) - - accum Return 1 - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-2.25) 2.25 (-2.25*hf/wf) (2.25*hf/wf) (-10) 10 - else ortho (-2.25*wf/hf) (2.25*wf/hf) (-2.25) 2.25 (-10) 10 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Be certain to request an accumulation buffer. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/AccPersp.hs b/examples/RedBook/AccPersp.hs deleted file mode 100644 --- a/examples/RedBook/AccPersp.hs +++ /dev/null @@ -1,166 +0,0 @@ -{- - AccPersp.hs (adapted from accpersp.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Use the accumulation buffer to do full-scene antialiasing on a scene with - perspective projection, using the special routines accFrustum and - accPerspective. --} - -import Data.List ( genericLength ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a --- gaussian distribution around the origin. Use these to do model jittering for --- scene anti-aliasing and view volume jittering for depth of field effects. Use --- in conjunction with the accwindow routine. -j8 :: [Vector2 GLdouble] -j8 = [ - Vector2 (-0.334818) 0.435331 , - Vector2 0.286438 (-0.393495), - Vector2 0.459462 0.141540 , - Vector2 (-0.414498) (-0.192829), - Vector2 (-0.183790) 0.082102 , - Vector2 (-0.079263) (-0.317383), - Vector2 0.102254 0.299133 , - Vector2 0.164216 (-0.054399) ] - --- The first 6 arguments are identical to the frustum call. pixD is anti-alias --- jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD is --- depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field --- effects. focus is distance from eye to plane in focus. focus must be greater --- than, but not equal to 0. Note that accFrustum calls translate. You will --- probably want to insure that your ModelView matrix has been initialized to --- identity before calling accFrustum. -accFrustum :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble - -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () -accFrustum left right bottom top zNear zFar - (Vector2 pixDx pixDy) (Vector2 eyeDx eyeDy) focus = do - (_, Size w h) <- get viewport - - let xWSize = right - left; - yWSize = top - bottom; - - dx = -(pixDx * xWSize / fromIntegral w + eyeDx * zNear / focus) - dy = -(pixDy * yWSize / fromIntegral h + eyeDy * zNear / focus) - - matrixMode $= Projection - loadIdentity - frustum (left + dx) (right + dx) (bottom + dy) (top + dy) zNear zFar - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 (-eyeDx) (-eyeDy) 0) - --- The first 4 arguments are identical to the perspective call. pixD is --- anti-alias jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD --- is depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field --- effects. focus is distance from eye to plane in focus. focus must be greater --- than, but not equal to 0. Note that accPerspective calls accFrustum. -accPerspective :: GLdouble -> GLdouble -> GLdouble -> GLdouble - -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () -accPerspective fovY aspect zNear zFar pixD eyeD focus = do - let fov2 = ((fovY * pi) / 180) / 2 - - top = zNear / (cos fov2 / sin fov2) - bottom = -top - - right = top * aspect - left = -right - - accFrustum left right bottom top zNear zFar pixD eyeD focus - --- Initialize lighting and other values. -myInit :: IO () -myInit = do - materialAmbient Front $= Color4 1 1 1 1 - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 50 - position (Light 0) $= Vertex4 0 0 10 1 - lightModelAmbient $= Color4 0.2 0.2 0.2 1 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - shadeModel $= Flat - - clearColor $= Color4 0 0 0 0 - clearAccum $= Color4 0 0 0 0 - -displayObjects :: IO () -displayObjects = do - -- resolve overloading, not needed in "real" programs - let translatef = translate :: Vector3 GLfloat -> IO () - rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () - - preservingMatrix $ do - translatef (Vector3 0 0 (-5)) - rotatef 30 (Vector3 1 0 0) - - preservingMatrix $ do - translatef (Vector3 (-0.80) 0.35 0) - rotatef 100 (Vector3 1 0 0) - materialDiffuse Front $= Color4 0.7 0.7 0 1 - renderObject Solid (Torus 0.275 0.85 16 16) - - preservingMatrix $ do - translatef (Vector3 (-0.75) (-0.50) 0) - rotatef 45 (Vector3 0 0 1) - rotatef 45 (Vector3 1 0 0) - materialDiffuse Front $= Color4 0 0.7 0.7 1 - renderObject Solid (Cube 1.5) - - preservingMatrix $ do - translatef (Vector3 0.75 0.60 0) - rotatef 30 (Vector3 1 0 0) - materialDiffuse Front $= Color4 0.7 0 0.7 1 - renderObject Solid (Sphere' 1 16 16) - - preservingMatrix $ do - translatef (Vector3 0.70 (-0.90) 0.25) - materialDiffuse Front $= Color4 0.7 0.4 0.4 1 - renderObject Solid Octahedron - --- display draws 5 teapots into the accumulation buffer several times; each time --- with a jittered perspective. The focal point is at z = 5.0, so the gold --- teapot will stay in focus. The amount of jitter is adjusted by the magnitude --- of the accPerspective jitter; in this example, 0.33. In this example, the --- teapots are drawn 8 times. -display :: DisplayCallback -display = do - (_, Size w h) <- get viewport - clear [ AccumBuffer ] - - flip mapM_ j8 $ \(Vector2 x y) -> do - clear [ ColorBuffer, DepthBuffer ] - accPerspective 50 (fromIntegral w / fromIntegral h) 1 15 - (Vector2 x y) (Vector2 0 0) 1 - displayObjects - accum Accum (recip (genericLength j8)) - - accum Return 1 - flush - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Be certain you request an accumulation buffer. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/Alpha.hs b/examples/RedBook/Alpha.hs deleted file mode 100644 --- a/examples/RedBook/Alpha.hs +++ /dev/null @@ -1,91 +0,0 @@ -{- - Alpha.hs (adapted from alpha.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws several overlapping filled polygons to demonstrate the - effect order has on alpha blending results. Use the 't' key to toggle the - order of drawing polygons. --} - -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { leftFirst :: IORef Bool } - -makeState :: IO State -makeState = do - l <- newIORef True - return $ State { leftFirst = l } - --- Initialize alpha blending function. -myInit :: IO () -myInit = do - blend $= Enabled - blendFunc $= (SrcAlpha, OneMinusSrcAlpha) - shadeModel $= Flat - clearColor $= Color4 0 0 0 0 - -drawLeftTriangle :: IO () -drawLeftTriangle = - -- draw yellow triangle on LHS of screen - renderPrimitive Triangles $ do - color (Color4 1 1 0 (0.75 :: GLfloat)) - vertex (Vertex3 0.1 0.9 (0 :: GLfloat)) - vertex (Vertex3 0.1 0.1 (0 :: GLfloat)) - vertex (Vertex3 0.7 0.5 (0 :: GLfloat)) - -drawRightTriangle :: IO () -drawRightTriangle = - -- draw cyan triangle on RHS of screen - renderPrimitive Triangles $ do - color (Color4 0 1 1 (0.75 :: GLfloat)) - vertex (Vertex3 0.9 0.9 (0 :: GLfloat)) - vertex (Vertex3 0.3 0.5 (0 :: GLfloat)) - vertex (Vertex3 0.9 0.1 (0 :: GLfloat)) - -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer ] - l <- get (leftFirst state) - if l - then do drawLeftTriangle; drawRightTriangle - else do drawRightTriangle; drawLeftTriangle - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho2D 0 1 0 (hf/wf) - else ortho2D 0 (wf/hf) 0 1 - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case toLower c of - 't' -> do leftFirst state $~ not; postRedisplay Nothing - '\27' -> exitWith ExitSuccess -- Escape key - _ -> return () -keyboard _ _ _ _ _ = return () - --- Main Loop --- Open window with initial window size, title bar, RGBA display mode, and --- handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 200 200 - createWindow progName - state <- makeState - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - displayCallback $= display state - mainLoop diff --git a/examples/RedBook/Alpha3D.hs b/examples/RedBook/Alpha3D.hs deleted file mode 100644 --- a/examples/RedBook/Alpha3D.hs +++ /dev/null @@ -1,124 +0,0 @@ -{- - Alpha3D.hs (adapted from alpha3D.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates how to intermix opaque and alpha blended polygons - in the same scene, by using depthMask. Press the 'a' key to animate moving - the transparent object through the opaque object. Press the 'r' key to reset - the scene. --} - -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -maxZ, minZ, zInc :: GLfloat -maxZ = 8 -minZ = -8 -zInc = 0.4 - --- We don't animate via the idle callback, because this is way too fast on --- modern computers. A timer with the delay below is used instead for redraw. -delay :: Timeout -delay = 100 - -data State = State { solidZ, transparentZ :: IORef GLfloat } - -makeState :: IO State -makeState = do - s <- newIORef maxZ - t <- newIORef minZ - return $ State { solidZ = s, transparentZ = t } - -data DisplayLists = DisplayLists { sphereList, cubeList :: DisplayList } - -myInit :: IO DisplayLists -myInit = do - materialSpecular Front $= Color4 1 1 1 0.15 - materialShininess Front $= 100 - position (Light 0) $= Vertex4 0.5 0.5 1 0 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - - s <- defineNewList Compile $ renderObject Solid (Sphere' 0.4 16 16) - c <- defineNewList Compile $ renderObject Solid (Cube 0.6) - return $ DisplayLists { sphereList = s, cubeList = c } - -display :: State -> DisplayLists -> DisplayCallback -display state displayLists = do - clear [ ColorBuffer, DepthBuffer ] - - preservingMatrix $ do - s <- get (solidZ state) - translate (Vector3 (-0.15) (-0.15) s) - materialEmission Front $= Color4 0 0 0 1 - materialDiffuse Front $= Color4 0.75 0.75 0 1 - callList (sphereList displayLists) - - preservingMatrix $ do - t <- get (transparentZ state) - translate (Vector3 (0.15) (0.15) t) - rotate (15 :: GLfloat) (Vector3 1 1 0) - rotate (30 :: GLfloat) (Vector3 0 1 0) - materialEmission Front $= Color4 0 0.3 0.3 0.6 - materialDiffuse Front $= Color4 0 0.8 0.8 0.6 - blend $= Enabled - depthMask $= Disabled - blendFunc $= (SrcAlpha, One) - callList (cubeList displayLists) - depthMask $= Enabled - blend $= Disabled - - swapBuffers - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-1.5) 1.5 (-1.5*hf/wf) (1.5*hf/wf) (-10) 10 - else ortho (-1.5*wf/hf) (1.5*wf/hf) (-1.5) 1.5 (-10) 10 - matrixMode $= Modelview 0 - loadIdentity - -animate :: State -> TimerCallback -animate state = do - s <- get (solidZ state) - t <- get (transparentZ state) - if (s <= minZ || t >= maxZ) - then idleCallback $= Nothing - else do - solidZ state $~ (+ (- zInc)) - transparentZ state $~ (+ zInc) - addTimerCallback delay (animate state) - postRedisplay Nothing - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case toLower c of - 'a' -> do solidZ state $= maxZ; transparentZ state $= minZ; addTimerCallback delay (animate state) - 'r' -> do solidZ state $= maxZ; transparentZ state $= minZ; postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - -- The original C example uses single buffering, which flickers a lot. - initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - createWindow progName - state <- makeState - displayLists <- myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - displayCallback $= display state displayLists - mainLoop diff --git a/examples/RedBook/BezCurve.hs b/examples/RedBook/BezCurve.hs deleted file mode 100644 --- a/examples/RedBook/BezCurve.hs +++ /dev/null @@ -1,67 +0,0 @@ -{- - BezCurve.hs (adapted from bezcurve.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program uses evaluators to draw a Bezier curve. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -ctrlPoints :: [Vertex3 GLfloat] -ctrlPoints = [ Vertex3 (-4)(-4) 0, Vertex3 (-2) 4 0, - Vertex3 2 (-4) 0, Vertex3 4 4 0 ] - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - m <- newMap1 (0, 1) ctrlPoints - map1 $= Just (m :: GLmap1 Vertex3 GLfloat) - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - color3f (Color3 1 1 1) - renderPrimitive LineStrip $ - mapM_ evalCoord1 [ i/30.0 :: GLfloat | i <- [0..30] ] - -- The following code displays the control points as dots. - pointSize $= 5 - color3f (Color3 1 1 0) - renderPrimitive Points $ - mapM_ vertex ctrlPoints - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-5.0) 5.0 (-5.0*hf/wf) (5.0*hf/wf) (-5.0) 5.0 - else ortho (-5.0*wf/hf) (5.0*wf/hf) (-5.0) 5.0 (-5.0) 5.0 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/BezMesh.hs b/examples/RedBook/BezMesh.hs deleted file mode 100644 --- a/examples/RedBook/BezMesh.hs +++ /dev/null @@ -1,84 +0,0 @@ -{- - BezMesh.hs (adapted from bezmesh.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program renders a lighted, filled Bezier surface, using two-dimensional - evaluators. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Data.List ( transpose ) -import Graphics.UI.GLUT - -ctrlPoints :: [[Vertex3 GLfloat]] -ctrlPoints = [ - [ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0, - Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ], - [ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0, - Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ], - [ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0, - Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ], - [ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0), - Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]] - -initlights :: IO () -initlights = do - lighting $= Enabled - light (Light 0) $= Enabled - - ambient (Light 0) $= Color4 0.2 0.2 0.2 1.0 - position (Light 0) $= Vertex4 0 0 2 1 - - materialDiffuse Front $= Color4 0.6 0.6 0.6 1.0 - materialSpecular Front $= Color4 1.0 1.0 1.0 1.0 - materialShininess Front $= 50 - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - rotate (85 :: GLfloat) (Vector3 1 1 1) - evalMesh2 Fill (0, 20) (0, 20) - flush - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - depthFunc $= Just Less - m <- newMap2 (0, 1) (0, 1) (transpose ctrlPoints) - map2 $= Just (m :: GLmap2 Vertex3 GLfloat) - autoNormal $= Enabled - mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat))) - initlights -- for lighted version only - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0 - else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/BezSurf.hs b/examples/RedBook/BezSurf.hs deleted file mode 100644 --- a/examples/RedBook/BezSurf.hs +++ /dev/null @@ -1,79 +0,0 @@ -{- - BezSurf.hs (adapted from bezsurf.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program renders a wireframe Bezier surface, using two-dimensional - evaluators. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -ctrlPoints :: [[Vertex3 GLfloat]] -ctrlPoints = [ - [ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0, - Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ], - [ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0, - Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ], - [ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0, - Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ], - [ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0), - Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]] - --- Hey mom, look, it's C! ;-) -for :: GLfloat -> GLfloat -> (GLfloat -> IO ()) -> IO () -for s e f = mapM_ f [ i | i <- [ s, if s <= e then s + 1 else s - 1 .. e ] ] - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - color (Color3 1 1 1 :: Color3 GLfloat) - preservingMatrix $ do - rotate (85 :: GLfloat) (Vector3 1 1 1) - for 0 8 $ \j -> do - renderPrimitive LineStrip $ do - for 0 30 $ \i -> evalCoord2 (i/30, j/ 8) - renderPrimitive LineStrip $ do - for 0 30 $ \i -> evalCoord2 (j/ 8, i/30) - flush - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - m <- newMap2 (0, 1) (0, 1) ctrlPoints - map2 $= Just (m :: GLmap2 Vertex3 GLfloat) - mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat))) - depthFunc $= Just Less - shadeModel $= Flat - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0 - else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/BlendEqn.hs b/examples/RedBook/BlendEqn.hs deleted file mode 100644 --- a/examples/RedBook/BlendEqn.hs +++ /dev/null @@ -1,95 +0,0 @@ -{- - BlendEqn.hs (adapted from blendeqn.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Demonstrate the different blending functions available with the OpenGL - imaging subset. This program demonstrates use of blendEquation. - - The following keys change the selected blend equation function: - - 'a' -> FuncAdd - 's' -> FuncSubtract - 'r' -> FuncReverseSubtract - 'm' -> Min - 'x' -> Max --} - -import Data.Char ( toLower ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - clearColor $= Color4 1 1 0 0 - blendFunc $= (One, One) - blend $= Enabled - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - - color (Color3 0 0 (1 :: GLfloat)) - rect (Vertex2 (-0.5) (-0.5)) (Vertex2 0.5 (0.5 :: GLfloat)) - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - let aspect = fromIntegral w / fromIntegral h - - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - if aspect < 1 - then let aspect' = recip aspect - in ortho (-aspect') aspect' (-1) 1 (-1) 1 - else ortho (-1) 1 (-aspect) aspect (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char c) Down _ _ = case toLower c of - -- Colors are added as: (0, 0, 1) + (1, 1, 0) = (1, 1, 1) - -- which will produce a white square on a yellow background. - 'a' -> setBlendEquation FuncAdd - - -- Colors are subtracted as: (0, 0, 1) - (1, 1, 0) = (-1, -1, 1) - -- which is clamped to (0, 0, 1), producing a blue square on a - -- yellow background - 's' -> setBlendEquation FuncSubtract - - -- Colors are subtracted as: (1, 1, 0) - (0, 0, 1) = (1, 1, -1) - -- which is clamed to (1, 1, 0). This produces yellow for both - -- the square and the background. - 'r' -> setBlendEquation FuncReverseSubtract - - -- The minimum of each component is computed, as - -- [min(0, 1), min(0, 1), min(1, 0)] which equates to (0, 0, 0). - -- This will produce a black square on the yellow background. - 'm' -> setBlendEquation Min - - -- The minimum of each component is computed, as - -- [max(0, 1), max(0, 1), max(1, 0)] which equates to (1, 1, 1) - -- This will produce a white square on the yellow background. - 'x' -> setBlendEquation Max - - '\27' -> exitWith ExitSuccess - _ -> return () - where setBlendEquation e = do - blendEquation $= e - postRedisplay Nothing -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 512 512 - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display - mainLoop diff --git a/examples/RedBook/Checker.hs b/examples/RedBook/Checker.hs deleted file mode 100644 --- a/examples/RedBook/Checker.hs +++ /dev/null @@ -1,101 +0,0 @@ -{- - Checker.hs (adapted from checker.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program texture maps a checkerboard image onto two rectangles. - - Texture objects are only used when GL_EXT_texture_object is supported. --} - -import Control.Monad ( when ) -import Data.Maybe ( isJust, listToMaybe ) -import Data.Bits ( (.&.) ) -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Create checkerboard image -checkImageSize :: TextureSize2D -checkImageSize = TextureSize2D 64 64 - -withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) - -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () -withCheckImage (TextureSize2D w h) n f act = - withArray [ f c | - i <- [ 0 .. w - 1 ], - j <- [ 0 .. h - 1 ], - let c | (i .&. n) == (j .&. n) = 0 - | otherwise = 255 ] $ - act. PixelData RGBA UnsignedByte - -myInit :: IO (Maybe TextureObject) -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - depthFunc $= Just Less - rowAlignment Unpack $= 1 - - exts <- get glExtensions - mbTexName <- if "GL_EXT_texture_object" `elem` exts - then fmap listToMaybe $ genObjectNames 1 - else return Nothing - when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName - - textureWrapMode Texture2D S $= (Repeated, Repeat) - textureWrapMode Texture2D T $= (Repeated, Repeat) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - withCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) $ - texImage2D Nothing NoProxy 0 RGBA' checkImageSize 0 - return mbTexName - -display :: Maybe TextureObject -> DisplayCallback -display mbTexName = do - clear [ ColorBuffer, DepthBuffer ] - texture Texture2D $= Enabled - textureFunction $= Decal - when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName - - -- resolve overloading, not needed in "real" programs - let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - renderPrimitive Quads $ do - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) - texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) - texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 ) - texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) - - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) - texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 ) - texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) - texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) - flush - texture Texture2D $= Disabled - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 60 (fromIntegral w / fromIntegral h) 1 30 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-3.6 :: GLfloat)) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - createWindow progName - mbTexName <- myInit - displayCallback $= display mbTexName - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/Clip.hs b/examples/RedBook/Clip.hs deleted file mode 100644 --- a/examples/RedBook/Clip.hs +++ /dev/null @@ -1,63 +0,0 @@ -{- - Clip.hs (adapted from clip.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates arbitrary clipping planes. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - translatef = translate :: Vector3 GLfloat -> IO () - rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () - color3f (Color3 1 1 1) - - preservingMatrix $ do - translatef (Vector3 0 0 (-5)) - - -- clip lower half -- y < 0 - clipPlane (ClipPlaneName 0) $= Just (Plane 0 1 0 0) - -- clip left half -- x < 0 - clipPlane (ClipPlaneName 1) $= Just (Plane 1 0 0 0) - - rotatef 90 (Vector3 1 0 0) - renderObject Wireframe (Sphere' 1 20 16) - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 60 (fromIntegral w / fromIntegral h) 1 20 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/ColorMat.hs b/examples/RedBook/ColorMat.hs deleted file mode 100644 --- a/examples/RedBook/ColorMat.hs +++ /dev/null @@ -1,94 +0,0 @@ -{- - Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - After initialization, the program will be in ColorMaterial mode. - Interaction: pressing the mouse buttons will change the diffuse - reflection values. --} - -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { r, g, b :: IORef GLfloat } - -diffuseMaterial :: State -> IO (Color4 GLfloat) -diffuseMaterial state = do - r' <- get (r state) - g' <- get (g state) - b' <- get (b state) - return $ Color4 r' g' b' 1 - -makeState :: IO State -makeState = do - r' <- newIORef 0.5 - g' <- newIORef 0.5 - b' <- newIORef 0.5 - return $ State { r = r', g = g', b = b' } - --- Initialize material property, light source, lighting model, --- and depth buffer. -myInit :: State -> IO () -myInit state = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Smooth - depthFunc $= Just Less - dm <- diffuseMaterial state - materialDiffuse Front $= dm - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 25 - position (Light 0) $= Vertex4 1 1 1 0 - lighting $= Enabled - light (Light 0) $= Enabled - colorMaterial $= Just (Front, Diffuse) - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - renderObject Solid (Sphere' 1 20 16) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-1.5) 1.5 (-1.5 * hf/wf) (1.5 * hf/wf) (-10) 10 - else ortho (-1.5 * wf/hf) (1.5 * wf/hf) (-1.5) 1.5 (-10) 10 - matrixMode $= Modelview 0 - loadIdentity - -keyboardMouse :: State -> KeyboardMouseCallback -keyboardMouse state (MouseButton button) Down _ _ = case button of - LeftButton -> update r - MiddleButton -> update g - RightButton -> update b - _ -> return () - where update component = do - component state $~ inc - dm <- diffuseMaterial state - color dm - postRedisplay Nothing - inc x = let s = x + 0.1 in if s > 1 then 0 else s -keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess -keyboardMouse _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - state <- makeState - myInit state - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboardMouse state) - mainLoop diff --git a/examples/RedBook/ColorMatrix.hs b/examples/RedBook/ColorMatrix.hs deleted file mode 100644 --- a/examples/RedBook/ColorMatrix.hs +++ /dev/null @@ -1,65 +0,0 @@ -{- - ColorMatrix.hs (adapted from colormatrix.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program uses the color matrix to exchange the color channels of an image. - - Red -> Green - Green -> Blue - Blue -> Red --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT -import ReadImage - -myInit :: IO () -myInit = do - m <- newMatrix ColumnMajor [ 0, 1, 0, 0, - 0, 0, 1, 0, - 1, 0, 0, 0, - 0, 0, 0, 1 ] - rowAlignment Unpack $= 1 - clearColor $= Color4 0 0 0 0 - matrixMode $= Color - matrix Nothing $= (m :: GLmatrix GLfloat) - matrixMode $= Modelview 0 - -display :: Size -> PixelData a -> DisplayCallback -display size pixels = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - rasterPos2i (Vertex2 1 1) - drawPixels size pixels - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, args) <- getArgsAndInitialize - (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= size - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display size pixels - mainLoop diff --git a/examples/RedBook/ColorTable.hs b/examples/RedBook/ColorTable.hs deleted file mode 100644 --- a/examples/RedBook/ColorTable.hs +++ /dev/null @@ -1,62 +0,0 @@ -{- - ColorTable.hs (adapted from colortable.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Invert a passed block of pixels. This program illustrates the use of the - colorTable function. --} - -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT -import ReadImage - -myInit :: IO () -myInit = do - rowAlignment Unpack $= 1 - clearColor $= Color4 0 0 0 0 - -- Set up an inverse color table - let tableSize = 256 - t = fromIntegral (tableSize - 1) :: GLubyte - withArray [ Color3 i i i | i <- [ t, t - 1 .. 0 ] ] $ \buf -> - colorTable NoProxy ColorTable RGB' tableSize (PixelData RGB UnsignedByte buf) - colorTableStage ColorTableStage $= Enabled - -display :: Size -> PixelData a -> DisplayCallback -display size pixels = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - rasterPos2i (Vertex2 1 1) - drawPixels size pixels - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, args) <- getArgsAndInitialize - (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= size - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display size pixels - mainLoop diff --git a/examples/RedBook/Combiner.hs b/examples/RedBook/Combiner.hs deleted file mode 100644 --- a/examples/RedBook/Combiner.hs +++ /dev/null @@ -1,236 +0,0 @@ -{- - Combiner.hs (adapted from combiner.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program renders a variety of quads showing different effects of - texture combiner functions. - - The first row renders an untextured polygon (so you can compare the - fragment colors) and then the 2 textures. - - The second row shows several different combiner functions on a single - texture: replace, modulate, add, add-signed, and subtract. - - The third row shows the interpolate combiner function on a single texture - with a constant color/alpha value, varying the amount of interpolation. - - The fourth row uses multitexturing with two textures and different - combiner functions. - - The fifth row are some combiner experiments: using the scaling factor and - reversing the order of subtraction for a combination function. --} - -import Data.Bits ( (.&.) ) -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Create checkerboard image -imageSize :: TextureSize2D -imageSize = TextureSize2D 8 8 - -makeImage :: TextureSize2D -> (GLsizei -> GLsizei -> Color4 GLubyte) - -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () -makeImage (TextureSize2D w h) f act = - withArray [ f i j | - i <- [ 0 .. w - 1 ], - j <- [ 0 .. h - 1 ] ] $ - act . PixelData RGBA UnsignedByte - -myInit :: IO (TextureObject, TextureObject, DisplayList) -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Smooth - - rowAlignment Unpack $= 1 - - [texName0, texName1] <- genObjectNames 2 - - textureBinding Texture2D $= Just texName0 - textureWrapMode Texture2D S $= (Repeated, Repeat) - textureWrapMode Texture2D T $= (Repeated, Repeat) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - -- horiz b & w stripes - makeImage imageSize (\i _ -> let c = if i .&. 2 == 0 then 255 else 0 in Color4 c c c 255) $ - texImage2D Nothing NoProxy 0 RGBA' imageSize 0 - - textureBinding Texture2D $= Just texName1 - textureWrapMode Texture2D S $= (Repeated, Repeat) - textureWrapMode Texture2D T $= (Repeated, Repeat) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - textureFunction $= Decal - -- wider vertical 50% cyan and black stripes - makeImage imageSize (\_ j -> let c = if j .&. 4 /= 0 then 128 else 0 in Color4 0 c c 255) $ - texImage2D Nothing NoProxy 0 RGBA' imageSize 0 - - -- smooth-shaded polygon with multiple texture coordinates - let vert :: TexCoord2 GLfloat -> Color3 GLfloat -> Vertex3 GLfloat -> IO () - vert t c v = do - multiTexCoord (TextureUnit 0) t - multiTexCoord (TextureUnit 1) t - color c - vertex v - - dl <- defineNewList Compile $ - renderPrimitive Quads $ do - vert (TexCoord2 0 0) (Color3 0.5 1 0.25) (Vertex3 0 0 0) - vert (TexCoord2 0 2) (Color3 1 1 1 ) (Vertex3 0 1 0) - vert (TexCoord2 2 2) (Color3 1 1 1 ) (Vertex3 1 1 0) - vert (TexCoord2 2 0) (Color3 1 0.5 0.25) (Vertex3 1 0 0) - - return (texName0, texName1, dl) - -display :: (TextureObject, TextureObject, DisplayList) -> DisplayCallback -display (texName0, texName1, dl) = do - clear [ ColorBuffer ] - - let drawAt :: GLfloat -> GLfloat -> IO () - drawAt x y = preservingMatrix $ do - translate (Vector3 x y 0) - callList dl - - -- untextured polygon -- see the "fragment" colors - texture Texture2D $= Disabled - drawAt 0 5 - - texture Texture2D $= Enabled - -- draw ordinary textured polys; 1 texture unit; combine mode disabled - textureFunction $= Modulate - textureBinding Texture2D $= Just texName0 - drawAt 1 5 - - textureBinding Texture2D $= Just texName1 - drawAt 2 5 - - -- different combine modes enabled; 1 texture unit - -- defaults are: - -- argRGB Arg0 $= Arg SrcColor CurrentUnit - -- argRGB Arg1 $= Arg SrcColor Previous - - textureBinding Texture2D $= Just texName0 - textureFunction $= Combine - combineRGB $= Replace' - argRGB Arg0 $= Arg SrcColor CurrentUnit - drawAt 1 4 - - combineRGB $= Modulate' - argRGB Arg1 $= Arg SrcColor Previous - drawAt 2 4 - - combineRGB $= AddUnsigned' - drawAt 3 4 - - combineRGB $= AddSigned - drawAt 4 4 - - combineRGB $= Subtract - drawAt 5 4 - - -- interpolate combine with constant color; 1 texture unit - -- use different alpha values for constant color - -- defaults are: - -- argRGB Arg0 $= Arg SrcColor CurrentUnit - -- argRGB Arg1 $= Arg SrcColor Previous - -- argRGB Arg2 $= Arg SrcAlpha Constant - - constantColor $= Color4 0 0 0 0.2 - textureBinding Texture2D $= Just texName0 - textureFunction $= Combine - combineRGB $= Interpolate - argRGB Arg0 $= Arg SrcColor CurrentUnit - argRGB Arg1 $= Arg SrcColor Previous - argRGB Arg2 $= Arg SrcAlpha Constant - drawAt 1 3 - - constantColor $= Color4 0 0 0 0.4 - drawAt 2 3 - - constantColor $= Color4 0 0 0 0.6 - drawAt 3 3 - - constantColor $= Color4 0 0 0 0.8 - drawAt 4 3 - - -- combine textures 0 & 1 - -- defaults are: - -- argRGB Arg0 $= Arg SrcColor CurrentUnit - -- argRGB Arg1 $= Arg SrcColor Previous - - activeTexture $= TextureUnit 0 - texture Texture2D $= Enabled - textureBinding Texture2D $= Just texName0 - textureFunction $= Modulate - - activeTexture $= TextureUnit 1 - texture Texture2D $= Enabled - textureBinding Texture2D $= Just texName1 - textureFunction $= Combine - combineRGB $= Replace' - drawAt 1 2 - - -- try different combiner modes of texture unit 1 - combineRGB $= Modulate' - drawAt 2 2 - - combineRGB $= AddUnsigned' - drawAt 3 2 - - combineRGB $= AddSigned - drawAt 4 2 - - combineRGB $= Subtract - drawAt 5 2 - - -- some experiments - - -- see the effect of rgbScale - rgbScale $= 2 - combineRGB $= Replace' - drawAt 1 1 - - combineRGB $= Modulate' - drawAt 2 1 - rgbScale $= 1 - - -- reverse the order of subtraction Arg1-Arg0 - - textureFunction $= Combine - combineRGB $= Subtract - argRGB Arg0 $= Arg SrcColor Previous - argRGB Arg1 $= Arg SrcColor CurrentUnit - drawAt 5 1 - - activeTexture $= TextureUnit 1 -- deactivate multitexturing - texture Texture2D $= Disabled - activeTexture $= TextureUnit 0 -- activate single texture unit - - flush - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 7 0 7 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 400 400 - initialWindowPosition $= Position 100 100 - createWindow progName - texNamesAndDL <- myInit - displayCallback $= display texNamesAndDL - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/Convolution.hs b/examples/RedBook/Convolution.hs deleted file mode 100644 --- a/examples/RedBook/Convolution.hs +++ /dev/null @@ -1,83 +0,0 @@ -{- - Convolution.hs (adapted from convolution.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Use various 2D convolutions filters to find edges in an image. --} - -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT -import ReadImage - -data Filter = Filter String [GLfloat] - -filterTable :: [(Key,Filter)] -filterTable = [ - (Char 'h', Filter "horizontal" [ 0, -1, 0, - 0, 1, 0, - 0, 0, 0 ]), - - (Char 'v', Filter "vertical" [ 0, 0, 0, - -1, 1, 0, - 0, 0, 0 ]), - - (Char 'l', Filter "laplacian" [ -0.125, -0.125, -0.125, - -0.125, 1.0 , -0.125, - -0.125, -0.125, -0.125 ])] - -setFilter :: Filter -> IO () -setFilter (Filter filterName filterData) = do - putStrLn ("Using the " ++ filterName ++ " filter") - withArray filterData $ \buf -> - convolutionFilter2D Luminance' (Size 3 3) (PixelData Luminance Float buf) - -myInit :: IO () -myInit = do - rowAlignment Unpack $= 1 - clearColor $= Color4 0 0 0 0 - setFilter (snd (head filterTable)) - convolution Convolution2D $= Enabled - -display :: Size -> PixelData a -> DisplayCallback -display size pixels = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - rasterPos2i (Vertex2 1 1) - drawPixels size pixels - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard key Down _ _ = - maybe (return ()) - (\f -> do setFilter f; postRedisplay Nothing) - (lookup key filterTable) -keyboard _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, args) <- getArgsAndInitialize - (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) - initialDisplayMode $= [ SingleBuffered, RGBAMode ] - initialWindowSize $= size - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display size pixels - mainLoop diff --git a/examples/RedBook/Cube.hs b/examples/RedBook/Cube.hs deleted file mode 100644 --- a/examples/RedBook/Cube.hs +++ /dev/null @@ -1,56 +0,0 @@ -{- - Cube.hs (adapted from cube.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates a single modeling transformation, scale and a - single viewing transformation, lookAt. A wireframe cube is rendered. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () - color3f (Color3 1 1 1) - loadIdentity -- clear the matrix - -- viewing transformation - lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) - scalef 1 2 1 -- modeling transformation - renderObject Wireframe (Cube 1) - flush - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - frustum (-1) 1 (-1) 1 1.5 20 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/CubeMap.hs b/examples/RedBook/CubeMap.hs deleted file mode 100644 --- a/examples/RedBook/CubeMap.hs +++ /dev/null @@ -1,118 +0,0 @@ -{- - CubeMap.hs (adapted from CubeMap.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates cube map textures. Six different colored checker - board textures are created and applied to a lit sphere. - - Pressing the 'f' and 'b' keys translate the viewer forward and backward. --} - -import Data.Bits ( (.&.) ) -import Data.IORef ( IORef, newIORef ) -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { zTrans :: IORef GLfloat } - -makeState :: IO State -makeState = do - z <- newIORef 0 - return $ State { zTrans = z } - -imageSize :: TextureSize2D -imageSize = TextureSize2D 4 4 - -withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) - -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () -withCheckImage (TextureSize2D w h) n f act = - withArray [ f c | - i <- [ 0 .. w - 1 ], - j <- [ 0 .. h - 1 ], - let c | (i .&. n) == (j .&. n) = 0 - | otherwise = 255 ] $ - act. PixelData RGBA UnsignedByte - -makeImage :: CubeMapTarget -> (GLubyte -> (Color4 GLubyte)) -> IO () -makeImage target f = - withCheckImage imageSize 0x1 f $ - texImage2D (Just target) NoProxy 0 RGBA' imageSize 0 - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - depthFunc $= Just Less - shadeModel $= Smooth - - rowAlignment Unpack $= 1 - textureWrapMode TextureCubeMap S $= (Repeated, Repeat) - textureWrapMode TextureCubeMap T $= (Repeated, Repeat) - textureWrapMode TextureCubeMap R $= (Repeated, Repeat) - textureFilter TextureCubeMap $= ((Nearest, Nothing), Nearest) - - makeImage TextureCubeMapPositiveX (\c -> Color4 c c c 255) - makeImage TextureCubeMapNegativeX (\c -> Color4 0 c c 255) - makeImage TextureCubeMapPositiveY (\c -> Color4 c c 0 255) - makeImage TextureCubeMapNegativeY (\c -> Color4 255 c c 255) - makeImage TextureCubeMapPositiveZ (\c -> Color4 c 0 c 255) - makeImage TextureCubeMapNegativeZ (\c -> Color4 c c 255 255) - - textureGenMode S $= Just NormalMap - textureGenMode T $= Just NormalMap - textureGenMode R $= Just NormalMap - - textureFunction $= Modulate - - texture TextureCubeMap $= Enabled - lighting $= Enabled - light (Light 0) $= Enabled - autoNormal $= Enabled - normalize $= Enabled - materialDiffuse Front $= Color4 1 1 1 1 - -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - z <- get (zTrans state) - translate (Vector3 0 0 z) - renderObject Solid (Sphere' 5 20 10) - swapBuffers - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 40 (fromIntegral w / fromIntegral h) 1 300 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-20 :: GLfloat)) - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char 'f') Down _ _ = move state (-0.2) -keyboard state (Char 'b') Down _ _ = move state 0.2 -keyboard _ (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ _ = return () - -move :: State -> GLfloat -> IO () -move state inc = do - zTrans state $~ (+ inc) - postRedisplay Nothing - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 400 400 - initialWindowPosition $= Position 50 50 - createWindow progName - state <- makeState - myInit - displayCallback $= display state - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - mainLoop diff --git a/examples/RedBook/DList.hs b/examples/RedBook/DList.hs deleted file mode 100644 --- a/examples/RedBook/DList.hs +++ /dev/null @@ -1,85 +0,0 @@ -{- - DList.hs (adapted from list.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates how to make and execute a - display list. Note that attributes, such as current - color and matrix, are changed. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO DisplayList -myInit = do - [listName] <- genObjectNames 1 - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - vertex2f = vertex :: Vertex2 GLfloat -> IO () - translatef = translate :: Vector3 GLfloat -> IO () - defineList listName Compile $ do - color3f (Color3 1 0 0) -- current color red - renderPrimitive Triangles $ do - vertex2f (Vertex2 0 0) - vertex2f (Vertex2 1 0) - vertex2f (Vertex2 0 1) - translatef (Vector3 1.5 0.0 0.0) -- move position - shadeModel $= Flat - return listName - -drawLine :: IO () -drawLine = do - -- resolve overloading, not needed in "real" programs - let vertex2f = vertex :: Vertex2 GLfloat -> IO () - renderPrimitive Lines $ do - vertex2f (Vertex2 0.0 0.5) - vertex2f (Vertex2 15.0 0.5) - -display :: DisplayList -> DisplayCallback -display listName = do - -- NOTE: The following 'loadIdentity' is missing in the original - -- example, but without it the translatef calls accumulate and - -- the graphics wander out of the window after a few redraws... - loadIdentity - - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - color3f (Color3 0 1 0) -- current color green - sequence_ (replicate 10 (callList listName)) -- draw 10 triangles - drawLine -- is this line green? NO! - -- where is the line drawn? - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho2D 0.0 2.0 (-0.5*hf/wf) (1.5*hf/wf) - else ortho2D 0.0 (2.0*wf/hf) (-0.5) 1.5 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Open window with initial window size, title bar, --- RGBA display mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 650 50 - createWindow progName - listName <- myInit - reshapeCallback $= Just reshape - displayCallback $= display listName - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/DOF.hs b/examples/RedBook/DOF.hs deleted file mode 100644 --- a/examples/RedBook/DOF.hs +++ /dev/null @@ -1,182 +0,0 @@ -{- - DOF.hs (adapted from dof.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates use of the accumulation buffer to create an - out-of-focus depth-of-field effect. The teapots are drawn several times into - the accumulation buffer. The viewing volume is jittered, except at the focal - point, where the viewing volume is at the same position, each time. In this - case, the gold teapot remains in focus. --} - -import Data.List ( genericLength ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a --- gaussian distribution around the origin. Use these to do model jittering for --- scene anti-aliasing and view volume jittering for depth of field effects. Use --- in conjunction with the accwindow routine. -j8 :: [Vector2 GLdouble] -j8 = [ - Vector2 (-0.334818) 0.435331 , - Vector2 0.286438 (-0.393495), - Vector2 0.459462 0.141540 , - Vector2 (-0.414498) (-0.192829), - Vector2 (-0.183790) 0.082102 , - Vector2 (-0.079263) (-0.317383), - Vector2 0.102254 0.299133 , - Vector2 0.164216 (-0.054399) ] - --- The first 6 arguments are identical to the frustum call. pixD is anti-alias --- jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD is --- depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field --- effects. focus is distance from eye to plane in focus. focus must be greater --- than, but not equal to 0. Note that accFrustum calls translate. You will --- probably want to insure that your ModelView matrix has been initialized to --- identity before calling accFrustum. -accFrustum :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble - -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () -accFrustum left right bottom top zNear zFar - (Vector2 pixDx pixDy) (Vector2 eyeDx eyeDy) focus = do - (_, Size w h) <- get viewport - - let xWSize = right - left; - yWSize = top - bottom; - - dx = -(pixDx * xWSize / fromIntegral w + eyeDx * zNear / focus) - dy = -(pixDy * yWSize / fromIntegral h + eyeDy * zNear / focus) - - matrixMode $= Projection - loadIdentity - frustum (left + dx) (right + dx) (bottom + dy) (top + dy) zNear zFar - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 (-eyeDx) (-eyeDy) 0) - --- The first 4 arguments are identical to the perspective call. pixD is --- anti-alias jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD --- is depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field --- effects. focus is distance from eye to plane in focus. focus must be greater --- than, but not equal to 0. Note that accPerspective calls accFrustum. -accPerspective :: GLdouble -> GLdouble -> GLdouble -> GLdouble - -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () -accPerspective fovY aspect zNear zFar pixD eyeD focus = do - let fov2 = ((fovY * pi) / 180) / 2 - - top = zNear / (cos fov2 / sin fov2) - bottom = -top - - right = top * aspect - left = -right - - accFrustum left right bottom top zNear zFar pixD eyeD focus - -myInit :: IO DisplayList -myInit = do - ambient (Light 0) $= Color4 0 0 0 1 - diffuse (Light 0) $= Color4 1 1 1 1 - position (Light 0) $= Vertex4 0 3 3 0 - - lightModelAmbient $= Color4 0.2 0.2 0.2 1 - lightModelLocalViewer $= Disabled - - frontFace $= CW - lighting $= Enabled - light (Light 0) $= Enabled - autoNormal $= Enabled - normalize $= Enabled - depthFunc $= Just Less - - clearColor $= Color4 0 0 0 0 - clearAccum $= Color4 0 0 0 0 - -- make teapot display list - defineNewList Compile $ - renderObject Solid (Teapot 0.5) - --- Move object into position, specify the material properties, draw a teapot. -renderTeapot :: DisplayList -> Vector3 GLfloat -> Color4 GLfloat - -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> IO () -renderTeapot teapotList pos amb dif spec shine = - preservingMatrix $ do - translate pos - materialAmbient Front $= amb - materialDiffuse Front $= dif - materialSpecular Front $= spec - materialShininess Front $= shine * 128 - callList teapotList - --- display draws 5 teapots into the accumulation buffer several times; each time --- with a jittered perspective. The focal point is at z = 5.0, so the gold --- teapot will stay in focus. The amount of jitter is adjusted by the magnitude --- of the accPerspective jitter; in this example, 0.33. In this example, the --- teapots are drawn 8 times. -display :: DisplayList -> DisplayCallback -display teapotList = do - (_, Size w h) <- get viewport - clear [ AccumBuffer ] - - flip mapM_ j8 $ \(Vector2 x y) -> do - clear [ ColorBuffer, DepthBuffer ] - accPerspective 45 (fromIntegral w / fromIntegral h) 1 15 - (Vector2 0 0) (Vector2 (0.33 * x) (0.33 * y)) 5 - - -- ruby, gold, silver, emerald, and cyan teapots - renderTeapot teapotList - (Vector3 (-1.1) (-0.5) (-4.5)) - (Color4 0.1745 0.01175 0.01175 1) - (Color4 0.61424 0.04136 0.04136 1) - (Color4 0.727811 0.626959 0.626959 1) - 0.6 - renderTeapot teapotList - (Vector3 (-0.5) (-0.5) (-5.0)) - (Color4 0.24725 0.1995 0.0745 1) - (Color4 0.75164 0.60648 0.22648 1) - (Color4 0.628281 0.555802 0.366065 1) - 0.4 - renderTeapot teapotList - (Vector3 0.2 (-0.5) (-5.5)) - (Color4 0.19225 0.19225 0.19225 1) - (Color4 0.50754 0.50754 0.50754 1) - (Color4 0.508273 0.508273 0.508273 1) - 0.4 - renderTeapot teapotList - (Vector3 1.0 (-0.5) (-6.0)) - (Color4 0.0215 0.1745 0.0215 1) - (Color4 0.07568 0.61424 0.07568 1) - (Color4 0.633 0.727811 0.633 1) - 0.6 - renderTeapot teapotList - (Vector3 1.8 (-0.5) (-6.5)) - (Color4 0.0 0.1 0.06 1) - (Color4 0.0 0.50980392 0.50980392 1) - (Color4 0.50196078 0.50196078 0.50196078 1) - 0.25 - accum Accum (recip (genericLength j8)) - - accum Return 1 - flush - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Be certain you request an accumulation buffer. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ] - initialWindowSize $= Size 400 400 - initialWindowPosition $= Position 100 100 - createWindow progName - teapotList <- myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display teapotList - mainLoop diff --git a/examples/RedBook/Data/leeds.bin b/examples/RedBook/Data/leeds.bin deleted file mode 100644 Binary files a/examples/RedBook/Data/leeds.bin and /dev/null differ diff --git a/examples/RedBook/Double.hs b/examples/RedBook/Double.hs deleted file mode 100644 --- a/examples/RedBook/Double.hs +++ /dev/null @@ -1,76 +0,0 @@ -{- - Double.hs (adapted from double.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This is a simple double buffered program. - Pressing the left mouse button rotates the rectangle. - Pressing the middle mouse button stops the rotation. --} - -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { spin :: IORef GLfloat } - -makeState :: IO State -makeState = do - s <- newIORef 0 - return $ State { spin = s } - -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer ] - preservingMatrix $ do - s <- get (spin state) - rotate s (Vector3 0 0 1) - color (Color3 1 1 1 :: Color3 GLfloat) - rect (Vertex2 (-25) (-25)) (Vertex2 25 25 :: Vertex2 GLfloat) - swapBuffers - -spinDisplay :: State -> IdleCallback -spinDisplay state = do - let wrap n s = if s > n then s - n else s - spin state $~ (wrap 360 . (+ 2)) - postRedisplay Nothing - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho (-50) 50 (-50) 50 (-1) 1 - matrixMode $= Modelview 0 - loadIdentity - -keyboardMouse :: State -> KeyboardMouseCallback -keyboardMouse state (MouseButton b) Down _ _ = - idleCallback $= case b of - LeftButton -> Just (spinDisplay state) - _ -> Nothing --- ESC not handled in the original example, but useful nevertheless -keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess -keyboardMouse _ _ _ _ _ = return () - --- Request double buffer display mode. --- Register mouse input callback functions -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ DoubleBuffered, RGBMode ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - createWindow progName - state <- makeState - myInit - displayCallback $= display state - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboardMouse state) - mainLoop diff --git a/examples/RedBook/DrawF.hs b/examples/RedBook/DrawF.hs deleted file mode 100644 --- a/examples/RedBook/DrawF.hs +++ /dev/null @@ -1,62 +0,0 @@ -{- - DrawF.hs (adapted from drawf.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Draws the bitmapped letter F on the screen (several times). - This demonstrates use of the bitmap call. --} - -import Foreign ( Ptr, newArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO (Ptr GLubyte) -myInit = do - rowAlignment Unpack $= 1 - clearColor $= Color4 0 0 0 0 - newArray [ - 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, - 0xff, 0x00, 0xff, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, - 0xff, 0xc0, 0xff, 0xc0 ] - -display :: Ptr GLubyte -> DisplayCallback -display rasters = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - color3f (Color3 1 1 1) - rasterPos2i (Vertex2 20 20) - sequence_ $ replicate 3 $ - bitmap (Size 10 12) (Vertex2 0 0) (Vector2 11 0) rasters - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop --- Open window with initial window size, title bar, --- RGBA display mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 100 100 - initialWindowPosition $= Position 100 100 - createWindow progName - rasters <- myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display rasters - mainLoop diff --git a/examples/RedBook/Feedback.hs b/examples/RedBook/Feedback.hs deleted file mode 100644 --- a/examples/RedBook/Feedback.hs +++ /dev/null @@ -1,77 +0,0 @@ -{- - Feedback.hs (adapted from feedback.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates use of OpenGL feedback. First, a lighting - environment is set up and a few lines are drawn. Then feedback mode is - entered, and the same lines are drawn. The results in the feedback buffer are - printed. --} - -import Control.Monad ( when ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Initialize lighting. -myInit :: IO () -myInit = do - lighting $= Enabled - light (Light 0) $= Enabled - --- Draw a few lines and two points, one of which will be clipped. If in feedback --- mode, a passthrough token is issued between each primitive -drawGeometry :: IO () -drawGeometry = do - mode <- get renderMode - -- resolve overloading, not needed in "real" programs - let normal3f = normal :: Normal3 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - renderPrimitive LineStrip $ do - normal3f (Normal3 0 0 1) - vertex3f (Vertex3 30 30 0) - vertex3f (Vertex3 50 60 0) - vertex3f (Vertex3 70 40 0) - when (mode == Feedback) $ - passThrough (PassThroughValue 1) - renderPrimitive Points $ - vertex3f (Vertex3 (-100) (-100) (-100)) -- will be clipped - when (mode == Feedback) $ - passThrough (PassThroughValue 2) - renderPrimitive Points $ do - normal3f (Normal3 0 0 1) - vertex3f (Vertex3 50 50 0) - flush -- not in original example - -printBuffer :: Maybe [FeedbackToken] -> IO () -printBuffer = maybe (putStrLn "feedback buffer overflow") (mapM_ print) - -display :: DisplayCallback -display = do - matrixMode $= Projection - loadIdentity - ortho 0 100 0 100 0 1 - - clearColor $= Color4 0 0 0 0 - clear [ ColorBuffer ] - drawGeometry - - (_, tokens) <- getFeedbackTokens 1024 ThreeDColor drawGeometry - printBuffer tokens - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 100 100 - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/Fog.hs b/examples/RedBook/Fog.hs deleted file mode 100644 --- a/examples/RedBook/Fog.hs +++ /dev/null @@ -1,90 +0,0 @@ -{- - Fog.hs (adapted from fog.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws 5 red spheres, each at a different z distance from the - eye, in different types of fog. Pressing the f key chooses between 3 types - of fog: exponential, exponential squared, and linear. In this program, there - is a fixed density value, as well as fixed start and end values for the - linear fog. --} - -import Data.Char ( toLower ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - depthFunc $= Just Less - - position (Light 0) $= Vertex4 0.5 0.5 3.0 0.0 - lighting $= Enabled - light (Light 0) $= Enabled - - -- NOTE: The alpha values are missing from fog.c! - materialAmbient Front $= Color4 0.1745 0.01175 0.01175 1.0 - materialDiffuse Front $= Color4 0.61424 0.04136 0.04136 1.0 - materialSpecular Front $= Color4 0.727811 0.626959 0.626959 1.0 - materialShininess Front $= 0.6 * 128 - - fog $= Enabled - let c = Color4 0.5 0.5 0.5 1.0 - fogMode $= Exp 0.35 - fogColor $= c - hint Fog $= DontCare - clearColor $= c - -renderSpehere :: Vector3 GLfloat -> IO () -renderSpehere xyz = - preservingMatrix $ do - translate xyz - renderObject Solid (Sphere' 0.4 16 16) - --- display draws 5 spheres at different z positions. -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - mapM_ renderSpehere [ Vector3 x (-0.5) (-3 - x) | x <- [-2 .. 2] ] - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10.0) 10.0 - else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10.0) 10.0 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char c) Down _ _ = case toLower c of - 'f' -> do - mode <- get fogMode - case mode of - Linear _ _ -> do fogMode $= Exp 0.35; putStrLn "Fog mode is Exp" - Exp _ -> do fogMode $= Exp2 0.35; putStrLn "Fog mode is Exp2" - Exp2 _ -> do fogMode $= Linear 1 5; putStrLn "Fog mode is Linear" - postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, depth buffer, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display - mainLoop diff --git a/examples/RedBook/FogCoord.hs b/examples/RedBook/FogCoord.hs deleted file mode 100644 --- a/examples/RedBook/FogCoord.hs +++ /dev/null @@ -1,122 +0,0 @@ -{- - FogCoord.hs (adapted from fogcoord.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates the use of explicit fog coordinates. You can press - the keyboard and change the fog coordinate value at any vertex. You can also - switch between using explicit fog coordinates and the default fog generation - mode. - - Pressing the 'f' and 'b' keys move the viewer forward and backwards. Pressing - 'c' initiates the default fog generation. Pressing capital 'C' restores - explicit fog coordinates. Pressing '1', '2', '3', '8', '9', and '0' add or - subtract from the fog coordinate values at one of the three vertices of the - triangle. --} - -import Control.Monad ( when ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { f1, f2, f3 :: IORef (FogCoord1 GLfloat) } - -makeState :: IO State -makeState = do - f1' <- newIORef (FogCoord1 1) - f2' <- newIORef (FogCoord1 5) - f3' <- newIORef (FogCoord1 10) - return $ State { f1 = f1', f2 = f2', f3 = f3' } - --- Initialize fog -myInit :: IO () -myInit = do - let theFogColor = Color4 0 0.25 0.25 1 - fog $= Enabled - fogMode $= Exp 0.25 - fogColor $= theFogColor - hint Fog $= DontCare - fogCoordSrc $= FogCoord - clearColor $= theFogColor - -drawTriangle :: State -> (State -> IORef (FogCoord1 GLfloat)) -> Vertex3 GLfloat -> IO () -drawTriangle state f v = do - fc <- get (f state) - fogCoord fc - vertex v - --- display draws a triangle at an angle. -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer ] - - color (Color3 1 0.75 (0 :: GLfloat)) - renderPrimitive Triangles $ do - drawTriangle state f1 (Vertex3 2 (-2) 0 ) - drawTriangle state f2 (Vertex3 (-2) 0 (-5)) - drawTriangle state f3 (Vertex3 0 2 (-10)) - - swapBuffers - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 45 1 0.25 25 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-5 :: GLfloat)) - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case c of - 'c' -> setSrc FragmentDepth - 'C' -> setSrc FogCoord - '1' -> inc f1 0.25 - '2' -> inc f2 0.25 - '3' -> inc f3 0.25 - '8' -> inc f1 (-0.25) - '9' -> inc f2 (-0.25) - '0' -> inc f3 (-0.25) - 'b' -> trans (-0.25) - 'f' -> trans 0.25 - '\27' -> exitWith ExitSuccess - _ -> return () - where setSrc :: FogCoordSrc -> IO () - setSrc s = do - fogCoordSrc $= s - postRedisplay Nothing - - inc :: (State -> IORef (FogCoord1 GLfloat)) -> GLfloat -> IO () - inc f x = do - FogCoord1 oldValue <- get (f state) - let newValue = oldValue + x - when (newValue > 0) $ do - f state $= FogCoord1 newValue - postRedisplay Nothing - - trans :: GLfloat -> IO () - trans x = do - matrixMode $= Modelview 0 - translate (Vector3 0 0 x) - postRedisplay Nothing -keyboard _ _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ DoubleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - createWindow progName - state <- makeState - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - displayCallback $= display state - mainLoop - - diff --git a/examples/RedBook/FogIndex.hs b/examples/RedBook/FogIndex.hs deleted file mode 100644 --- a/examples/RedBook/FogIndex.hs +++ /dev/null @@ -1,76 +0,0 @@ -{- - FogIndex.hs (adapted from fogindex.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws 5 wireframe spheres, each at a different z distance from - the eye, in linear fog. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Initialize color map and fog. Set screen clear color to end of color ramp. -numColors, rampStart :: GLint -numColors = 32 -rampStart = 16 - -myInit :: IO () -myInit = do - depthFunc $= Just Less - - flip mapM_ [ 0 .. numColors - 1 ] $ \i -> do - let shade = fromIntegral (numColors - i) / fromIntegral numColors - colorMapEntry (Index1 (rampStart + i)) $= Color3 shade shade shade - fog $= Enabled - - fogMode $= Linear 1 6 - fogIndex $= Index1 numColors - hint Fog $= Nicest - clearIndex $= Index1 (fromIntegral (numColors + rampStart - 1)) - -renderSpehere :: Vector3 GLfloat -> IO () -renderSpehere xyz = - preservingMatrix $ do - translate xyz - renderObject Wireframe (Sphere' 0.4 16 16) - --- display draws 5 spheres at different z positions. -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - index (Index1 rampStart) - mapM_ renderSpehere [ Vector3 x (-0.5) (-3 - x) | x <- [-2 .. 2] ] - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10.0) 10.0 - else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10.0) 10.0 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, color index --- display mode, depth buffer, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, IndexMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display - mainLoop diff --git a/examples/RedBook/Font.hs b/examples/RedBook/Font.hs deleted file mode 100644 --- a/examples/RedBook/Font.hs +++ /dev/null @@ -1,127 +0,0 @@ -{- - Font.hs (adapted from font.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Draws some text in a bitmapped font. Uses bitmap and other pixel routines. - Also demonstrates use of display lists. --} - -import Control.Monad ( zipWithM_ ) -import Data.List ( genericDrop, genericLength ) -import Foreign.C.String ( castCharToCChar ) -import Foreign.Marshal.Array ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -space :: [GLubyte] -space = [ - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 ] - -letters :: [[GLubyte]] -letters = [ - [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xff, 0xc3, 0xc3, 0xc3, 0x66, 0x3c, 0x18 ], - [ 0x00, 0x00, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ], - [ 0x00, 0x00, 0x7e, 0xe7, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xe7, 0x7e ], - [ 0x00, 0x00, 0xfc, 0xce, 0xc7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc7, 0xce, 0xfc ], - [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0xc0, 0xc0, 0xfc, 0xc0, 0xc0, 0xc0, 0xc0, 0xff ], - [ 0x00, 0x00, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xfc, 0xc0, 0xc0, 0xc0, 0xff ], - [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xcf, 0xc0, 0xc0, 0xc0, 0xc0, 0xe7, 0x7e ], - [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xff, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], - [ 0x00, 0x00, 0x7e, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x7e ], - [ 0x00, 0x00, 0x7c, 0xee, 0xc6, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06 ], - [ 0x00, 0x00, 0xc3, 0xc6, 0xcc, 0xd8, 0xf0, 0xe0, 0xf0, 0xd8, 0xcc, 0xc6, 0xc3 ], - [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0 ], - [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xdb, 0xff, 0xff, 0xe7, 0xc3 ], - [ 0x00, 0x00, 0xc7, 0xc7, 0xcf, 0xcf, 0xdf, 0xdb, 0xfb, 0xf3, 0xf3, 0xe3, 0xe3 ], - [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xe7, 0x7e ], - [ 0x00, 0x00, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ], - [ 0x00, 0x00, 0x3f, 0x6e, 0xdf, 0xdb, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0x66, 0x3c ], - [ 0x00, 0x00, 0xc3, 0xc6, 0xcc, 0xd8, 0xf0, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ], - [ 0x00, 0x00, 0x7e, 0xe7, 0x03, 0x03, 0x07, 0x7e, 0xe0, 0xc0, 0xc0, 0xe7, 0x7e ], - [ 0x00, 0x00, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0xff ], - [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], - [ 0x00, 0x00, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], - [ 0x00, 0x00, 0xc3, 0xe7, 0xff, 0xff, 0xdb, 0xdb, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], - [ 0x00, 0x00, 0xc3, 0x66, 0x66, 0x3c, 0x3c, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3 ], - [ 0x00, 0x00, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3 ], - [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0x60, 0x30, 0x7e, 0x0c, 0x06, 0x03, 0x03, 0xff ]] - -charToGLubyte :: Char -> GLubyte -charToGLubyte = fromIntegral . castCharToCChar - -makeRasterFont :: IO DisplayList -makeRasterFont = do - rowAlignment Unpack $= 1 - - fontDisplayLists@(fontOffset:_) <- genObjectNames 128 - let listsStartingWith ch = genericDrop (charToGLubyte ch) fontDisplayLists - makeLetter dl letter = - defineList dl Compile $ - withArray letter $ - bitmap (Size 8 13) (Vertex2 0 2) (Vector2 10 0) - - zipWithM_ makeLetter (listsStartingWith 'A') letters - makeLetter (head (listsStartingWith ' ')) space - return fontOffset - -myInit :: IO DisplayList -myInit = do - shadeModel $= Flat - makeRasterFont - -printString :: DisplayList -> String -> IO () -printString fontOffset s = - preservingAttrib [ ListAttributes ] $ do - listBase $= fontOffset - withArray (map charToGLubyte s) $ - callLists (genericLength s) UnsignedByte - --- Everything above this line could be in a library --- that defines a font. To make it work, you've got --- to call makeRasterFont before you start making --- calls to printString. -display :: DisplayList -> DisplayCallback -display fontOffset = do - let white = Color3 1 1 1 - - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - color3f white - - rasterPos2i (Vertex2 20 60) - printString fontOffset "THE QUICK BROWN FOX JUMPS" - rasterPos2i (Vertex2 20 40) - printString fontOffset "OVER A LAZY DOG" - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop --- Open window with initial window size, title bar, --- RGBA display mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 300 100 - initialWindowPosition $= Position 100 100 - createWindow progName - fontOffset <- myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display fontOffset - mainLoop diff --git a/examples/RedBook/Hello.hs b/examples/RedBook/Hello.hs deleted file mode 100644 --- a/examples/RedBook/Hello.hs +++ /dev/null @@ -1,55 +0,0 @@ -{- - Hello.hs (adapted from hello.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This is a simple, introductory OpenGL program. --} - -import Graphics.UI.GLUT - -display :: DisplayCallback -display = do - -- clear all pixels - clear [ ColorBuffer ] - - -- draw white polygon (rectangle) with corners at - -- (0.25, 0.25, 0.0) and (0.75, 0.75, 0.0) - color (Color3 1.0 1.0 (1.0 :: GLfloat)) - -- resolve overloading, not needed in "real" programs - let vertex3f = vertex :: Vertex3 GLfloat -> IO () - renderPrimitive Polygon $ mapM_ vertex3f [ - Vertex3 0.25 0.25 0.0, - Vertex3 0.75 0.25 0.0, - Vertex3 0.75 0.75 0.0, - Vertex3 0.25 0.75 0.0] - - -- don't wait! - -- start processing buffered OpenGL routines - flush - -myInit :: IO () -myInit = do - -- select clearing color - clearColor $= Color4 0 0 0 0 - - -- initialize viewing values - matrixMode $= Projection - loadIdentity - ortho 0 1 0 1 (-1) 1 - --- Declare initial window size, position, and display mode (single buffer and --- RGBA). Open window with "hello" in its title bar. Call initialization --- routines. Register callback function to display graphics. Enter main loop and --- process events. -main :: IO () -main = do - getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - createWindow "hello" - myInit - displayCallback $= display - mainLoop diff --git a/examples/RedBook/Histogram.hs b/examples/RedBook/Histogram.hs deleted file mode 100644 --- a/examples/RedBook/Histogram.hs +++ /dev/null @@ -1,85 +0,0 @@ -{- - Histogram.hs (adapted from histogram.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Compute the histogram of the image. This program illustrates the use of - the histogram function. --} - -import Control.Monad ( zipWithM_ ) -import Foreign ( allocaArray, peekArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT -import ReadImage - -histogramSize :: Int -histogramSize = 256 -- Must be a power of 2 - -myInit :: IO () -myInit = do - rowAlignment Unpack $= 1 - clearColor $= Color4 0 0 0 0 - - histogram NoProxy $= Just (fromIntegral histogramSize, RGB', PassThrough) - -display :: Size -> PixelData a -> DisplayCallback -display size pixels = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - rasterPos2i (Vertex2 1 1) - drawPixels size pixels - - values <- allocaArray histogramSize $ \buf -> do - -- Note: The example in the Red Book uses GL_UNSIGNED_SHORT here, - -- but we are more honest by using Short... - getHistogram Reset (PixelData RGB Short buf) - peekArray histogramSize buf - - -- Plot histogram - zipWithM_ (plotHistogram values) - [ Color3 1 0 0, Color3 0 1 0, Color3 0 0 1 ] - [\(Color3 r _ _) -> r, \(Color3 _ g _) -> g, \(Color3 _ _ b) -> b ] - flush - -plotHistogram :: - [Color3 GLshort] -> Color3 GLfloat -> (Color3 GLshort -> GLshort) -> IO () -plotHistogram values c selectComponent = - renderPrimitive LineStrip $ do - color c - zipWithM_ (\i h -> vertex (Vertex2 i (selectComponent h))) [ 0 .. ] values - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho 0 (fromIntegral histogramSize) 0 10000 (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char 's') Down _ _ = do - Just (width, format, sink) <- get (histogram NoProxy) - let newSink = if sink == Sink then PassThrough else Sink - histogram NoProxy $= Just (width, format, newSink) - postRedisplay Nothing -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, args) <- getArgsAndInitialize - (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= size - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display size pixels - mainLoop diff --git a/examples/RedBook/Image.hs b/examples/RedBook/Image.hs deleted file mode 100644 --- a/examples/RedBook/Image.hs +++ /dev/null @@ -1,116 +0,0 @@ -{- - Image.hs (adapted from image.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates drawing pixels and shows the effect of - drawPixels, copyPixels, and pixelZoom. - - Interaction: moving the mouse while pressing the mouse button will copy - the image in the lower-left corner of the window to the mouse position, - using the current pixel zoom factors. There is no attempt to prevent you - from drawing over the original image. If you press the 'r' key, the - original image and zoom factors are reset. If you press the 'z' or 'Z' - keys, you change the zoom factors. --} - -import Data.Bits ( (.&.) ) -import Data.IORef ( IORef, newIORef ) -import Foreign ( newArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { zoomFactor :: IORef GLfloat } - -makeState :: IO State -makeState = do - z <- newIORef 1 - return $ State { zoomFactor = z } - --- Create checkerboard image -checkImageSize :: Size -checkImageSize = Size 64 64 - -type Image = PixelData (Color3 GLubyte) - -makeCheckImage :: Size -> GLsizei -> (GLubyte -> (Color3 GLubyte)) -> IO Image -makeCheckImage (Size w h) n f = - fmap (PixelData RGB UnsignedByte) $ - newArray [ f c | - i <- [ 0 .. w - 1 ], - j <- [ 0 .. h - 1 ], - let c | (i .&. n) == (j .&. n) = 0 - | otherwise = 255 ] - -myInit :: IO Image -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - rowAlignment Unpack $= 1 - makeCheckImage checkImageSize 0x8 (\c -> Color3 c c c) - -display :: Image -> DisplayCallback -display pixelData = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - rasterPos2i (Vertex2 0 0) - drawPixels checkImageSize pixelData - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 (fromIntegral w) 0 (fromIntegral h) - matrixMode $= Modelview 0 - loadIdentity - -motion :: State -> MotionCallback -motion state (Position x y) = do - Size _ height <- get windowSize - let screenY = fromIntegral height - y - -- resolve overloading, not needed in "real" programs - let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - rasterPos2i (Vertex2 x screenY) - z <- get (zoomFactor state) - pixelZoom $= (z, z) - copyPixels (Position 0 0) checkImageSize CopyColor - pixelZoom $= (1, 1) - flush - -resetZoomFactor :: State -> IO () -resetZoomFactor state = do - zoomFactor state $= 1.0 - postRedisplay Nothing - putStrLn "zoomFactor reset to 1.0" - -incZoomFactor :: State -> GLfloat -> IO () -incZoomFactor state inc = do - zoomFactor state $~! (max 0.5 . min 3.0 . (+ inc)) - get (zoomFactor state) >>= putStrLn . ("zoomFactor is now " ++) . show - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char 'r') Down _ _ = resetZoomFactor state -keyboard state (Char 'R') Down _ _ = resetZoomFactor state -keyboard state (Char 'z') Down _ _ = incZoomFactor state 0.5 -keyboard state (Char 'Z') Down _ _ = incZoomFactor state (-0.5) -keyboard _ (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - createWindow progName - state <- makeState - checkImage <- myInit - displayCallback $= display checkImage - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - motionCallback $= Just (motion state) - mainLoop diff --git a/examples/RedBook/Light.hs b/examples/RedBook/Light.hs deleted file mode 100644 --- a/examples/RedBook/Light.hs +++ /dev/null @@ -1,62 +0,0 @@ -{- - Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates the use of the OpenGL lighting model. A sphere - is drawn using a grey material characteristic. A single light source - illuminates the object. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Smooth - - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 50 - position (Light 0) $= Vertex4 1 1 1 0 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - renderObject Solid (Sphere' 1 20 16) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-1.5) 1.5 (-1.5 * hf/wf) (1.5 * hf/wf) (-10) 10 - else ortho (-1.5 * wf/hf) (1.5 * wf/hf) (-1.5) 1.5 (-10) 10 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/Lines.hs b/examples/RedBook/Lines.hs deleted file mode 100644 --- a/examples/RedBook/Lines.hs +++ /dev/null @@ -1,88 +0,0 @@ -{- - Lines.hs (adapted from lines.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates geometric primitives and their attributes. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -drawOneLine :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO () -drawOneLine p1 p2 = renderPrimitive Lines $ do vertex p1; vertex p2 - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - -- select white for all lines - color (Color3 1.0 1.0 1.0 :: Color3 GLfloat) - - -- in 1st row, 3 lines, each with a different stipple - lineStipple $= Just (1, 0x0101) -- dotted - drawOneLine (Vertex2 50 125) (Vertex2 150 125) - lineStipple $= Just (1, 0x00FF) -- dashed - drawOneLine (Vertex2 150 125) (Vertex2 50 125) - lineStipple $= Just (1, 0x1C47) -- dash/dot/dash - drawOneLine (Vertex2 250 125) (Vertex2 350 125) - - -- in 2nd row, 3 wide lines, each with different stipple - lineWidth $= 5.0 - lineStipple $= Just (1, 0x0101) -- dotted - drawOneLine (Vertex2 50 100) (Vertex2 150 100) - lineStipple $= Just (1, 0x00FF) -- dashed - drawOneLine (Vertex2 150 100) (Vertex2 250 100) - lineStipple $= Just (1, 0x1C47) -- dash/dot/dash - drawOneLine (Vertex2 250 100) (Vertex2 350 100) - lineWidth $= 1.0 - - -- in 3rd row, 6 lines, with dash/dot/dash stipple - -- as part of a single connected line strip - lineStipple $= Just (1, 0x1C47) -- dash/dot/dash - renderPrimitive LineStrip $ mapM_ vertex [ Vertex2 (50+(i*50)) (75 :: GLint) | i <- [0..6] ] - - -- in 4th row, 6 independent lines with same stipple - sequence_ [ drawOneLine (Vertex2 (50+( i *50)) 50) - (Vertex2 (50+((i+1)*50)) 50) | i <- [0..5] ] - - -- in 5th row, 1 line, with dash/dot/dash stipple - -- and a stipple repeat factor of 5 - lineStipple $= Just (5, 0x1C47) -- dash/dot/dash - drawOneLine (Vertex2 50 25) (Vertex2 350 25) - - lineStipple $= Nothing - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 (fromIntegral w) 0 (fromIntegral h) - -- the following line is not in the original example, but it's good style... - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Request double buffer display mode. --- Register mouse input callback functions -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 400 150 - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/MVArray.hs b/examples/RedBook/MVArray.hs deleted file mode 100644 --- a/examples/RedBook/MVArray.hs +++ /dev/null @@ -1,87 +0,0 @@ -{- - MVArray.hs (adapted from mvarray.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates multiple vertex arrays, specifically the OpenGL - routine multiDrawElements. --} - -import Control.Monad ( unless ) -import Data.List ( genericLength ) -import Foreign ( Storable, Ptr, newArray ) -import System.Exit ( exitFailure, exitWith, ExitCode(..) ) -import Graphics.UI.GLUT - -data MultiDrawInfo a = MultiDrawInfo (Ptr GLsizei) (Ptr (Ptr a)) GLsizei - -makeMultiDrawInfo :: Storable a => [[a]] -> IO (MultiDrawInfo a) -makeMultiDrawInfo indicesLists = do - count <- newArray $ map genericLength indicesLists - indices <- newArray =<< mapM newArray indicesLists - return $ MultiDrawInfo count indices (genericLength indicesLists) - -setupPointer :: IO () -setupPointer = do - clientState VertexArray $= Enabled - vertices <- newArray ([ - Vertex2 25 25, - Vertex2 75 75, - Vertex2 100 125, - Vertex2 150 75, - Vertex2 200 175, - Vertex2 250 150, - Vertex2 300 125, - Vertex2 100 200, - Vertex2 150 250, - Vertex2 200 225, - Vertex2 250 300, - Vertex2 300 250 ] :: [Vertex2 GLint]) - arrayPointer VertexArray $= VertexArrayDescriptor 2 Int 0 vertices - -myInit :: IO (MultiDrawInfo GLubyte) -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Smooth - setupPointer - makeMultiDrawInfo [ [ 0, 1, 2, 3, 4, 5, 6 ], - [ 1, 7, 8, 9, 10, 11 ] ] - -display :: MultiDrawInfo GLubyte -> DisplayCallback -display (MultiDrawInfo count indices primCount) = do - clear [ ColorBuffer ] - color (Color3 1 1 1 :: Color3 GLfloat) - multiDrawElements LineStrip count UnsignedByte indices primCount - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 (fromIntegral w) 0 (fromIntegral h) - -- the following line is not in the original example, but it's good style... - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 350 350 - initialWindowPosition $= Position 100 100 - createWindow progName - -- we have to do this *after* createWindow, otherwise we have no OpenGL context - exts <- get glExtensions - unless ("GL_EXT_multi_draw_arrays" `elem` exts) $ do - putStrLn "Sorry, this demo requires the GL_EXT_multi_draw_arrays extension." - exitFailure - multiDrawInfo <- myInit - displayCallback $= display multiDrawInfo - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/Material.hs b/examples/RedBook/Material.hs deleted file mode 100644 --- a/examples/RedBook/Material.hs +++ /dev/null @@ -1,149 +0,0 @@ -{- - Material.hs (adapted from material.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates the use of the GL lighting model. Several - objects are drawn using different material characteristics. A single - light source illuminates the objects. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Initialize z-buffer, projection matrix, light source, and lighting model. --- Do not specify a material property here. - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0.1 0.1 0 - depthFunc $= Just Less - shadeModel $= Smooth - - ambient (Light 0) $= Color4 0 0 0 1 - diffuse (Light 0) $= Color4 1 1 1 1 - position (Light 0) $= Vertex4 0 3 2 0 - lightModelAmbient $= Color4 0.4 0.4 0.4 1 - lightModelLocalViewer $= Disabled - - lighting $= Enabled - light (Light 0) $= Enabled - --- Draw twelve spheres in 3 rows with 4 columns. --- The spheres in the first row have materials with no ambient reflection. --- The second row has materials with significant ambient reflection. --- The third row has materials with colored ambient reflection. --- --- The first column has materials with blue, diffuse reflection only. --- The second column has blue diffuse reflection, as well as specular --- reflection with a low shininess exponent. --- The third column has blue diffuse reflection, as well as specular --- reflection with a high shininess exponent (a more concentrated highlight). --- The fourth column has materials which also include an emissive component. --- --- translate is used to move spheres to their appropriate locations. - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - - let draw :: GLfloat -> GLfloat -> Color4 GLfloat -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> Color4 GLfloat -> IO () - draw row column amb dif spc shi emi = - preservingMatrix $ do - translate (Vector3 (2.5 * (column - 2.5)) (3 * (2 - row)) 0) - materialAmbient Front $= amb - materialDiffuse Front $= dif - materialSpecular Front $= spc - materialShininess Front $= shi - materialEmission Front $= emi - renderObject Solid (Sphere' 1 16 16) - - noMat = Color4 0 0 0 1 - matAmbient = Color4 0.7 0.7 0.7 1 - matAmbientColor = Color4 0.8 0.8 0.2 1 - matDiffuse = Color4 0.1 0.5 0.8 1 - matSpecular = Color4 1 1 1 1 - noShininess = 0 - lowShininess = 5 - highShininess = 100 - matEmission = Color4 0.3 0.2 0.2 0 - - -- draw sphere in first row, first column - -- diffuse reflection only; no ambient or specular - draw 1 1 noMat matDiffuse noMat noShininess noMat - - -- draw sphere in first row, second column - -- diffuse and specular reflection; low shininess; no ambient - draw 1 2 noMat matDiffuse matSpecular lowShininess noMat - - -- draw sphere in first row, third column - -- diffuse and specular reflection; high shininess; no ambient - draw 1 3 noMat matDiffuse matSpecular highShininess noMat - - -- draw sphere in first row, fourth column - -- diffuse reflection; emission; no ambient or specular reflection - draw 1 4 noMat matDiffuse noMat noShininess matEmission - - -- draw sphere in second row, first column - -- ambient and diffuse reflection; no specular - draw 2 1 matAmbient matDiffuse noMat noShininess noMat - - -- draw sphere in second row, second column - -- ambient, diffuse and specular reflection; low shininess - draw 2 2 matAmbient matDiffuse matSpecular lowShininess noMat - - -- draw sphere in second row, third column - -- ambient, diffuse and specular reflection; high shininess - draw 2 3 matAmbient matDiffuse matSpecular highShininess noMat - - -- draw sphere in second row, fourth column - -- ambient and diffuse reflection; emission; no specular - draw 2 4 matAmbient matDiffuse noMat noShininess matEmission - - -- draw sphere in third row, first column - -- colored ambient and diffuse reflection; no specular - draw 3 1 matAmbientColor matDiffuse noMat noShininess noMat - - -- draw sphere in third row, second column - -- colored ambient, diffuse and specular reflection; low shininess - draw 3 2 matAmbientColor matDiffuse matSpecular lowShininess noMat - - -- draw sphere in third row, third column - -- colored ambient, diffuse and specular reflection; high shininess - draw 3 3 matAmbientColor matDiffuse matSpecular highShininess noMat - - -- draw sphere in third row, fourth column - -- colored ambient and diffuse reflection; emission; no specular - draw 3 4 matAmbientColor matDiffuse noMat noShininess matEmission - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h * 2 - then ortho (-6) 6 (-3 * (hf * 2) / wf) (3 * (hf * 2) / wf) (-10) 10 - else ortho (-6 * wf / (hf * 2)) (6 * wf / (hf * 2)) (-3) 3 (-10) 10 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 600 450 - createWindow progName - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/Minmax.hs b/examples/RedBook/Minmax.hs deleted file mode 100644 --- a/examples/RedBook/Minmax.hs +++ /dev/null @@ -1,64 +0,0 @@ -{- - Minmax.hs (adapted from minmax.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Determine the minimum and maximum values of a group of pixels. This - demonstrates use of the minmax function. --} - -import Foreign ( allocaArray, peekArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT -import ReadImage - -myInit :: IO () -myInit = do - rowAlignment Unpack $= 1 - clearColor $= Color4 0 0 0 0 - minmax $= Just (RGB', PassThrough) - -display :: Size -> PixelData a -> DisplayCallback -display size pixels = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () - rasterPos2i (Vertex2 1 1) - drawPixels size pixels - flush - - [Color3 minR minG minB, Color3 maxR maxG maxB] <- allocaArray 2 $ \buf -> do - getMinmax Reset (PixelData RGB UnsignedByte buf) - peekArray 2 buf :: IO [Color3 GLubyte] - putStrLn (" Red : min = " ++ show minR ++ " max = " ++ show maxR) - putStrLn (" Green : min = " ++ show minG ++ " max = " ++ show maxG) - putStrLn (" Blue : min = " ++ show minB ++ " max = " ++ show maxB) - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, args) <- getArgsAndInitialize - (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= size - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display size pixels - mainLoop diff --git a/examples/RedBook/Mipmap.hs b/examples/RedBook/Mipmap.hs deleted file mode 100644 --- a/examples/RedBook/Mipmap.hs +++ /dev/null @@ -1,97 +0,0 @@ -{- - Mipmap.hs (adapted from mipmap.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates using mipmaps for texture maps. To overtly show - the effect of mipmaps, each mipmap reduction level has a solidly colored, - contrasting texture image. Thus, the quadrilateral which is drawn is drawn - with several different colors. --} - -import Control.Monad ( when ) -import Data.Maybe ( isJust, listToMaybe ) -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -makeImage :: Level -> TextureSize2D -> Color4 GLubyte -> IO () -makeImage level size@(TextureSize2D w h) col = - withArray (replicate (fromIntegral (w * h)) col) $ - texImage2D Nothing NoProxy level RGBA' size 0 . PixelData RGBA UnsignedByte - -makeImages :: [Color4 GLubyte] -> IO () -makeImages colors = sequence_ $ zipWith3 makeImage levels sizes colors - where numLevels = length colors - levels = [ 0 .. fromIntegral numLevels - 1 ] - sizes = reverse (take numLevels [ TextureSize2D s s | s <- iterate (* 2) 1 ]) - -myInit :: IO (Maybe TextureObject) -myInit = do - depthFunc $= Just Less - shadeModel $= Flat - - translate (Vector3 0 0 (-3.6 :: GLfloat)) - rowAlignment Unpack $= 1 - - exts <- get glExtensions - mbTexName <- if "GL_EXT_texture_object" `elem` exts - then fmap listToMaybe $ genObjectNames 1 - else return Nothing - when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName - - textureWrapMode Texture2D S $= (Repeated, Repeat) - textureWrapMode Texture2D T $= (Repeated, Repeat) - textureFilter Texture2D $= ((Nearest, Just Nearest), Nearest) - - makeImages [ Color4 255 255 0 255, - Color4 255 0 255 255, - Color4 255 0 0 255, - Color4 0 255 0 255, - Color4 0 0 255 255, - Color4 255 255 255 255 ] - - textureFunction $= Decal - texture Texture2D $= Enabled - return mbTexName - -display :: Maybe TextureObject -> DisplayCallback -display mbTexName = do - clear [ ColorBuffer, DepthBuffer ] - when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName - -- resolve overloading, not needed in "real" programs - let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - renderPrimitive Quads $ do - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 ( -2) (-1) 0 ) - texCoord2f (TexCoord2 0 8); vertex3f (Vertex3 ( -2) 1 0 ) - texCoord2f (TexCoord2 8 8); vertex3f (Vertex3 2000 1 (-6000)) - texCoord2f (TexCoord2 8 0); vertex3f (Vertex3 2000 (-1) (-6000)) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 60 (fromIntegral w / fromIntegral h) 1 30000 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 50 50 - createWindow progName - texName <- myInit - displayCallback $= display texName - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/Model.hs b/examples/RedBook/Model.hs deleted file mode 100644 --- a/examples/RedBook/Model.hs +++ /dev/null @@ -1,86 +0,0 @@ -{- - Model.hs (adapted from model.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates modeling transformations. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - -drawTriangle :: IO () -drawTriangle = do - -- resolve overloading, not needed in "real" programs - let vertex2f = vertex :: Vertex2 GLfloat -> IO () - renderPrimitive LineLoop $ do - vertex2f (Vertex2 0 25 ) - vertex2f (Vertex2 25 (-25)) - vertex2f (Vertex2 (-25) (-25)) - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - translatef = translate :: Vector3 GLfloat -> IO () - scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () - rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () - color3f (Color3 1 1 1) - - loadIdentity - color3f (Color3 1 1 1) - drawTriangle - - lineStipple $= Just (1, 0xF0F0) - loadIdentity - translatef (Vector3 (-20) 0 0) - drawTriangle - - lineStipple $= Just (1, 0xF00F) - loadIdentity - scalef 1.5 0.5 1.0 - drawTriangle - - lineStipple $= Just (1, 0x8888) - loadIdentity - rotatef 90 (Vector3 0 0 1) - drawTriangle - lineStipple $= Nothing - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-50) 50 (-50 * hf/wf) (50 * hf/wf) (-1) 1 - else ortho (-50 * wf/hf) (50 * wf/hf) (-50) 50 (-1) 1 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/MoveLight.hs b/examples/RedBook/MoveLight.hs deleted file mode 100644 --- a/examples/RedBook/MoveLight.hs +++ /dev/null @@ -1,85 +0,0 @@ -{- - MoveLight.hs (adapted from movelight.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates when to issue lighting and transformation - commands to render a model with a light which is moved by a - modeling transformation (rotate or translate). The light position - is reset after the modeling transformation is called. The eye - position does not change. - - A sphere is drawn using a grey material characteristic. A single - light source illuminates the object. - - Interaction: pressing the left mouse button alters the modeling - transformation (x rotation) by 30 degrees. The scene is then - redrawn with the light in a new position. --} - -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { spin :: IORef Int } - -makeState :: IO State -makeState = do - s <- newIORef 0 - return $ State { spin = s } - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Smooth - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) - preservingMatrix $ do - s <- get (spin state) - rotate (fromIntegral s :: GLdouble) (Vector3 1 0 0) - position (Light 0) $= Vertex4 0 0 1.5 1 - translate (Vector3 0 0 1.5 :: Vector3 GLdouble) - lighting $= Disabled - color (Color3 0 1 1 :: Color3 GLfloat) - renderObject Wireframe (Cube 0.1) - lighting $= Enabled - renderObject Solid (Torus 0.275 0.85 8 15) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 40 (fromIntegral w / fromIntegral h) 1 20 - matrixMode $= Modelview 0 - loadIdentity - -keyboardMouse :: State -> KeyboardMouseCallback -keyboardMouse state (MouseButton LeftButton) Down _ _ = do - spin state $~ ((`mod` 360) . (+ 30)) - postRedisplay Nothing -keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess -keyboardMouse _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - state <- makeState - myInit - displayCallback $= display state - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboardMouse state) - mainLoop diff --git a/examples/RedBook/MultiTex.hs b/examples/RedBook/MultiTex.hs deleted file mode 100644 --- a/examples/RedBook/MultiTex.hs +++ /dev/null @@ -1,111 +0,0 @@ -{- - MultiTex.hs (adapted from multitex.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE --} - -import Control.Monad ( unless ) -import Foreign ( withArray ) -import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -specifyTexture :: TextureSize2D -> (GLubyte -> GLubyte -> Color4 GLubyte) -> IO () -specifyTexture size@(TextureSize2D w h) f = - withArray [ f i j | i <- [ 0 .. fromIntegral w - 1 ], - j <- [ 0 .. fromIntegral h - 1] ] $ - texImage2D Nothing NoProxy 0 RGBA' size 0 . PixelData RGBA UnsignedByte - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - depthFunc $= Just Less - rowAlignment Unpack $= 1 - - [texName0, texName1] <- genObjectNames 2 - textureBinding Texture2D $= Just texName0 - -- Note: We use much brighter colors than in the original example where - -- everything was almost black. - specifyTexture (TextureSize2D 32 32) (\i j -> Color4 (i*8) (j*8) ((i*j) `div` 4) 255) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - textureWrapMode Texture2D S $= (Repeated, Repeat) - textureWrapMode Texture2D T $= (Repeated, Repeat) - - textureBinding Texture2D $= Just texName1 - specifyTexture (TextureSize2D 16 16) (\i j -> Color4 255 (i*16) (j*16) 255) - textureFilter Texture2D $= ((Linear', Nothing), Linear') - textureWrapMode Texture2D S $= (Repeated, ClampToEdge) - textureWrapMode Texture2D T $= (Repeated, ClampToEdge) - -- Use the two texture objects to define two texture units - -- for use in multitexturing - activeTexture $= TextureUnit 0 - texture Texture2D $= Enabled - textureBinding Texture2D $= Just texName0 - textureFunction $= Replace - matrixMode $= Texture - loadIdentity - translate (Vector3 0.5 0.5 (0 :: GLfloat)) - rotate (45 :: GLfloat) (Vector3 0 0 1) - translate (Vector3 (-0.5) (-0.5) (0 :: GLfloat)) - matrixMode $= Modelview 0 - activeTexture $= TextureUnit 1 - texture Texture2D $= Enabled - textureBinding Texture2D $= Just texName1 - textureFunction $= Modulate - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - -- resolve overloading, not needed in "real" programs - let multiTexCoord2f = multiTexCoord :: TextureUnit -> TexCoord2 GLfloat -> IO () - vertex2f = vertex :: Vertex2 GLfloat -> IO () - renderPrimitive Triangles $ do - multiTexCoord2f (TextureUnit 0) (TexCoord2 0 0) - multiTexCoord2f (TextureUnit 1) (TexCoord2 1 0) - vertex2f (Vertex2 0 0) - multiTexCoord2f (TextureUnit 0) (TexCoord2 0.5 1) - multiTexCoord2f (TextureUnit 1) (TexCoord2 0.5 0) - vertex2f (Vertex2 50 100) - multiTexCoord2f (TextureUnit 0) (TexCoord2 1 0) - multiTexCoord2f (TextureUnit 1) (TexCoord2 1 1) - vertex2f (Vertex2 100 0) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho2D 0 100 0 (100*hf/wf) - else ortho2D 0 (100*wf/hf) 0 100 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - createWindow progName - -- we have to do this *after* createWindow, otherwise we have no OpenGL context - version <- get (majorMinor glVersion) - unless (version >= (1, 3)) $ do - exts <- get glExtensions - unless ("GL_ARB_multitexture" `elem` exts && -- part of 1.3 core - "GL_EXT_texture_object" `elem` exts) $ do -- part of 1.1 core - putStrLn "Sorry, this demo requires the GL_ARB_multitexture and GL_EXT_texture_object extensions." - exitFailure - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/Multisamp.hs b/examples/RedBook/Multisamp.hs deleted file mode 100644 --- a/examples/RedBook/Multisamp.hs +++ /dev/null @@ -1,137 +0,0 @@ -{- - Multisamp.hs (adapted from multisamp.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws shows how to use multisampling to draw anti-aliased - geometric primitives. The same display list, a pinwheel of triangles and - lines of varying widths, is rendered twice. Multisampling is enabled when the - left side is drawn. Multisampling is disabled when the right side is drawn. - - Pressing the 'b' key toggles drawing of the checkerboard background. - Antialiasing is sometimes easier to see when objects are rendered over a - contrasting background. --} - -import Control.Monad ( when ) -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { bgToggle :: IORef Bool } - -makeState :: IO State -makeState = do - b <- newIORef True - return $ State { bgToggle = b } - -data DisplayLists = DisplayLists { pinwheelList, backgroundList :: DisplayList } - --- Print out state values related to multisampling. Create display list with --- "pinwheel" of lines and triangles. -myInit :: IO DisplayLists -myInit = do - clearColor $= Color4 0 0 0 0 - sb <- get sampleBuffers - putStrLn ("number of sample buffers is " ++ show sb) - s <- get samples - putStrLn ("number of samples is " ++ show s) - - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - vertex2f = vertex :: Vertex2 GLfloat -> IO () - - p <- defineNewList Compile $ do - flip mapM_ [ 0 .. 18 ] $ \i -> - preservingMatrix $ do - rotate (360 * fromIntegral i / 19 :: GLfloat) (Vector3 0 0 1) - color3f (Color3 1 1 1) - lineWidth $= fromIntegral ((i `mod` 3 :: Int) + 1) - renderPrimitive Lines $ do - vertex2f (Vertex2 0.25 0.05) - vertex2f (Vertex2 0.9 0.2) - color3f (Color3 0 1 1) - renderPrimitive Triangles $ do - vertex2f (Vertex2 0.25 0) - vertex2f (Vertex2 0.9 0) - vertex2f (Vertex2 0.875 0.1) - - b <- defineNewList Compile $ do - color3f (Color3 1 0.5 0) - renderPrimitive Quads $ - flip mapM_ [ 0 .. 15 ] $ \i -> - flip mapM_ [ 0 .. 15 ] $ \j -> - when (((i + j) `mod` 2 :: Int) == 0) $ do - let ii = fromIntegral i * 0.25 - jj = fromIntegral j * 0.25 - vertex2f (Vertex2 (-2.0 + ii) (-2.0 + jj)) - vertex2f (Vertex2 (-2.0 + ii) (-1.75 + jj)) - vertex2f (Vertex2 (-1.75 + ii) (-1.75 + jj)) - vertex2f (Vertex2 (-1.75 + ii) (-2.0 + jj)) - - return $ DisplayLists { pinwheelList = p, backgroundList = b } - --- Draw two sets of primitives, so that you can compare the user of --- multisampling against its absence. --- --- This code enables antialiasing and draws one display list and disables and --- draws the other display list -display :: State -> DisplayLists -> DisplayCallback -display state displayLists = do - clear [ ColorBuffer ] - - t <- get (bgToggle state) - when t $ - callList (backgroundList displayLists) - - -- resolve overloading, not needed in "real" programs - let translatef = translate :: Vector3 GLfloat -> IO () - - multisample $= Enabled - preservingMatrix $ do - translatef (Vector3 (-1) 0 0) - callList (pinwheelList displayLists) - - multisample $= Disabled - preservingMatrix $ do - translatef (Vector3 1 0 0) - callList (pinwheelList displayLists) - - swapBuffers - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= 2 * h - then ortho2D (-2) 2 (-2*hf/wf) (2*hf/wf) - else ortho2D (-2*wf/hf) (2*wf/hf) (-2) 2 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case toLower c of - 'b' -> do bgToggle state $~ not; postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ DoubleBuffered, RGBMode, Multisampling ] - initialWindowSize $= Size 600 300 - createWindow progName - state <- makeState - displayLists <- myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - displayCallback $= display state displayLists - mainLoop diff --git a/examples/RedBook/PickDepth.hs b/examples/RedBook/PickDepth.hs deleted file mode 100644 --- a/examples/RedBook/PickDepth.hs +++ /dev/null @@ -1,126 +0,0 @@ -{- - PickDepth.hs (adapted from pickdepth.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Picking is demonstrated in this program. In rendering mode, three - overlapping rectangles are drawn. When the left mouse button is pressed, - selection mode is entered with the picking matrix. Rectangles which are drawn - under the cursor position are "picked." Pay special attention to the depth - value range, which is returned. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - depthFunc $= Just Less - shadeModel $= Flat - depthRange $= (0, 1) -- The default z mapping - --- The nine squares are drawn. Each square is given two names: one for the row --- and the other for the column on the grid. The color of each square is --- determined by its position on the grid, and the value in the board array. --- Note: In contrast to the the original example, we always give names to --- squares, regardless of the render mode. This simplifies the code a bit and --- is even suggested by the Red Book. - --- The three rectangles are drawn, each with a different name. Note that each --- rectangle is drawn with a different z value. Note: In contrast to the the --- original example, we always give names to squares, regardless of the render --- mode. This simplifies the code a bit and is even suggested by the Red Book. -drawRects :: IO () -drawRects = do - -- resolve overloading, not needed in "real" programs - let color3 = color :: Color3 GLfloat -> IO () - vertex3 = vertex :: Vertex3 GLint -> IO () - loadName (Name 1) - renderPrimitive Quads $ do - color3 (Color3 1.0 1.0 0.0) - vertex3 (Vertex3 2 0 0) - vertex3 (Vertex3 2 6 0) - vertex3 (Vertex3 6 6 0) - vertex3 (Vertex3 6 0 0) - loadName (Name 2) - renderPrimitive Quads $ do - color3 (Color3 0.0 1.0 1.0) - vertex3 (Vertex3 3 2 (-1)) - vertex3 (Vertex3 3 8 (-1)) - vertex3 (Vertex3 8 8 (-1)) - vertex3 (Vertex3 8 2 (-1)) - loadName (Name 3) - renderPrimitive Quads $ do - color3 (Color3 1.0 0.0 1.0) - vertex3 (Vertex3 0 2 (-2)) - vertex3 (Vertex3 0 7 (-2)) - vertex3 (Vertex3 5 7 (-2)) - vertex3 (Vertex3 5 2 (-2)) - --- processHits prints the hit records. -processHits :: Maybe[HitRecord] -> IO () -processHits Nothing = putStrLn "selection buffer overflow" -processHits (Just hitRecords) = do - putStrLn ("hits = " ++ show (length hitRecords)) - flip mapM_ hitRecords $ \(HitRecord z1 z2 names) -> do - putStrLn (" number of names for hit = " ++ show (length names)) - putStr (" z1 is " ++ show z1) - putStrLn ("; z2 is " ++ show z2) - putStr " the name is" - sequence_ [ putStr (" " ++ show n) | Name n <- names ] - putChar '\n' - --- pickRects() sets up selection mode, name stack, and projection matrix for --- picking. Then the objects are drawn. - -bufSize :: GLsizei -bufSize = 512 - -pickRects :: KeyboardMouseCallback -pickRects (MouseButton LeftButton) Down _ (Position x y) = do - vp@(_, (Size _ height)) <- get viewport - (_, maybeHitRecords) <- getHitRecords bufSize $ - withName (Name 0) $ do - matrixMode $= Projection - preservingMatrix $ do - loadIdentity - -- create 5x5 pixel picking region near cursor location - pickMatrix (fromIntegral x, fromIntegral height - fromIntegral y) (5, 5) vp - ortho 0 8 0 8 (-0.5) 2.5 - drawRects - flush - processHits maybeHitRecords - postRedisplay Nothing -pickRects (Char '\27') Down _ _ = exitWith ExitSuccess -pickRects _ _ _ _ = return () - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - drawRects - flush - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho 0 8 0 8 (-0.5) 2.5 - matrixMode $= Modelview 0 - loadIdentity - --- Main Loop -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 200 200 - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just pickRects - mainLoop diff --git a/examples/RedBook/PickSquare.hs b/examples/RedBook/PickSquare.hs deleted file mode 100644 --- a/examples/RedBook/PickSquare.hs +++ /dev/null @@ -1,121 +0,0 @@ -{- - PickSquare.hs (adapted from picksquare.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Use of multiple names and picking are demonstrated. A 3x3 grid of squares is - drawn. When the left mouse button is pressed, all squares under the cursor - position have their color changed. --} - -import Data.Array ( Array, listArray, (!) ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -type Board = Array (Int,Int) (IORef Int) - -data State = State { board :: Board } - -makeState :: IO State -makeState = do - refs <- sequence . replicate 9 . newIORef $ 0 - return $ State { board = listArray ((0,0),(2,2)) refs } - --- Clear color value for every square on the board -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - --- The nine squares are drawn. Each square is given two names: one for the row --- and the other for the column on the grid. The color of each square is --- determined by its position on the grid, and the value in the board array. --- Note: In contrast to the the original example, we always give names to --- squares, regardless of the render mode. This simplifies the code a bit and --- is even suggested by the Red Book. -drawSquares :: State -> IO () -drawSquares state = - flip mapM_ [ 0 .. 2 ] $ \i -> do - loadName (Name (fromIntegral i)) - flip mapM_ [ 0 .. 2 ] $ \j -> - withName (Name (fromIntegral j)) $ do - val <- get (board state ! (i,j)) - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - color3f (Color3 (fromIntegral i / 3.0) - (fromIntegral j / 3.0) - (fromIntegral val / 3.0)) - let vertex2i :: Int -> Int -> Vertex2 GLint - vertex2i x y = Vertex2 (fromIntegral x) (fromIntegral y) - rect (vertex2i i j) (vertex2i (i + 1) (j + 1)) - --- processHits prints the hit records and updates the board array. -processHits :: Maybe[HitRecord] -> State -> IO () -processHits Nothing _ = putStrLn "selection buffer overflow" -processHits (Just hitRecords) state = do - putStrLn ("hits = " ++ show (length hitRecords)) - mapM_ (\(HitRecord z1 z2 names) -> do - putStrLn (" number of names for this hit = " ++ show (length names)) - putStr (" z1 is " ++ show z1) - putStrLn ("; z2 is " ++ show z2) - putStr " names are" - sequence_ [ putStr (" " ++ show n) | Name n <- names ] - putChar '\n' - let [i, j] = [ fromIntegral n | Name n <- names ] - (board state ! (i,j)) $~ (\x -> (x + 1) `mod` 3)) - hitRecords - --- pickSquares sets up selection mode, name stack, and projection matrix for --- picking. Then the objects are drawn. - -bufSize :: GLsizei -bufSize = 512 - -pickSquares :: State -> KeyboardMouseCallback -pickSquares state (MouseButton LeftButton) Down _ (Position x y) = do - vp@(_, (Size _ height)) <- get viewport - (_, maybeHitRecords) <- getHitRecords bufSize $ - withName (Name 0) $ do - matrixMode $= Projection - preservingMatrix $ do - loadIdentity - -- create 5x5 pixel picking region near cursor location - pickMatrix (fromIntegral x, fromIntegral height - fromIntegral y) (5, 5) vp - ortho2D 0 3 0 3 - drawSquares state - flush - processHits maybeHitRecords state - postRedisplay Nothing -pickSquares _ (Char '\27') Down _ _ = exitWith ExitSuccess -pickSquares _ _ _ _ _ = return () - -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer ] - drawSquares state - flush - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 3 0 3 - matrixMode $= Modelview 0 - loadIdentity - --- Main Loop -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 100 100 - initialWindowPosition $= Position 100 100 - createWindow progName - state <- makeState - myInit - reshapeCallback $= Just reshape - displayCallback $= display state - keyboardMouseCallback $= Just (pickSquares state) - mainLoop diff --git a/examples/RedBook/Planet.hs b/examples/RedBook/Planet.hs deleted file mode 100644 --- a/examples/RedBook/Planet.hs +++ /dev/null @@ -1,83 +0,0 @@ -{- - Planet.hs (adapted from planet.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program shows how to composite modeling transformations to draw - translated and rotated models. Interaction: pressing the d and y keys - (day and year) alters the rotation of the planet around the sun. --} - -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { year, day :: IORef GLint } - -makeState :: IO State -makeState = do - y <- newIORef 0 - d <- newIORef 0 - return $ State { year = y, day = d } - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - translatef = translate :: Vector3 GLfloat -> IO () - color3f (Color3 1 1 1) - - preservingMatrix $ do - renderObject Wireframe (Sphere' 1 20 16) -- draw sun - y <- get (year state) - rotate (fromIntegral y :: GLfloat) (Vector3 0 1 0) - translatef (Vector3 2 0 0) - d <- get (day state) - rotate (fromIntegral d :: GLfloat) (Vector3 0 1 0) - renderObject Wireframe (Sphere' 0.2 10 8) -- draw smaller planet - - swapBuffers - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 60 (fromIntegral w / fromIntegral h) 1 20 - matrixMode $= Modelview 0 - loadIdentity - lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case c of - 'd' -> update day 10 - 'D' -> update day (-10) - 'y' -> update year 10 - 'Y' -> update year (-10) - '\27' -> exitWith ExitSuccess - _ -> return () - where update angle inc = do - angle state $~ ((`mod` 360) . (+ inc)) - postRedisplay Nothing -keyboard _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ DoubleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - state <- makeState - myInit - displayCallback $= display state - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - mainLoop diff --git a/examples/RedBook/PointP.hs b/examples/RedBook/PointP.hs deleted file mode 100644 --- a/examples/RedBook/PointP.hs +++ /dev/null @@ -1,152 +0,0 @@ -{- - PointP.hs (adapted from pointp.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates point parameters and their effect on point - primitives. 250 points are randomly generated within a 10 by 10 by 40 region, - centered at the origin. In some modes (including the default), points that - are closer to the viewer will appear larger. - - Pressing the 'c', 'l', and 'q' keys switch the point parameters attenuation - mode to constant, linear, or quadratic, respectively. - - Pressing the 'f' and 'b' keys move the viewer forward and backwards. In - either linear or quadratic attenuation mode, the distance from the viewer to - the point will change the size of the point primitive. - - Pressing the '+' and '-' keys will change the current point size. In this - program, the point size is bounded, so it will not get less than 2, nor - greater than the maximum returned by pointSizeRange. --} - -import Control.Monad ( when, unless ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure ) -import System.Random ( randomRIO ) -import Graphics.UI.GLUT - -type Attenuation = (GLfloat,GLfloat,GLfloat) - -constant, linear, quadratic :: Attenuation -constant = (1, 0, 0 ) -linear = (0, 0.12, 0 ) -quadratic = (0, 0, 0.01) - -data State = State { distance :: IORef GLfloat } - -makeState :: IO State -makeState = do - d <- newIORef (-10) - return $ State { distance = d } - --- CFloat has no Random instance, so we go via Float -randomGLfloat :: (GLfloat, GLfloat) -> IO GLfloat -randomGLfloat = fmap floatToGLfloat . randomRIO . fmapPair glFloatToFloat - where fmapPair f (x, y) = (f x, f y) - floatToGLfloat = realToFrac :: Float -> GLfloat - glFloatToFloat = realToFrac :: GLfloat -> Float - -randomColor :: IO (Color3 GLfloat) -randomColor = do - g <- randomGLfloat (0.5, 1) - b <- randomGLfloat (0, 1) - return $ Color3 1 g b - -randomVertex :: IO (Vertex3 GLfloat) -randomVertex = do - x <- randomGLfloat (-5, 5) - y <- randomGLfloat (-5, 5) - z <- randomGLfloat (-5, -45) - return $ Vertex3 x y z - -myInit :: IO DisplayList -myInit = do - pointList <- defineNewList Compile $ - renderPrimitive Points $ - sequence_ $ replicate 250 $ do - color =<< randomColor - vertex =<< randomVertex - - depthFunc $= Just Less - pointSmooth $= Enabled - blend $= Enabled - blendFunc $= (SrcAlpha, OneMinusSrcAlpha) - pointSize $= 7 - - pointDistanceAttenuation $= linear - pointFadeThresholdSize $= 2 - - return pointList - -display :: State -> DisplayList -> DisplayCallback -display state pointList = do - clear [ ColorBuffer, DepthBuffer ] - d <- get (distance state) - loadIdentity - translate (Vector3 0 0 d) - callList pointList - swapBuffers - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 35 1 0.25 200 - matrixMode $= Modelview 0 - -setPointDistanceAttenuation :: Attenuation -> IO () -setPointDistanceAttenuation att = do - pointDistanceAttenuation $= att - postRedisplay Nothing - -incDistance :: State -> GLfloat -> IO () -incDistance state inc = do - distance state $~ (+ inc) - postRedisplay Nothing - -incPointSize :: GLfloat -> IO () -incPointSize inc = do - newPointSize <- fmap (+ inc) $ get pointSize - (_,maxPointSize) <- get pointSizeRange - when (2 <= newPointSize && newPointSize <= maxPointSize) $ do - pointSize $= newPointSize - postRedisplay Nothing - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case c of - 'c' -> setPointDistanceAttenuation constant - 'l' -> setPointDistanceAttenuation linear - 'q' -> setPointDistanceAttenuation quadratic - 'b' -> incDistance state (-0.5) - 'f' -> incDistance state 0.5 - '+' -> incPointSize 1 - '-' -> incPointSize (-1) - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ RGBMode, DoubleBuffered, WithDepthBuffer, Multisampling ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - - -- We have to do this *after* createWindow, otherwise we have no OpenGL - -- context. Note that the original C example simply tests for OpenGL 1.4 at - -- compile time, we do a runtime check for the needed extension. - extensions <- get glExtensions - unless ("GL_ARB_point_parameters" `elem` extensions) $ do - putStrLn "Sorry, this demo requires the GL_ARB_point_parameters extension." - exitFailure - - state <- makeState - pointList <- myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - displayCallback $= display state pointList - mainLoop diff --git a/examples/RedBook/PolyOff.hs b/examples/RedBook/PolyOff.hs deleted file mode 100644 --- a/examples/RedBook/PolyOff.hs +++ /dev/null @@ -1,151 +0,0 @@ -{- - PolyOff.hs (adapted from polyoff.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates polygon offset to draw a shaded polygon and its - wireframe counterpart without ugly visual artifacts ("stitching"). --} - -import Control.Monad ( when ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure ) -import Graphics.UI.GLUT - -data State = State { - spinX, spinY :: IORef GLfloat, - tDist :: IORef GLfloat, - polyFactor :: IORef GLfloat, - polyUnits :: IORef GLfloat - } - -makeState :: IO State -makeState = do - x <- newIORef 0 - y <- newIORef 0 - t <- newIORef 0 - f <- newIORef 1 - u <- newIORef 1 - return $ State { spinX = x, spinY = y, tDist = t, polyFactor = f, polyUnits = u } - --- display draws two spheres, one with a gray, diffuse material, the other --- sphere with a magenta material with a specular highlight. -display :: State -> DisplayList -> DisplayCallback -display state sphereList = do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - t <- get (tDist state) - translate (Vector3 0 0 t) - x <- get (spinX state) - rotate x (Vector3 1 0 0) - y <- get (spinY state) - rotate y (Vector3 0 1 0) - - materialAmbientAndDiffuse Front $= Color4 0.8 0.8 0.8 1 - materialSpecular Front $= Color4 0 0 0 1 - materialShininess Front $= 0 - lighting $= Enabled - light (Light 0) $= Enabled - polygonOffsetFill $= Enabled - f <- get (polyFactor state) - u <- get (polyUnits state) - polygonOffset $= (f, u) - callList sphereList - polygonOffsetFill $= Disabled - - lighting $= Disabled - light (Light 0) $= Disabled - color (Color3 1 1 (1 :: GLfloat)) - polygonMode $= (Line, Line) - callList sphereList - polygonMode $= (Fill, Fill) - - flush - --- specify initial properties --- create display list with sphere --- initialize lighting and depth buffer -gfxinit :: IO DisplayList -gfxinit = do - clearColor $= Color4 0 0 0 1 - - sphereList <- defineNewList Compile $ - renderObject Solid (Sphere' 1 20 12) - - depthFunc $= Just Less - - ambient (Light 0) $= Color4 0 0 0 1 - diffuse (Light 0) $= Color4 1 1 1 1 - specular (Light 0) $= Color4 1 1 1 1 - position (Light 0) $= Vertex4 1 1 1 0 - lightModelAmbient $= Color4 0.2 0.2 0.2 1 - - return sphereList - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 45 (fromIntegral w / fromIntegral h) 1 10 - matrixMode $= Modelview 0 - loadIdentity - lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) - -incSpin :: IORef GLfloat -> IO () -incSpin spinRef = do - let wrap n s = if s > n then s - n else s - spinRef $~ (wrap 360 . (+ 5)) - postRedisplay Nothing - -incDist :: State -> GLfloat -> IO () -incDist state inc = do - newDist <- fmap (+ inc) $ get (tDist state) - when (-5 <= newDist && newDist <= 4) $ do - tDist state $= newDist - postRedisplay Nothing - -incPoly :: String -> IORef GLfloat -> GLfloat -> IO () -incPoly name polyRef inc = do - polyRef $~ (+ inc) - p <- get polyRef - putStrLn (name ++ " is " ++ show p) - postRedisplay Nothing - -keyboardMouse :: State -> KeyboardMouseCallback -keyboardMouse state k Down _ _ = case k of - (MouseButton LeftButton) -> incSpin (spinX state) - (MouseButton MiddleButton) -> incSpin (spinY state) - (MouseButton RightButton) -> exitWith ExitSuccess - (Char 't') -> incDist state 0.5 - (Char 'T') -> incDist state (-0.5) - (Char 'F') -> incPoly "polyFactor" (polyFactor state) 0.1 - (Char 'f') -> incPoly "polyFactor" (polyFactor state) (-0.1) - (Char 'U') -> incPoly "polyUnits" (polyUnits state) 1 - (Char 'u') -> incPoly "polyUnits" (polyUnits state) (-1) - _ -> return () -keyboardMouse _ _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - createWindow progName - - -- we have to do this *after* createWindow, otherwise we have no OpenGL context - version <- get (majorMinor glVersion) - when (version == (1,0)) $ do - putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." - putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," - putStrLn "you may be able to modify this program to make it run." - exitFailure - - state <- makeState - sphereList <- gfxinit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboardMouse state) - displayCallback $= display state sphereList - mainLoop diff --git a/examples/RedBook/Polys.hs b/examples/RedBook/Polys.hs deleted file mode 100644 --- a/examples/RedBook/Polys.hs +++ /dev/null @@ -1,84 +0,0 @@ -{- - Polys.hs (adapted from polys.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates polygon stippling. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -fly :: IO GLpolygonstipple -fly = newPolygonStipple [ - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x03, 0x80, 0x01, 0xC0, 0x06, 0xC0, 0x03, 0x60, - 0x04, 0x60, 0x06, 0x20, 0x04, 0x30, 0x0C, 0x20, - 0x04, 0x18, 0x18, 0x20, 0x04, 0x0C, 0x30, 0x20, - 0x04, 0x06, 0x60, 0x20, 0x44, 0x03, 0xC0, 0x22, - 0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22, - 0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22, - 0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22, - 0x66, 0x01, 0x80, 0x66, 0x33, 0x01, 0x80, 0xCC, - 0x19, 0x81, 0x81, 0x98, 0x0C, 0xC1, 0x83, 0x30, - 0x07, 0xe1, 0x87, 0xe0, 0x03, 0x3f, 0xfc, 0xc0, - 0x03, 0x31, 0x8c, 0xc0, 0x03, 0x33, 0xcc, 0xc0, - 0x06, 0x64, 0x26, 0x60, 0x0c, 0xcc, 0x33, 0x30, - 0x18, 0xcc, 0x33, 0x18, 0x10, 0xc4, 0x23, 0x08, - 0x10, 0x63, 0xC6, 0x08, 0x10, 0x30, 0x0c, 0x08, - 0x10, 0x18, 0x18, 0x08, 0x10, 0x00, 0x00, 0x08] - -halftone :: IO GLpolygonstipple -halftone = newPolygonStipple . take 128 . cycle $ [ - 0xAA, 0xAA, 0xAA, 0xAA, 0x55, 0x55, 0x55, 0x55] - -display :: (GLpolygonstipple, GLpolygonstipple) -> DisplayCallback -display (flyStipple, halftoneStipple) = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - rectf = rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO () - color3f (Color3 1 1 1) - - -- draw one solid, unstippled rectangle, - -- then two stippled rectangles - rectf (Vertex2 25 25) (Vertex2 125 125) - polygonStipple $= Just flyStipple - rectf (Vertex2 125 25) (Vertex2 225 125) - polygonStipple $= Just halftoneStipple - rectf (Vertex2 225 25) (Vertex2 325 125) - polygonStipple $= (Nothing :: Maybe GLpolygonstipple) - - flush - -myInit :: IO (GLpolygonstipple, GLpolygonstipple) -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - flyStipple <- fly - halftoneStipple <- halftone - return (flyStipple, halftoneStipple) - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0.0 (fromIntegral w) 0.0 (fromIntegral h) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 350 150 - createWindow progName - stipples <- myInit - displayCallback $= display stipples - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/Quadric.hs b/examples/RedBook/Quadric.hs deleted file mode 100644 --- a/examples/RedBook/Quadric.hs +++ /dev/null @@ -1,106 +0,0 @@ -{- - Quadric.hs (adapted from quadric.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates the use of the renderQuadric routine. Quadric - objects are created with some quadric properties and errors are reported. - Note that the cylinder has no top or bottom and the circle has a hole in it. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO (DisplayList, DisplayList, DisplayList, DisplayList) -myInit = do - clearColor $= Color4 0 0 0 0 - - materialAmbient Front $= Color4 0.5 0.5 0.5 1 - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 50 - position (Light 0) $= Vertex4 1 1 1 0 - lightModelAmbient $= Color4 0.5 0.5 0.5 1 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - - -- Create 4 display lists, each with a different quadric object. - -- Different drawing styles and surface normal specifications - -- are demonstrated. - -- smooth shaded - dl1 <- newQuadricDL (Just Smooth) FillStyle (Sphere 0.75 15 10) - -- flat shaded - dl2 <- newQuadricDL (Just Flat) FillStyle (Cylinder 0.5 0.3 1 15 5) - -- all polygons wireframe - dl3 <- newQuadricDL Nothing LineStyle (Disk 0.25 1 20 4) - -- boundary only - dl4 <- newQuadricDL Nothing SilhouetteStyle (PartialDisk 0 1 20 4 0 225) - return (dl1, dl2, dl3, dl4) - -newQuadricDL :: QuadricNormal -> QuadricDrawStyle -> QuadricPrimitive -> IO DisplayList -newQuadricDL n s p = - defineNewList Compile $ do - renderQuadric (QuadricStyle n NoTextureCoordinates Outside s) p - reportErrors - -display :: (DisplayList, DisplayList, DisplayList, DisplayList) -> DisplayCallback -display (dl1, dl2, dl3, dl4) = do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - -- resolve overloading, not needed in "real" programs - let translatef = translate :: Vector3 GLfloat -> IO () - rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () - color3f = color :: Color3 GLfloat -> IO () - - lighting $= Enabled - shadeModel $= Smooth - translatef (Vector3 (-1) (-1) 0) - callList dl1 - - shadeModel $= Flat - translatef (Vector3 0 2 0) - preservingMatrix $ do - rotatef 300 (Vector3 1 0 0) - callList dl2 - - lighting $= Disabled - color3f (Color3 0 1 1) - translatef (Vector3 2 (-2) 0) - callList dl3 - - color3f (Color3 1 1 0) - translatef (Vector3 0 2 0) - callList dl4 - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10) 10 - else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10) 10 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - displayLists <- myInit - displayCallback $= display displayLists - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/ReadImage.hs b/examples/RedBook/ReadImage.hs deleted file mode 100644 --- a/examples/RedBook/ReadImage.hs +++ /dev/null @@ -1,65 +0,0 @@ -{- - ReadImage.hs (adapted from readImage.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - Support for reading a file of raw RGB data: - 4 bytes big-endian width - 4 bytes big-endian height - width * height RGB byte triples --} - -module ReadImage ( readImage ) where - -import Data.Word ( Word8, Word32 ) -import Control.Exception ( bracket ) -import Control.Monad ( when ) -import System.IO ( Handle, IOMode(ReadMode), openBinaryFile, hGetBuf, hClose ) -import System.IO.Error ( mkIOError, eofErrorType ) -import Foreign ( Ptr, alloca, mallocBytes, Storable(..) ) -import Graphics.UI.GLUT - --- This is probably overkill, but anyway... -newtype Word32BigEndian = Word32BigEndian Word32 - -word32BigEndianToGLsizei :: Word32BigEndian -> GLsizei -word32BigEndianToGLsizei (Word32BigEndian x) = fromIntegral x - -instance Storable Word32BigEndian where - sizeOf ~(Word32BigEndian x) = sizeOf x - alignment ~(Word32BigEndian x) = alignment x - peek ptr = do - let numBytes = sizeOf (undefined :: Word32BigEndian) - bytes <- mapM (peekByteOff ptr) [ 0 .. numBytes - 1 ] :: IO [Word8] - let value = foldl (\val byte -> val * 256 + fromIntegral byte) 0 bytes - return $ Word32BigEndian value - poke = error "" - --- This is the reason for all this stuff above... -readGLsizei :: Handle -> IO GLsizei -readGLsizei handle = - alloca $ \buf -> do - hGetBufFully handle buf (sizeOf (undefined :: Word32BigEndian)) - fmap word32BigEndianToGLsizei $ peek buf - --- A handy variant of hGetBuf with additional error checking -hGetBufFully :: Handle -> Ptr a -> Int -> IO () -hGetBufFully handle ptr numBytes = do - bytesRead <- hGetBuf handle ptr numBytes - when (bytesRead /= numBytes) $ - ioError $ mkIOError eofErrorType "hGetBufFully" (Just handle) Nothing - --- Closing a file is nice, even when an error occurs during reading. -withBinaryFile :: FilePath -> (Handle -> IO a) -> IO a -withBinaryFile filePath = bracket (openBinaryFile filePath ReadMode) hClose - -readImage :: FilePath -> IO (Size, PixelData a) -readImage filePath = - withBinaryFile filePath $ \handle -> do - width <- readGLsizei handle - height <- readGLsizei handle - let numBytes = fromIntegral (3 * width * height) - buf <- mallocBytes numBytes - hGetBufFully handle buf numBytes - return (Size width height, PixelData RGB UnsignedByte buf) diff --git a/examples/RedBook/Robot.hs b/examples/RedBook/Robot.hs deleted file mode 100644 --- a/examples/RedBook/Robot.hs +++ /dev/null @@ -1,89 +0,0 @@ -{- - Robot.hs (adapted from robot.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program shows how to composite modeling transformations to draw - translated and rotated hierarchical models. Interaction: pressing the s - and e keys (shoulder and elbow) alters the rotation of the robot arm. --} - -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { shoulder, elbow :: IORef GLint } - -makeState :: IO State -makeState = do - s <- newIORef 0 - e <- newIORef 0 - return $ State { shoulder = s, elbow = e } - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let translatef = translate :: Vector3 GLfloat -> IO () - scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () - preservingMatrix $ do - translatef (Vector3 (-1) 0 0) - s <- get (shoulder state) - rotate (fromIntegral s :: GLfloat) (Vector3 0 0 1) - translatef (Vector3 1 0 0) - preservingMatrix $ do - scalef 2 0.4 1 - renderObject Wireframe (Cube 1) - translatef (Vector3 1 0 0) - e <- get (elbow state) - rotate (fromIntegral e :: GLfloat) (Vector3 0 0 1) - translatef (Vector3 1 0 0) - preservingMatrix $ do - scalef 2 0.4 1 - renderObject Wireframe (Cube 1) - swapBuffers - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 65 (fromIntegral w / fromIntegral h) 1 20 - matrixMode $= Modelview 0 - loadIdentity - -- resolve overloading, not needed in "real" programs - let translatef = translate :: Vector3 GLfloat -> IO () - translatef (Vector3 0 0 (-5)) - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case c of - 's' -> update shoulder 5 - 'S' -> update shoulder (-5) - 'e' -> update elbow 5 - 'E' -> update elbow (-5) - '\27' -> exitWith ExitSuccess - _ -> return () - where update joint inc = do - joint state $~ ((`mod` 360) . (+ inc)) - postRedisplay Nothing -keyboard _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ DoubleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - state <- makeState - myInit - displayCallback $= display state - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - mainLoop diff --git a/examples/RedBook/Scene.hs b/examples/RedBook/Scene.hs deleted file mode 100644 --- a/examples/RedBook/Scene.hs +++ /dev/null @@ -1,73 +0,0 @@ -{- - Scene.hs (adapted from scene.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates the use of the GL lighting model. Objects are - drawn using a grey material characteristic. A single light source - illuminates the objects. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Initialize material property and light source. -myInit :: IO () -myInit = do - ambient (Light 0) $= Color4 0 0 0 1 - diffuse (Light 0) $= Color4 1 1 1 1 - specular (Light 0) $= Color4 1 1 1 1 - -- light position is NOT default value - position (Light 0) $= Vertex4 1 1 1 0 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - rotate (20 :: GLfloat) (Vector3 1 0 0) - preservingMatrix $ do - translate (Vector3 (-0.75) 0.5 (0 :: GLfloat)) - rotate (90 :: GLfloat) (Vector3 1 0 0) - renderObject Solid (Torus 0.275 0.85 15 15) - preservingMatrix $ do - translate (Vector3 (-0.75) (-0.5) (0 :: GLfloat)) - rotate (270 :: GLfloat) (Vector3 1 0 0) - renderObject Solid (Cone 1 2 15 15) - preservingMatrix $ do - translate (Vector3 0.75 0 (-1 :: GLfloat)) - renderObject Solid (Sphere' 1 15 15) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-2.5) 2.5 (-2.5 * hf/wf) (2.5 * hf/wf) (-10) 10 - else ortho (-2.5 * wf/hf) (2.5 * wf/hf) (-2.5) 2.5 (-10) 10 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - createWindow progName - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/Select.hs b/examples/RedBook/Select.hs deleted file mode 100644 --- a/examples/RedBook/Select.hs +++ /dev/null @@ -1,150 +0,0 @@ -{- - Select.hs (adapted from select.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This is an illustration of the selection mode and name stack, which detects - whether objects which collide with a viewing volume. First, four triangles - and a rectangular box representing a viewing volume are drawn (drawScene - routine). The green triangle and yellow triangles appear to lie within the - viewing volume, but the red triangle appears to lie outside it. Then the - selection mode is entered (selectObjects routine). Drawing to the screen - ceases. To see if any collisions occur, the four triangles are called. In - this example, the green triangle causes one hit with the name 1, and the - yellow triangles cause one hit with the name 3. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- draw a triangle with vertices at (x1, y1), (x2, y2) and (x3, y3) at z units --- away from the origin. -drawTriangle :: - Vertex2 GLfloat -> Vertex2 GLfloat -> Vertex2 GLfloat -> GLfloat -> IO () -drawTriangle (Vertex2 x1 y1) (Vertex2 x2 y2) (Vertex2 x3 y3) z = do - renderPrimitive Triangles $ mapM_ vertex [ - Vertex3 x1 y1 z, - Vertex3 x2 y2 z, - Vertex3 x3 y3 z] - --- draw a rectangular box with these outer x, y, and z values -drawViewVolume :: Vertex3 GLfloat -> Vertex3 GLfloat -> IO () -drawViewVolume (Vertex3 x1 y1 z1) (Vertex3 x2 y2 z2) = do - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - color3f (Color3 1 1 1) - renderPrimitive LineLoop $ mapM_ vertex [ - Vertex3 x1 y1 (-z1), - Vertex3 x2 y1 (-z1), - Vertex3 x2 y2 (-z1), - Vertex3 x1 y2 (-z1)] - - renderPrimitive LineLoop $ mapM_ vertex [ - Vertex3 x1 y1 (-z2), - Vertex3 x2 y1 (-z2), - Vertex3 x2 y2 (-z2), - Vertex3 x1 y2 (-z2)] - - renderPrimitive Lines $ mapM_ vertex [ -- 4 lines - Vertex3 x1 y1 (-z1), - Vertex3 x1 y1 (-z2), - Vertex3 x1 y2 (-z1), - Vertex3 x1 y2 (-z2), - Vertex3 x2 y1 (-z1), - Vertex3 x2 y1 (-z2), - Vertex3 x2 y2 (-z1), - Vertex3 x2 y2 (-z2)] - --- drawScene draws 4 triangles and a wire frame which represents the viewing --- volume. -drawScene :: IO () -drawScene = do - matrixMode $= Projection - loadIdentity - perspective 40 (4/3) 1 100 - - matrixMode $= Modelview 0 - loadIdentity - lookAt (Vertex3 7.5 7.5 12.5) (Vertex3 2.5 2.5 (-5)) (Vector3 0 1 0) - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - color3f (Color3 0 1 0) -- green triangle - drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-5) - color3f (Color3 1 0 0) -- red triangle - drawTriangle (Vertex2 2 7) (Vertex2 3 7) (Vertex2 2.5 8) (-5) - color3f (Color3 1 1 0) -- yellow triangles - drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-1) - drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-9) - drawViewVolume (Vertex3 0 0 0) (Vertex3 5 5 10) - -processHits :: Maybe [HitRecord] -> IO () -processHits Nothing = putStrLn "selection buffer overflow" -processHits (Just hitRecords) = do - putStrLn ("hits = " ++ show (length hitRecords)) - mapM_ (\(HitRecord z1 z2 names) -> do - putStrLn (" number of names for hit = " ++ show (length names)) - putStr (" z1 is " ++ show z1) - putStrLn ("; z2 is " ++ show z2) - putStr " the name is" - sequence_ [ putStr (" " ++ show n) | Name n <- names ] - putChar '\n') - hitRecords - --- selectObjects "draws" the triangles in selection mode, assigning names for --- the triangles. Note that the third and fourth triangles share one name, so --- that if either or both triangles intersects the viewing/clipping volume, --- only one hit will be registered. - -bufSize :: GLsizei -bufSize = 512 - -selectObjects :: IO () -selectObjects = do - (_, maybeHitRecords) <- getHitRecords bufSize $ do - withName (Name 0) $ do - preservingMatrix $ do - matrixMode $= Projection - loadIdentity - ortho 0 5 0 5 0 10 - matrixMode $= Modelview 0 - loadIdentity - loadName (Name 1) - drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-5) - loadName (Name 2) - drawTriangle (Vertex2 2 7) (Vertex2 3 7) (Vertex2 2.5 8) (-5) - loadName (Name 3) - drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-1) - drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-9) - flush - processHits maybeHitRecords - -myInit :: IO () -myInit = do - depthFunc $= Just Less - shadeModel $= Flat - -display :: DisplayCallback -display = do - clearColor $= Color4 0 0 0 0 - clear [ ColorBuffer, DepthBuffer ] - drawScene - selectObjects - flush - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 200 200 - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/ShadowMap.hs b/examples/RedBook/ShadowMap.hs deleted file mode 100644 --- a/examples/RedBook/ShadowMap.hs +++ /dev/null @@ -1,255 +0,0 @@ -{- - ShadowMap.hs (adapted from shadowmap.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE --} - -import Control.Monad ( when, unless ) -import Data.IORef ( IORef, newIORef ) -import Foreign.Marshal.Array ( allocaArray ) -import Foreign.Ptr ( nullPtr ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -shadowMapSize :: TextureSize2D -shadowMapSize = TextureSize2D 256 256 - -fovy, nearPlane, farPlane :: GLdouble -fovy = 60 -nearPlane = 10 -farPlane = 100 - -lightPos :: Vertex4 GLfloat -lightPos = Vertex4 25 25 25 1 - -lookat :: Vertex3 GLdouble -lookat = Vertex3 0 0 0 - -up :: Vector3 GLdouble -up = Vector3 0 0 1 - -data State = State { - angle :: IORef GLdouble, - torusAngle :: IORef GLfloat, - showShadow :: IORef Bool, - animate :: IORef Bool, - funcMode :: IORef ComparisonFunction } - -makeState :: IO State -makeState = do - a <- newIORef 0 - t <- newIORef 0 - s <- newIORef False - n <- newIORef True - f <- newIORef Lequal - return $ State { angle = a, torusAngle = t, showShadow = s, - animate = n, funcMode = f } - -myInit :: IO () -myInit = do - texImage2D Nothing NoProxy 0 DepthComponent' shadowMapSize 0 - (PixelData DepthComponent UnsignedByte nullPtr) - - position (Light 0) $= lightPos - let white = Color4 1 1 1 1 - specular (Light 0) $= white - diffuse (Light 0) $= white - - textureWrapMode Texture2D S $= (Repeated, ClampToEdge) - textureWrapMode Texture2D T $= (Repeated, ClampToEdge) - textureFilter Texture2D $= ((Linear', Nothing), Linear') - textureCompareMode Texture2D $= Just Lequal - depthTextureMode Texture2D $= Luminance' - - colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse) - - cullFace $= Just Back - - depthFunc $= Just Less - light (Light 0) $= Enabled - lighting $= Enabled - texture Texture2D $= Enabled - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective fovy (fromIntegral w / fromIntegral h) nearPlane farPlane - matrixMode $= Modelview 0 - -idle :: State -> IdleCallback -idle state = do - angle state $~! (+ (pi / 10000)) - torusAngle state $~! (+ 0.1) - postRedisplay Nothing - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = do - case c of - '\27' -> exitWith ExitSuccess - 't' -> - texture Texture2D $~ \cap -> if cap == Enabled then Disabled else Enabled - 'm' -> do - fm <- get (funcMode state) - textureCompareMode Texture2D $~ maybe (Just fm) (const Nothing) - compareMode <- get (textureCompareMode Texture2D) - putStrLn ("Compare mode " ++ maybe "Off" (const "On") compareMode) - 'f' -> do - funcMode state $~ \fm -> if fm == Lequal then Gequal else Lequal - fm <- get (funcMode state) - putStrLn ("Operator " ++ show fm) - textureCompareMode Texture2D $~ maybe Nothing (const (Just fm)) - 's' -> showShadow state $~ not - 'p' -> do - animate state $~ not - animate' <- get (animate state) - idleCallback $= if animate' then Just (idle state) else Nothing - _ -> return () - postRedisplay Nothing -keyboard _ _ _ _ _ = return () - -drawObjects :: GLfloat -> Bool -> IO () -drawObjects torusAngle' shadowRender = do - textureOn <- get (texture Texture2D) - - when shadowRender $ - texture Texture2D $= Disabled - - -- resolve overloading, not needed in "real" programs - let normal3f = normal :: Normal3 GLfloat -> IO () - color3f = color :: Color3 GLfloat -> IO () - rectf = rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO () - translatef = translate :: Vector3 GLfloat -> IO () - rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () - - unless shadowRender $ do - normal3f (Normal3 0 0 1) - color3f (Color3 1 1 1) - rectf (Vertex2 (-20) (-20)) (Vertex2 20 20) - - preservingMatrix $ do - translatef (Vector3 11 11 11) - rotatef 54.73 (Vector3 (-5) 5 0) - rotate torusAngle' (Vector3 1 0 0) - color3f (Color3 1 0 0) - renderObject Solid (Torus 1 4 8 36) - - preservingMatrix $ do - translatef (Vector3 2 2 2) - color3f (Color3 0 0 1) - renderObject Solid (Cube 4) - - preservingMatrix $ do - getLightPos Vector3 >>= translate - color3f (Color3 1 1 1) - renderObject Wireframe (Sphere' 0.5 6 6) - - when (shadowRender && textureOn == Enabled) $ - texture Texture2D $= Enabled - -getLightPos :: (GLdouble -> GLdouble -> GLdouble -> a) -> IO a -getLightPos f = do - Vertex4 x y z _ <- get (position (Light 0)) - return $ f (realToFrac x) (realToFrac y) (realToFrac z) - -generateShadowMap :: GLfloat -> Bool -> IO () -generateShadowMap torusAngle' showShadow' = do - lightPos' <- getLightPos Vertex3 - let (TextureSize2D shadowMapWidth shadowMapHeight) = shadowMapSize - shadowMapSize' = Size shadowMapWidth shadowMapHeight - - preservingViewport $ do - viewport $= (Position 0 0, shadowMapSize') - - clear [ ColorBuffer, DepthBuffer ] - - matrixMode $= Projection - preservingMatrix $ do - loadIdentity - perspective 80 1 10 1000 - matrixMode $= Modelview 0 - preservingMatrix $ do - loadIdentity - lookAt lightPos' lookat up - drawObjects torusAngle' True - matrixMode $= Projection - matrixMode $= Modelview 0 - - copyTexImage2D Nothing 0 DepthComponent' (Position 0 0) shadowMapSize 0 - - when showShadow' $ do - let numShadowMapPixels = fromIntegral (shadowMapWidth * shadowMapHeight) - allocaArray numShadowMapPixels $ \depthImage -> do - let pixelData fmt = PixelData fmt Float depthImage :: PixelData GLfloat - readPixels (Position 0 0) shadowMapSize' (pixelData DepthComponent) - (_, Size viewPortWidth _) <- get viewport - windowPos (Vertex2 (fromIntegral viewPortWidth / 2 :: GLfloat) 0) - drawPixels shadowMapSize' (pixelData Luminance) - swapBuffers - --- Note: preservingViewport is not exception safe, but it doesn't matter here -preservingViewport :: IO a -> IO a -preservingViewport act = do - v <- get viewport - x <- act - viewport $= v - return x - -generateTextureMatrix :: IO () -generateTextureMatrix = do - -- Set up projective texture matrix. We use the Modelview matrix stack and - -- OpenGL matrix commands to make the matrix. - m <- preservingMatrix $ do - loadIdentity - -- resolve overloading, not needed in "real" programs - let translatef = translate :: Vector3 GLfloat -> IO () - scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () - translatef (Vector3 0.5 0.5 0.0) - scalef 0.5 0.5 1.0 - perspective 60 1 1 1000 - lightPos' <- getLightPos Vertex3 - lookAt lightPos' lookat up - get (matrix (Just (Modelview 0))) - - [ sx, sy, sz, sw, - tx, ty, tz, tw, - rx, ry, rz, rw, - qx, qy, qz, qw ] <- getMatrixComponents RowMajor (m :: GLmatrix GLdouble) - - textureGenMode S $= Just (ObjectLinear (Plane sx sy sz sw)) - textureGenMode T $= Just (ObjectLinear (Plane tx ty tz tw)) - textureGenMode R $= Just (ObjectLinear (Plane rx ry rz rw)) - textureGenMode Q $= Just (ObjectLinear (Plane qx qy qz qw)) - -display :: State -> DisplayCallback -display state = do - let radius = 30 - torusAngle' <- get (torusAngle state) - showShadow' <- get (showShadow state) - generateShadowMap torusAngle' showShadow' - generateTextureMatrix - unless showShadow' $ do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - angle' <- get (angle state) - lookAt (Vertex3 (radius * cos angle') (radius * sin angle') 30) lookat up - drawObjects torusAngle' False - swapBuffers - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ RGBAMode, WithDepthBuffer, DoubleBuffered ] - initialWindowSize $= Size 521 512 - initialWindowPosition $= Position 100 100 - createWindow progName - state <- makeState - myInit - displayCallback $= display state - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - idleCallback $= Just (idle state) - - mainLoop diff --git a/examples/RedBook/Smooth.hs b/examples/RedBook/Smooth.hs deleted file mode 100644 --- a/examples/RedBook/Smooth.hs +++ /dev/null @@ -1,65 +0,0 @@ -{- - Smooth.hs (adapted from smooth.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates smooth shading. A smooth shaded polygon is drawn in - a 2-D projection. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Smooth - -triangle :: IO () -triangle = - -- resolve overloading, not needed in "real" programs - let vertex2f = vertex :: Vertex2 GLfloat -> IO () - color3f = color :: Color3 GLfloat -> IO () - in renderPrimitive Triangles $ do - color3f (Color3 1 0 0) - vertex2f (Vertex2 5 5) - color3f (Color3 0 1 0) - vertex2f (Vertex2 25 5) - color3f (Color3 0 0 1) - vertex2f (Vertex2 5 25) - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - triangle - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho2D 0 30 0 (30 * hf/wf) - else ortho2D 0 (30 * wf/hf) 0 30 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/Stencil.hs b/examples/RedBook/Stencil.hs deleted file mode 100644 --- a/examples/RedBook/Stencil.hs +++ /dev/null @@ -1,123 +0,0 @@ -{- - Stencil.hs (adapted from stencil.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates use of the stencil buffer for masking - nonrectangular regions. Whenever the window is redrawn, a value of 1 is drawn - into a diamond-shaped region in the stencil buffer. Elsewhere in the stencil - buffer, the value is 0. Then a blue sphere is drawn where the stencil value - is 1, and yellow torii are drawn where the stencil value is not 1. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data DisplayLists = DisplayLists { yellowMat, blueMat :: DisplayList } - -myInit :: IO DisplayLists -myInit = do - y <- defineNewList Compile $ do - materialDiffuse Front $= Color4 0.7 0.7 0 1 - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 64 - - b <- defineNewList Compile $ do - materialDiffuse Front $= Color4 0.1 0.1 0.7 1 - materialSpecular Front $= Color4 0.1 1 1 1 - materialShininess Front $= 45 - - position (Light 0) $= Vertex4 1 1 1 0 - - light (Light 0) $= Enabled - lighting $= Enabled - depthFunc $= Just Less - - clearStencil $= 0 - stencilTest $= Enabled - - return $ DisplayLists { yellowMat = y, blueMat = b } - --- Draw a sphere in a diamond-shaped section in the middle of a window with 2 --- torii. -display :: DisplayLists -> DisplayCallback -display displayLists = do - clear [ ColorBuffer, DepthBuffer ] - - -- draw blue sphere where the stencil is 1 - stencilFunc $= (Equal, 1, 1) - stencilOp $= (OpKeep, OpKeep, OpKeep) - callList (blueMat displayLists) - renderObject Solid (Sphere' 0.5 15 15) - - -- resolve overloading, not needed in "real" programs - let rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () - - -- draw the tori where the stencil is not 1 - stencilFunc $= (Notequal, 1, 1) - preservingMatrix $ do - rotatef 45 (Vector3 0 0 1) - rotatef 45 (Vector3 0 1 0) - callList (yellowMat displayLists) - renderObject Solid (Torus 0.275 0.85 15 15) - preservingMatrix $ do - rotatef 90 (Vector3 1 0 0) - renderObject Solid (Torus 0.275 0.85 15 15) - - flush - --- Whenever the window is reshaped, redefine the coordinate system and redraw --- the stencil area. -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - - -- create a diamond shaped stencil area - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho2D (-3) 3 (-3*hf/wf) (3*hf/wf) - else ortho2D (-3*wf/hf) (3*wf/hf) (-3) 3 - matrixMode $= Modelview 0 - loadIdentity - - -- resolve overloading, not needed in "real" programs - let vertex2f = vertex :: Vertex2 GLfloat -> IO () - translatef = translate :: Vector3 GLfloat -> IO () - - clear [ StencilBuffer ] - stencilFunc $= (Always, 1, 1) - stencilOp $= (OpReplace, OpReplace, OpReplace) - renderPrimitive Quads $ do - vertex2f (Vertex2 (-1) 0) - vertex2f (Vertex2 0 1) - vertex2f (Vertex2 1 0) - vertex2f (Vertex2 0 (-1)) - - matrixMode $= Projection - loadIdentity - perspective 45 (wf/hf) 3 7 - matrixMode $= Modelview 0 - loadIdentity - translatef (Vector3 0 0 (-5)) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop: Be certain to request stencil bits. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer, WithStencilBuffer ] - initialWindowSize $= Size 400 400 - initialWindowPosition $= Position 100 100 - createWindow progName - displayLists <- myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display displayLists - mainLoop diff --git a/examples/RedBook/Stroke.hs b/examples/RedBook/Stroke.hs deleted file mode 100644 --- a/examples/RedBook/Stroke.hs +++ /dev/null @@ -1,127 +0,0 @@ -{- - Stroke.hs (adapted from stroke.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates some characters of a stroke (vector) font. The - characters are represented by display lists, which are given numbers which - correspond to the ASCII values of the characters. Use of callLists is - demonstrated. --} - -import Data.List ( genericLength ) -import Foreign.C.String ( castCharToCChar ) -import Foreign.Marshal.Array ( withArray ) -import Graphics.UI.GLUT -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) - -aData, eData, pData, rData, sData :: [[Vertex2 GLfloat]] -aData = [ - [ Vertex2 0 0, Vertex2 0 9, Vertex2 1 10, Vertex2 4 10, Vertex2 5 9, - Vertex2 5 0 ], - [ Vertex2 0 5, Vertex2 5 5 ] ] - -eData = [ - [ Vertex2 5 0, Vertex2 0 0, Vertex2 0 10, Vertex2 5 10 ], - [ Vertex2 0 5, Vertex2 4 5 ] ] - -pData = [ - [ Vertex2 0 0, Vertex2 0 10, Vertex2 4 10, Vertex2 5 9, Vertex2 5 6, - Vertex2 4 5, Vertex2 0 5 ] ] - -rData = [ - [ Vertex2 0 0, Vertex2 0 10, Vertex2 4 10, Vertex2 5 9, Vertex2 5 6, - Vertex2 4 5, Vertex2 0 5 ], - [ Vertex2 3 5, Vertex2 5 0 ] ] - -sData = [ - [ Vertex2 0 1, Vertex2 1 0, Vertex2 4 0, Vertex2 5 1, Vertex2 5 4, - Vertex2 4 5, Vertex2 1 5, Vertex2 0 6, Vertex2 0 9, Vertex2 1 10, - Vertex2 4 10, Vertex2 5 9 ] ] - -advance :: IO () -advance = translate (Vector3 8 0 (0 :: GLfloat)) - --- drawLetter renders a letter with line segments given by the list of line --- strips. -drawLetter :: [[Vertex2 GLfloat]] -> IO () -drawLetter lineStrips = do - mapM_ (renderPrimitive LineStrip . mapM_ vertex) lineStrips - advance - -charToGLubyte :: Char -> GLubyte -charToGLubyte = fromIntegral . castCharToCChar - -myInit :: IO () -myInit = do - shadeModel $= Flat - - (base@(DisplayList b):_) <- genObjectNames 128 - listBase $= base - let charToDisplayList c = DisplayList (b + fromIntegral (charToGLubyte c)) - mapM_ (\(c, d) -> defineList (charToDisplayList c) Compile d) - [ ('A', drawLetter aData), - ('E', drawLetter eData), - ('P', drawLetter pData), - ('R', drawLetter rData), - ('S', drawLetter sData), - (' ', advance) ] - -test1, test2 :: String -test1 = "A SPARE SERAPE APPEARS AS" -test2 = "APES PREPARE RARE PEPPERS" - -printStrokedString :: String -> IO () -printStrokedString s = - withArray (map charToGLubyte s) $ - callLists (genericLength s) UnsignedByte - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () - translatef = translate :: Vector3 GLfloat -> IO () - - color3f (Color3 1 1 1) - preservingMatrix $ do - scalef 2 2 2 - translatef (Vector3 10 30 0) - printStrokedString test1 - preservingMatrix $ do - scalef 2 2 2 - translatef (Vector3 10 13 0) - printStrokedString test2 - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 (fromIntegral w) 0 (fromIntegral h) - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char c) Down _ _ = case c of - ' ' -> postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ = return () - --- Main Loop: Open window with initial window size, title bar, RGBA display --- mode, and handle input events. -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 440 120 - createWindow progName - myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - displayCallback $= display - mainLoop diff --git a/examples/RedBook/SurfPoints.hs b/examples/RedBook/SurfPoints.hs deleted file mode 100644 --- a/examples/RedBook/SurfPoints.hs +++ /dev/null @@ -1,129 +0,0 @@ -{- - SurfPoints.hs (adapted from surfpoints.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program is a modification of the earlier Surface.hs program. The - vertex data are not directly rendered, but are instead passed to the - callback function. The values of the tessellated vertices are printed - out there. - - This program draws a NURBS surface in the shape of a symmetrical hill. - The 'c' keyboard key allows you to toggle the visibility of the control - points themselves. Note that some of the control points are hidden by - the surface itself. - - NOTE: This example does NOT demonstrate the final NURBS API, it's currently - just a test for the internals... --} - -import Control.Monad ( when ) -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import Foreign.Marshal ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { showPoints :: IORef Bool } - -makeState :: IO State -makeState = do - s <- newIORef False - return $ State { showPoints = s } - --- The control points of the surface form a small hill and --- range from -3 to +3 in x, y, and z. -ctlPoints :: [[Vertex3 GLfloat]] -ctlPoints = - [ [ Vertex3 (2 * u - 3) - (2 * v - 3) - (if (u == 1 || u ==2) && (v == 1 || v == 2) then 3 else -3) - | v <- [ 0 .. 3 ] ] - | u <- [ 0 .. 3 ]] - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - materialDiffuse Front $= Color4 0.7 0.7 0.7 1 - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 100 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - autoNormal $= Enabled - normalize $= Enabled - --------------------------------------------------------------------------------- - -display :: State -> DisplayCallback -display state = do - let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - rotate (330 :: GLfloat) (Vector3 1 0 0) - scale 0.5 0.5 (0.5 :: GLfloat) - - withNURBSObj () $ \nurbsObj -> do - setNURBSMode nurbsObj NURBSTessellator - setSamplingMethod nurbsObj (PathLength 25) - setDisplayMode' nurbsObj Fill' - checkForNURBSError nurbsObj $ - withNURBSBeginCallback nurbsObj print $ - withNURBSVertexCallback nurbsObj print $ - withNURBSNormalCallback nurbsObj print $ - withNURBSEndCallback nurbsObj (putStrLn "end") $ - nurbsBeginEndSurface nurbsObj $ - withArray (concat ctlPoints) $ \cBuf -> - withArray knots $ \kBuf -> - nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4 - - s <- get (showPoints state) - when s $ do - pointSize $= 5 - lighting $= Disabled - color (Color3 1 1 (0 :: GLfloat)) - renderPrimitive Points $ - mapM_ (mapM_ vertex) ctlPoints - lighting $= Enabled - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 45 (fromIntegral w / fromIntegral h) 3 8 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-5 :: GLfloat)) - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case toLower c of - 'c' -> do showPoints state $~ not; postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - version <- get (majorMinor gluVersion) - when (version < (1,3)) $ do - putStrLn "This program demonstrates a feature which is introduced in the" - putStrLn "OpenGL Utility Library (GLU) Version 1.3." - putStrLn "If your implementation of GLU has the right extensions," - putStrLn "you may be able to modify this program to make it run." - putStrLn "Continuing anyway..." - state <- makeState - myInit - reshapeCallback $= Just reshape - displayCallback $= display state - keyboardMouseCallback $= Just (keyboard state) - mainLoop diff --git a/examples/RedBook/Surface.hs b/examples/RedBook/Surface.hs deleted file mode 100644 --- a/examples/RedBook/Surface.hs +++ /dev/null @@ -1,112 +0,0 @@ -{- - Surface.hs (adapted from surface.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws a NURBS surface in the shape of a symmetrical hill. - The 'c' keyboard key allows you to toggle the visibility of the control - points themselves. Note that some of the control points are hidden by - the surface itself. - - NOTE: This example does NOT demonstrate the final NURBS API, it's currently - just a test for the internals... --} - -import Control.Monad ( when ) -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import Foreign.Marshal ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { showPoints :: IORef Bool } - -makeState :: IO State -makeState = do - s <- newIORef False - return $ State { showPoints = s } - --- The control points of the surface form a small hill and --- range from -3 to +3 in x, y, and z. -ctlPoints :: [[Vertex3 GLfloat]] -ctlPoints = - [ [ Vertex3 (2 * u - 3) - (2 * v - 3) - (if (u == 1 || u ==2) && (v == 1 || v == 2) then 3 else -3) - | v <- [ 0 .. 3 ] ] - | u <- [ 0 .. 3 ]] - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - materialDiffuse Front $= Color4 0.7 0.7 0.7 1 - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 100 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - autoNormal $= Enabled - normalize $= Enabled - --------------------------------------------------------------------------------- - -display :: State -> DisplayCallback -display state = do - let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - rotate (330 :: GLfloat) (Vector3 1 0 0) - scale 0.5 0.5 (0.5 :: GLfloat) - - withNURBSObj () $ \nurbsObj -> do - setSamplingMethod nurbsObj (PathLength 25) - setDisplayMode' nurbsObj Fill' - checkForNURBSError nurbsObj $ - nurbsBeginEndSurface nurbsObj $ - withArray (concat ctlPoints) $ \cBuf -> - withArray knots $ \kBuf -> - nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4 - - s <- get (showPoints state) - when s $ do - pointSize $= 5 - lighting $= Disabled - color (Color3 1 1 (0 :: GLfloat)) - renderPrimitive Points $ - mapM_ (mapM_ vertex) ctlPoints - lighting $= Enabled - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 45 (fromIntegral w / fromIntegral h) 3 8 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-5 :: GLfloat)) - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case toLower c of - 'c' -> do showPoints state $~ not; postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - state <- makeState - myInit - reshapeCallback $= Just reshape - displayCallback $= display state - keyboardMouseCallback $= Just (keyboard state) - mainLoop diff --git a/examples/RedBook/Teapots.hs b/examples/RedBook/Teapots.hs deleted file mode 100644 --- a/examples/RedBook/Teapots.hs +++ /dev/null @@ -1,226 +0,0 @@ -{- - Teapots.hs (adapted from teapots.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates lots of material properties. A single light - source illuminates the objects. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Initialize depth buffer, projection matrix, light source, and lighting --- model. Do not specify a material property here. -myInit :: IO DisplayList -myInit = do - ambient (Light 0) $= Color4 0 0 0 1 - diffuse (Light 0) $= Color4 1 1 1 1 - position (Light 0) $= Vertex4 0 3 3 0 - lightModelAmbient $= Color4 0.2 0.2 0.2 1 - lightModelLocalViewer $= Disabled - - frontFace $= CW - lighting $= Enabled - light (Light 0) $= Enabled - autoNormal $= Enabled - normalize $= Enabled - depthFunc $= Just Less - -- be efficient--make teapot display list - defineNewList Compile $ - renderObject Solid (Teapot 1) - --- Move object into position, specify the material properties, draw a teapot. -renderTeapot :: DisplayList -> Vector3 GLfloat -> Color4 GLfloat - -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> IO () -renderTeapot teapotList pos amb dif spec shine = do - preservingMatrix $ do - translate pos - materialAmbient Front $= amb - materialDiffuse Front $= dif - materialSpecular Front $= spec - materialShininess Front $= shine * 128 - callList teapotList - --- 1st column: emerald, jade, obsidian, pearl, ruby, turquoise --- 2nd column: brass, bronze, chrome, copper, gold, silver --- 3rd column: black, cyan, green, red, white, yellow plastic --- 4th column: black, cyan, green, red, white, yellow rubber -display :: DisplayList -> DisplayCallback -display teapotList = do - clear [ ColorBuffer, DepthBuffer ] - renderTeapot teapotList - (Vector3 2 17 0) - (Color4 0.0215 0.1745 0.0215 1) - (Color4 0.07568 0.61424 0.07568 1) - (Color4 0.633 0.727811 0.633 1) - 0.6 - renderTeapot teapotList - (Vector3 2 14 0) - (Color4 0.135 0.2225 0.1575 1) - (Color4 0.54 0.89 0.63 1) - (Color4 0.316228 0.316228 0.316228 1) - 0.1 - renderTeapot teapotList - (Vector3 2 11 0) - (Color4 0.05375 0.05 0.06625 1) - (Color4 0.18275 0.17 0.22525 1) - (Color4 0.332741 0.328634 0.346435 1) - 0.3 - renderTeapot teapotList - (Vector3 2 8 0) - (Color4 0.25 0.20725 0.20725 1) - (Color4 1 0.829 0.829 1) - (Color4 0.296648 0.296648 0.296648 1) - 0.088 - renderTeapot teapotList - (Vector3 2 5 0) - (Color4 0.1745 0.01175 0.01175 1) - (Color4 0.61424 0.04136 0.04136 1) - (Color4 0.727811 0.626959 0.626959 1) - 0.6 - renderTeapot teapotList - (Vector3 2 2 0) - (Color4 0.1 0.18725 0.1745 1) - (Color4 0.396 0.74151 0.69102 1) - (Color4 0.297254 0.30829 0.306678 1) - 0.1 - renderTeapot teapotList - (Vector3 6 17 0) - (Color4 0.329412 0.223529 0.027451 1) - (Color4 0.780392 0.568627 0.113725 1) - (Color4 0.992157 0.941176 0.807843 1) - 0.21794872 - renderTeapot teapotList - (Vector3 6 14 0) - (Color4 0.2125 0.1275 0.054 1) - (Color4 0.714 0.4284 0.18144 1) - (Color4 0.393548 0.271906 0.166721 1) - 0.2 - renderTeapot teapotList - (Vector3 6 11 0) - (Color4 0.25 0.25 0.25 1) - (Color4 0.4 0.4 0.4 1) - (Color4 0.774597 0.774597 0.774597 1) - 0.6 - renderTeapot teapotList - (Vector3 6 8 0) - (Color4 0.19125 0.0735 0.0225 1) - (Color4 0.7038 0.27048 0.0828 1) - (Color4 0.256777 0.137622 0.086014 1) - 0.1 - renderTeapot teapotList - (Vector3 6 5 0) - (Color4 0.24725 0.1995 0.0745 1) - (Color4 0.75164 0.60648 0.22648 1) - (Color4 0.628281 0.555802 0.366065 1) - 0.4 - renderTeapot teapotList - (Vector3 6 2 0) - (Color4 0.19225 0.19225 0.19225 1) - (Color4 0.50754 0.50754 0.50754 1) - (Color4 0.508273 0.508273 0.508273 1) - 0.4 - renderTeapot teapotList - (Vector3 10 17 0) - (Color4 0 0 0 1) - (Color4 0.01 0.01 0.01 1) - (Color4 0.50 0.50 0.50 1) - 0.25 - renderTeapot teapotList - (Vector3 10 14 0) - (Color4 0 0.1 0.06 1) - (Color4 0 0.50980392 0.50980392 1) - (Color4 0.50196078 0.50196078 0.50196078 1) - 0.25 - renderTeapot teapotList - (Vector3 10 11 0) - (Color4 0 0 0 1) - (Color4 0.1 0.35 0.1 1) - (Color4 0.45 0.55 0.45 1) - 0.25 - renderTeapot teapotList - (Vector3 10 8 0) - (Color4 0 0 0 1) - (Color4 0.5 0 0 1) - (Color4 0.7 0.6 0.6 1) - 0.25 - renderTeapot teapotList - (Vector3 10 5 0) - (Color4 0 0 0 1) - (Color4 0.55 0.55 0.55 1) - (Color4 0.70 0.70 0.70 1) - 0.25 - renderTeapot teapotList - (Vector3 10 2 0) - (Color4 0 0 0 1) - (Color4 0.5 0.5 0 1) - (Color4 0.60 0.60 0.50 1) - 0.25 - renderTeapot teapotList - (Vector3 14 17 0) - (Color4 0.02 0.02 0.02 1) - (Color4 0.01 0.01 0.01 1) - (Color4 0.4 0.4 0.4 1) - 0.078125 - renderTeapot teapotList - (Vector3 14 14 0) - (Color4 0 0.05 0.05 1) - (Color4 0.4 0.5 0.5 1) - (Color4 0.04 0.7 0.7 1) - 0.078125 - renderTeapot teapotList - (Vector3 14 11 0) - (Color4 0 0.05 0 1) - (Color4 0.4 0.5 0.4 1) - (Color4 0.04 0.7 0.04 1) - 0.078125 - renderTeapot teapotList - (Vector3 14 8 0) - (Color4 0.05 0 0 1) - (Color4 0.5 0.4 0.4 1) - (Color4 0.7 0.04 0.04 1) - 0.078125 - renderTeapot teapotList - (Vector3 14 5 0) - (Color4 0.05 0.05 0.05 1) - (Color4 0.5 0.5 0.5 1) - (Color4 0.7 0.7 0.7 1) - 0.078125 - renderTeapot teapotList - (Vector3 14 2 0) - (Color4 0.05 0.05 0 1) - (Color4 0.5 0.5 0.4 1) - (Color4 0.7 0.7 0.04 1) - 0.078125 - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho 0 16 0 (16 * hf/wf) (-10) 10 - else ortho 0 (16 * wf/hf) 0 16 (-10) 10 - matrixMode $= Modelview 0 - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 600 - initialWindowPosition $= Position 50 50 - createWindow progName - teapotList <- myInit - reshapeCallback $= Just reshape - displayCallback $= display teapotList - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/Tess.hs b/examples/RedBook/Tess.hs deleted file mode 100644 --- a/examples/RedBook/Tess.hs +++ /dev/null @@ -1,117 +0,0 @@ -{- - Tess.hs (adapted from tess.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates polygon tessellation. Two tesselated objects are - drawn. The first is a rectangle with a triangular hole. The second is a - smooth shaded, self-intersecting star. - - Note the exterior rectangle is drawn with its vertices in counter-clockwise - order, but its interior clockwise. Note the combineCallback is needed for the - self-intersecting star. Also note that removing the TessProperty for the - star will make the interior unshaded (TessWindingOdd). --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -display :: [DisplayList] -> DisplayCallback -display displayLists = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - color3f (Color3 1 1 1) - mapM callList displayLists - flush - --- 'Float' is a dummy, any marshalable type would do -type DontCare = Float - -rectangle :: ComplexContour DontCare -rectangle = ComplexContour [ - AnnotatedVertex (Vertex3 50 50 0) 0, - AnnotatedVertex (Vertex3 200 50 0) 0, - AnnotatedVertex (Vertex3 200 200 0) 0, - AnnotatedVertex (Vertex3 50 200 0) 0 ] - -tri :: ComplexContour DontCare -tri = ComplexContour [ - AnnotatedVertex (Vertex3 75 75 0) 0, - AnnotatedVertex (Vertex3 125 175 0) 0, - AnnotatedVertex (Vertex3 175 75 0) 0 ] - -rectAndTri :: ComplexPolygon DontCare -rectAndTri = ComplexPolygon [ rectangle, tri ] - -noOpCombiner :: Combiner DontCare -noOpCombiner _newVertex _weightedProperties = 0 - -star :: ComplexPolygon (Color3 GLfloat) -star = ComplexPolygon [ - ComplexContour [ - AnnotatedVertex (Vertex3 250 50 0) (Color3 1 0 1), - AnnotatedVertex (Vertex3 325 200 0) (Color3 1 1 0), - AnnotatedVertex (Vertex3 400 50 0) (Color3 0 1 1), - AnnotatedVertex (Vertex3 250 150 0) (Color3 1 0 0), - AnnotatedVertex (Vertex3 400 150 0) (Color3 0 1 0) ] ] - -combineColors :: Combiner (Color3 GLfloat) -combineColors - _newVertex - (WeightedProperties - (w0, Color3 r0 g0 b0) - (w1, Color3 r1 g1 b1) - (w2, Color3 r2 g2 b2) - (w3, Color3 r3 g3 b3)) = - Color3 (w0*r0 + w1*r1 + w2*r2 + w3*r3) - (w0*g0 + w1*g1 + w2*g2 + w3*g3) - (w0*b0 + w1*b1 + w2*b2 + w3*b3) - -myInit :: IO [DisplayList] -myInit = do - clearColor $= Color4 0 0 0 0 - - rectAndTriList <- defineNewList Compile $ - drawSimplePolygon (\_ -> return ()) =<< - tessellate TessWindingOdd 0 (Normal3 0 0 0) noOpCombiner rectAndTri - - starList <- defineNewList Compile $ - drawSimplePolygon color =<< - tessellate TessWindingPositive 0 (Normal3 0 0 0) combineColors star - - return [ rectAndTriList, starList ] - -drawSimplePolygon :: (v -> IO ()) -> SimplePolygon v -> IO () -drawSimplePolygon colorHandler (SimplePolygon primitives) = - flip mapM_ primitives $ \(Primitive primitiveMode vertices) -> - renderPrimitive primitiveMode $ - flip mapM_ vertices $ \(AnnotatedVertex plainVertex col) -> do - colorHandler col - vertex plainVertex - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 (fromIntegral w) 0 (fromIntegral h) - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - createWindow progName - displayLists <- myInit - displayCallback $= display displayLists - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/TessWind.hs b/examples/RedBook/TessWind.hs deleted file mode 100644 --- a/examples/RedBook/TessWind.hs +++ /dev/null @@ -1,195 +0,0 @@ -{- - TessWind.hs (adapted from tesswind.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates the winding rule polygon tessellation property. - Four tessellated objects are drawn, each with very different contours. When - the w key is pressed, the objects are drawn with a different winding rule. --} - -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { currentWindingRule :: IORef TessWinding } - -makeState :: IO State -makeState = do - c <- newIORef TessWindingOdd - return $ State { currentWindingRule = c } - -type DisplayLists = (DisplayList, DisplayList, DisplayList, DisplayList) - --- 'Float' is a dummy, any marshalable type would do -type DontCare = Float - -rect1 :: ComplexContour DontCare -rect1 = ComplexContour [ - AnnotatedVertex (Vertex3 50 50 0) 0, - AnnotatedVertex (Vertex3 300 50 0) 0, - AnnotatedVertex (Vertex3 300 300 0) 0, - AnnotatedVertex (Vertex3 50 300 0) 0 ] - -rect2 :: ComplexContour DontCare -rect2 = ComplexContour [ - AnnotatedVertex (Vertex3 100 100 0) 0, - AnnotatedVertex (Vertex3 250 100 0) 0, - AnnotatedVertex (Vertex3 250 250 0) 0, - AnnotatedVertex (Vertex3 100 250 0) 0 ] - -rect3 :: ComplexContour DontCare -rect3 = ComplexContour [ - AnnotatedVertex (Vertex3 150 150 0) 0, - AnnotatedVertex (Vertex3 200 150 0) 0, - AnnotatedVertex (Vertex3 200 200 0) 0, - AnnotatedVertex (Vertex3 150 200 0) 0 ] - -rects1 :: ComplexPolygon DontCare -rects1 = ComplexPolygon [ rect1, rect2, rect3 ] - -rects2 :: ComplexPolygon DontCare -rects2 = ComplexPolygon [ - rect1, reverseComplexContour rect2, reverseComplexContour rect3 ] - -spiral :: ComplexPolygon DontCare -spiral = ComplexPolygon [ - ComplexContour [ - AnnotatedVertex (Vertex3 400 250 0) 0, - AnnotatedVertex (Vertex3 400 50 0) 0, - AnnotatedVertex (Vertex3 50 50 0) 0, - AnnotatedVertex (Vertex3 50 400 0) 0, - AnnotatedVertex (Vertex3 350 400 0) 0, - AnnotatedVertex (Vertex3 350 100 0) 0, - AnnotatedVertex (Vertex3 100 100 0) 0, - AnnotatedVertex (Vertex3 100 350 0) 0, - AnnotatedVertex (Vertex3 300 350 0) 0, - AnnotatedVertex (Vertex3 300 150 0) 0, - AnnotatedVertex (Vertex3 150 150 0) 0, - AnnotatedVertex (Vertex3 150 300 0) 0, - AnnotatedVertex (Vertex3 250 300 0) 0, - AnnotatedVertex (Vertex3 250 200 0) 0, - AnnotatedVertex (Vertex3 200 200 0) 0, - AnnotatedVertex (Vertex3 200 250 0) 0 ] ] - -quad1 :: ComplexContour DontCare -quad1 = ComplexContour [ - AnnotatedVertex (Vertex3 50 150 0) 0, - AnnotatedVertex (Vertex3 350 150 0) 0, - AnnotatedVertex (Vertex3 350 200 0) 0, - AnnotatedVertex (Vertex3 50 200 0) 0 ] - -quad2 :: ComplexContour DontCare -quad2 = ComplexContour [ - AnnotatedVertex (Vertex3 100 100 0) 0, - AnnotatedVertex (Vertex3 300 100 0) 0, - AnnotatedVertex (Vertex3 300 350 0) 0, - AnnotatedVertex (Vertex3 100 350 0) 0 ] - -tri :: ComplexContour DontCare -tri = ComplexContour [ - AnnotatedVertex (Vertex3 200 50 0) 0, - AnnotatedVertex (Vertex3 250 300 0) 0, - AnnotatedVertex (Vertex3 150 300 0) 0 ] - -quadsAndTri :: ComplexPolygon DontCare -quadsAndTri = ComplexPolygon [ quad1, quad2, tri ] - -reverseComplexContour :: ComplexContour DontCare -> ComplexContour DontCare -reverseComplexContour (ComplexContour avs) = ComplexContour (reverse avs) - -makeNewLists :: State -> DisplayLists -> IO () -makeNewLists state (dl1, dl2, dl3, dl4) = do - windingRule <- get (currentWindingRule state) - print windingRule -- not in original program, but useful - compileList windingRule dl1 rects1 - compileList windingRule dl2 rects2 - compileList windingRule dl3 spiral - compileList windingRule dl4 quadsAndTri - -compileList :: TessWinding -> DisplayList -> ComplexPolygon DontCare -> IO () -compileList windingRule displayList complexPolygon = - defineList displayList Compile $ - drawSimplePolygon =<< - tessellate windingRule 0 (Normal3 0 0 0) noOpCombiner complexPolygon - -noOpCombiner :: Combiner DontCare -noOpCombiner _newVertex _weightedProperties = 0 - -drawSimplePolygon :: SimplePolygon DontCare -> IO () -drawSimplePolygon (SimplePolygon primitives) = - flip mapM_ primitives $ \(Primitive primitiveMode vertices) -> - renderPrimitive primitiveMode $ - flip mapM_ vertices $ \(AnnotatedVertex plainVertex _) -> - vertex plainVertex - -display :: DisplayLists -> DisplayCallback -display (dl1, dl2, dl3, dl4) = do - clear [ ColorBuffer ] - -- resolve overloading, not needed in "real" programs - let color3f = color :: Color3 GLfloat -> IO () - translatef = translate :: Vector3 GLfloat -> IO () - color3f (Color3 1 1 1) - preservingMatrix $ do - callList dl1 - translatef (Vector3 0 500 0) - callList dl2 - translatef (Vector3 500 (-500) 0) - callList dl3 - translatef (Vector3 0 500 0) - callList dl4 - flush - -myInit :: State -> IO DisplayLists -myInit state = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - [dl1, dl2, dl3, dl4] <- genObjectNames 4 - let displayLists = (dl1, dl2, dl3, dl4) - makeNewLists state displayLists - return displayLists - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho2D 0 1000 0 (1000 * hf/wf) - else ortho2D 0 (1000 * wf/hf) 0 1000 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: State -> DisplayLists -> KeyboardMouseCallback -keyboard state displayLists (Char c) Down _ _ = case toLower c of - 'w' -> do currentWindingRule state $~ nextWindingRule - makeNewLists state displayLists - postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ _ = return () - -nextWindingRule :: TessWinding -> TessWinding -nextWindingRule r = case r of - TessWindingOdd -> TessWindingNonzero - TessWindingNonzero -> TessWindingPositive - TessWindingPositive -> TessWindingNegative - TessWindingNegative -> TessWindingAbsGeqTwo - TessWindingAbsGeqTwo -> TessWindingOdd - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - createWindow progName - state <- makeState - displayLists <- myInit state - displayCallback $= display displayLists - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state displayLists) - mainLoop diff --git a/examples/RedBook/TexBind.hs b/examples/RedBook/TexBind.hs deleted file mode 100644 --- a/examples/RedBook/TexBind.hs +++ /dev/null @@ -1,108 +0,0 @@ -{- - TexBind.hs (adapted from texbind.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates using textureBinding by creating and managing - two textures. --} - -import Control.Monad ( when ) -import Data.Bits ( (.&.) ) -import Foreign ( withArray ) -import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Create checkerboard image -checkImageSize :: TextureSize2D -checkImageSize = TextureSize2D 64 64 - -withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) - -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () -withCheckImage (TextureSize2D w h) n f act = - withArray [ f c | - i <- [ 0 .. w - 1 ], - j <- [ 0 .. h - 1 ], - let c | (i .&. n) == (j .&. n) = 0 - | otherwise = 255 ] $ - act . PixelData RGBA UnsignedByte - -myInit :: IO (TextureObject, TextureObject) -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - depthFunc $= Just Less - rowAlignment Unpack $= 1 - - [texName0, texName1] <- genObjectNames 2 - textureBinding Texture2D $= Just texName0 - textureWrapMode Texture2D S $= (Repeated, Clamp) - textureWrapMode Texture2D T $= (Repeated, Clamp) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - withCheckImage checkImageSize 0x08 (\c -> Color4 c c c 255) $ - texImage2D Nothing NoProxy 0 RGBA' checkImageSize 0 - - textureBinding Texture2D $= Just texName1 - textureWrapMode Texture2D S $= (Repeated, Clamp) - textureWrapMode Texture2D T $= (Repeated, Clamp) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - textureFunction $= Decal - withCheckImage checkImageSize 0x10 (\c -> Color4 c 0 0 255) $ - texImage2D Nothing NoProxy 0 RGBA' checkImageSize 0 - texture Texture2D $= Enabled - return (texName0, texName1) - -display :: (TextureObject, TextureObject) -> DisplayCallback -display (texName0, texName1) = do - clear [ ColorBuffer, DepthBuffer ] - -- resolve overloading, not needed in "real" programs - let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - textureBinding Texture2D $= Just texName0 - renderPrimitive Quads $ do - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) - texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) - texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 ) - texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) - textureBinding Texture2D $= Just texName1 - renderPrimitive Quads $ do - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) - texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 ) - texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) - texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 60 (fromIntegral w / fromIntegral h) 1 30 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-3.6 :: GLfloat)) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - createWindow progName - -- we have to do this *after* createWindow, otherwise we have no OpenGL context - version <- get (majorMinor glVersion) - when (version == (1,0)) $ do - putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." - putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," - putStrLn "you may be able to modify this program to make it run." - exitFailure - texNames <- myInit - reshapeCallback $= Just reshape - displayCallback $= display texNames - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/TexGen.hs b/examples/RedBook/TexGen.hs deleted file mode 100644 --- a/examples/RedBook/TexGen.hs +++ /dev/null @@ -1,132 +0,0 @@ -{- - TexGen.hs (adapted from texgen.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws a texture mapped teapot with automatically generated - texture coordinates. The texture is rendered as stripes on the teapot. - Initially, the object is drawn with texture coordinates based upon the - object coordinates of the vertex and distance from the plane x = 0. - Pressing the 'e' key changes the coordinate generation to eye coordinates - of the vertex. Pressing the 'o' key switches it back to the object - coordinates. Pressing the 's' key changes the plane to a slanted one - (x + y + z = 0). Pressing the 'x' key switches it back to x = 0. --} - -import Control.Monad ( when ) -import Data.Char ( toLower ) -import Data.Maybe ( isJust, listToMaybe ) -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -stripeImageWidth :: TextureSize1D -stripeImageWidth = TextureSize1D 32 - -xEqualZero, slanted :: Plane GLdouble -xEqualZero = Plane 1 0 0 0 -slanted = Plane 1 1 1 0 - -withStripeImage :: (PixelData (Color4 GLubyte) -> IO a) -> IO a -withStripeImage act = - withArray [ Color4 (if j <= 4 then 255 else 0) - (if j > 4 then 255 else 0) - 0 - 255 - | j <- [ 0 .. w - 1 ] ] $ - act . PixelData RGBA UnsignedByte - where TextureSize1D w = stripeImageWidth - -myInit :: IO (Maybe TextureObject) -myInit = do - clearColor $= Color4 0 0 0 0 - depthFunc $= Just Less - shadeModel $= Smooth - rowAlignment Unpack $= 1 - - exts <- get glExtensions - mbTexName <- if "GL_EXT_texture_object" `elem` exts - then fmap listToMaybe $ genObjectNames 1 - else return Nothing - when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName - - textureWrapMode Texture1D S $= (Repeated, Repeat) - textureFilter Texture1D $= ((Linear', Nothing), Linear') - withStripeImage $ texImage1D NoProxy 0 RGBA' stripeImageWidth 0 - - textureFunction $= Modulate - textureGenMode S $= Just (ObjectLinear xEqualZero) - - texture Texture1D $= Enabled - lighting $= Enabled - light (Light 0) $= Enabled - autoNormal $= Enabled - normalize $= Enabled - frontFace $= CW - cullFace $= Just Back - materialShininess Front $= 64 - return mbTexName - -display :: Maybe TextureObject -> DisplayCallback -display mbTexName = do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - rotate (45 :: GLfloat) (Vector3 0 0 1) - when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName - renderObject Solid (Teapot 2) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-3.5) 3.5 (-3.5*hf/wf) (3.5*hf/wf) (-3.5) 3.5 - else ortho (-3.5*wf/hf) (3.5*wf/hf) (-3.5) 3.5 (-3.5) 3.5 - matrixMode $= Modelview 0 - loadIdentity - -keyboard :: KeyboardMouseCallback -keyboard (Char c) Down _ _ = case toLower c of - 'e' -> setGenMode EyeLinear - 'o' -> setGenMode ObjectLinear - 's' -> setPlane slanted - 'x' -> setPlane xEqualZero - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ = return () - -setGenMode :: (Plane GLdouble -> TextureGenMode) -> IO () -setGenMode mode = do - currentGenMode <- get (textureGenMode S) - case currentGenMode of - Just (EyeLinear plane) -> textureGenMode S $= Just (mode plane) - Just (ObjectLinear plane) -> textureGenMode S $= Just (mode plane) - _ -> error "setGenMode: should never happen..." - postRedisplay Nothing - -setPlane :: Plane GLdouble -> IO () -setPlane plane = do - currentGenMode <- get (textureGenMode S) - case currentGenMode of - Just (EyeLinear _) -> textureGenMode S $= Just (EyeLinear plane) - Just (ObjectLinear _) -> textureGenMode S $= Just (ObjectLinear plane) - _ -> error "setPlane: should never happen..." - postRedisplay Nothing - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 256 256 - initialWindowPosition $= Position 100 100 - createWindow progName - mbTexName <- myInit - displayCallback $= display mbTexName - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/TexProx.hs b/examples/RedBook/TexProx.hs deleted file mode 100644 --- a/examples/RedBook/TexProx.hs +++ /dev/null @@ -1,58 +0,0 @@ -{- - TexProx.hs (adapted from texprox.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - The brief program illustrates use of texture proxies. This program only - prints out some messages about whether certain size textures are supported - and then exits. --} - -import Control.Monad ( when ) -import Foreign.Ptr ( nullPtr ) -import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -myInit :: IO () -myInit = do - let check = do - ok <- get (textureProxyOK (Left Texture2D) 0) - putStrLn ("proxy allocation " ++ if ok then "succeeded" else "failed") - - texImage2D Nothing Proxy 0 RGBA8 (TextureSize2D 64 64) 0 (PixelData RGBA UnsignedByte nullPtr) - check - - -- Note: We use a larger texture size here to demonstrate failure, - -- modern graphic cards can handle the original size. - texImage2D Nothing Proxy 0 RGBA16 (TextureSize2D 8192 8192) 0 (PixelData RGBA UnsignedShort nullPtr) - check - - -display :: DisplayCallback -display = exitWith ExitSuccess - -reshape :: ReshapeCallback -reshape size = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - -- we have to do this *after* createWindow, otherwise we have no OpenGL context - version <- get (majorMinor glVersion) - when (version == (1,0)) $ do - putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." - putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," - putStrLn "you may be able to modify this program to make it run." - exitFailure - myInit - displayCallback $= display - reshapeCallback $= Just reshape - mainLoop diff --git a/examples/RedBook/TexSub.hs b/examples/RedBook/TexSub.hs deleted file mode 100644 --- a/examples/RedBook/TexSub.hs +++ /dev/null @@ -1,120 +0,0 @@ -{- - TexSub.hs (adapted from texsub.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program texture maps a checkerboard image onto two rectangles. This - program clamps the texture, if the texture coordinates fall outside 0.0 - and 1.0. If the s key is pressed, a texture subimage is used to alter the - original texture. If the r key is pressed, the original texture is restored. --} - -import Control.Monad ( when ) -import Data.Char ( toLower ) -import Data.Bits ( (.&.) ) -import Foreign ( newArray ) -import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -checkImageSize, subImageSize :: TextureSize2D -checkImageSize = TextureSize2D 64 64 -subImageSize = TextureSize2D 16 16 - -type Image = PixelData (Color4 GLubyte) - -makeCheckImage :: - TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) -> IO Image -makeCheckImage (TextureSize2D w h) n f = - fmap (PixelData RGBA UnsignedByte) $ - newArray [ f c | - i <- [ 0 .. w - 1 ], - j <- [ 0 .. h - 1 ], - let c | (i .&. n) == (j .&. n) = 0 - | otherwise = 255 ] - -myInit :: IO (TextureObject, Image, Image) -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - depthFunc $= Just Less - - checkImage <- makeCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) - subImage <- makeCheckImage subImageSize 0x4 (\c -> Color4 c 0 0 255) - rowAlignment Unpack $= 1 - - [texName] <- genObjectNames 1 - textureBinding Texture2D $= Just texName - - textureWrapMode Texture2D S $= (Repeated, Repeat) - textureWrapMode Texture2D T $= (Repeated, Repeat) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - texImage2D Nothing NoProxy 0 RGBA' checkImageSize 0 checkImage - return (texName, checkImage, subImage) - -display :: TextureObject -> DisplayCallback -display texName = do - clear [ ColorBuffer, DepthBuffer ] - texture Texture2D $= Enabled - textureFunction $= Decal - textureBinding Texture2D $= Just texName - - -- resolve overloading, not needed in "real" programs - let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - renderPrimitive Quads $ do - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) - texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) - texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 ) - texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) - - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) - texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 ) - texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) - texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) - flush - texture Texture2D $= Disabled - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 60 (fromIntegral w / fromIntegral h) 1 30 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-3.6 :: GLfloat)) - -keyboard :: TextureObject -> Image -> Image -> KeyboardMouseCallback -keyboard texName checkImage subImage (Char c) Down _ _ = case toLower c of - 's' -> do - textureBinding Texture2D $= Just texName - texSubImage2D Nothing 0 (TexturePosition2D 12 44) subImageSize subImage - postRedisplay Nothing - 'r' -> do - textureBinding Texture2D $= Just texName - texImage2D Nothing NoProxy 0 RGBA' checkImageSize 0 checkImage - postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - createWindow progName - -- we have to do this *after* createWindow, otherwise we have no OpenGL context - version <- get (majorMinor glVersion) - when (version == (1,0)) $ do - putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." - putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," - putStrLn "you may be able to modify this program to make it run." - exitFailure - (texName, checkImage, subImage) <- myInit - displayCallback $= display texName - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard texName checkImage subImage) - mainLoop diff --git a/examples/RedBook/Texture3D.hs b/examples/RedBook/Texture3D.hs deleted file mode 100644 --- a/examples/RedBook/Texture3D.hs +++ /dev/null @@ -1,94 +0,0 @@ -{- - Texture3D.hs (adapted from texture3d.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates using a three-dimensional texture. It creates - a 3D texture and then renders two rectangles with different texture - coordinates to obtain different "slices" of the 3D texture. --} - -import Control.Monad ( unless ) -import Foreign ( withArray ) -import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Create checkerboard image -imageSize :: TextureSize3D -imageSize = TextureSize3D 16 16 16 - -withImage :: (PixelData (Color3 GLubyte) -> IO ()) -> IO () -withImage act = - withArray [ Color3 (s * 17) (t * 17) (r * 17) | - r <- [ 0 .. fromIntegral d - 1 ], - t <- [ 0 .. fromIntegral h - 1 ], - s <- [ 0 .. fromIntegral w - 1 ] ] $ - act . PixelData RGB UnsignedByte - where (TextureSize3D w h d) = imageSize - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - depthFunc $= Just Less - rowAlignment Unpack $= 1 - - [texName] <- genObjectNames 1 - textureBinding Texture3D $= Just texName - textureWrapMode Texture3D S $= (Repeated, Clamp) - textureWrapMode Texture3D T $= (Repeated, Clamp) - textureWrapMode Texture3D R $= (Repeated, Clamp) - textureFilter Texture3D $= ((Nearest, Nothing), Nearest) - withImage $ texImage3D NoProxy 0 RGB' imageSize 0 - texture Texture3D $= Enabled - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - -- resolve overloading, not needed in "real" programs - let texCoord3f = texCoord :: TexCoord3 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - renderPrimitive Quads $ do - texCoord3f (TexCoord3 0 0 0); vertex3f (Vertex3 (-2.25) (-1) 0) - texCoord3f (TexCoord3 0 1 0); vertex3f (Vertex3 (-2.25) 1 0) - texCoord3f (TexCoord3 1 1 1); vertex3f (Vertex3 (-0.25) 1 0) - texCoord3f (TexCoord3 1 0 1); vertex3f (Vertex3 (-0.25) (-1) 0) - - texCoord3f (TexCoord3 0 0 1); vertex3f (Vertex3 0.25 (-1) 0) - texCoord3f (TexCoord3 0 1 1); vertex3f (Vertex3 0.25 1 0) - texCoord3f (TexCoord3 1 1 0); vertex3f (Vertex3 2.25 1 0) - texCoord3f (TexCoord3 1 0 0); vertex3f (Vertex3 2.25 (-1) 0) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 60 (fromIntegral w / fromIntegral h) 1 30 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-4 :: GLfloat)) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - createWindow progName - -- we have to do this *after* createWindow, otherwise we have no OpenGL context - exts <- get glExtensions - unless ("GL_EXT_texture3D" `elem` exts) $ do - putStrLn "Sorry, this demo requires the GL_EXT_texture3D extension." - exitFailure - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/TextureSurf.hs b/examples/RedBook/TextureSurf.hs deleted file mode 100644 --- a/examples/RedBook/TextureSurf.hs +++ /dev/null @@ -1,99 +0,0 @@ -{- - TextureSurf.hs (adapted from texturesurf.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program uses evaluators to generate a curved surface and automatically - generated texture coordinates. --} - -import Data.List ( transpose ) -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -ctrlPoints :: [[Vertex3 GLfloat]] -ctrlPoints = [ - [ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0, - Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ], - [ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0, - Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ], - [ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0, - Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ], - [ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0), - Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]] - -texPts :: [[TexCoord2 GLfloat]] -texPts = [ - [ TexCoord2 0 0, TexCoord2 0 1 ], - [ TexCoord2 1 0, TexCoord2 1 1 ]] - -display :: DisplayCallback -display = do - clear [ ColorBuffer, DepthBuffer ] - color (Color3 1 1 1 :: Color3 GLfloat) - evalMesh2 Fill (0, 20) (0, 20) - flush - -imageSize :: TextureSize2D -imageSize = TextureSize2D 64 64 - -withImage :: (PixelData (Color3 GLubyte) -> IO ()) -> IO () -withImage act = - withArray [ Color3 (s (sin ti)) (s (cos (2 * tj))) (s (cos (ti + tj))) | - i <- [ 0 .. fromIntegral w - 1 ], - let ti = 2 * pi * i / fromIntegral w, - j <- [ 0 .. fromIntegral h - 1 ], - let tj = 2 * pi * j / fromIntegral h ] $ - act . PixelData RGB UnsignedByte - where (TextureSize2D w h) = imageSize - s :: Double -> GLubyte - s x = truncate (127 * (1 + x)) - -myInit :: IO () -myInit = do - m <- newMap2 (0, 1) (0, 1) (transpose ctrlPoints) - map2 $= Just (m :: GLmap2 Vertex3 GLfloat) - t <- newMap2 (0, 1) (0, 1) (transpose texPts) - map2 $= Just (t :: GLmap2 TexCoord2 GLfloat) - mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat))) - textureFunction $= Decal - textureWrapMode Texture2D S $= (Repeated, Repeat) - textureWrapMode Texture2D T $= (Repeated, Repeat) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - withImage $ texImage2D Nothing NoProxy 0 RGB' imageSize 0 - texture Texture2D $= Enabled - depthFunc $= Just Less - shadeModel $= Flat - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - let wf = fromIntegral w - hf = fromIntegral h - if w <= h - then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0 - else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0 - matrixMode $= Modelview 0 - loadIdentity - rotate (85 :: GLfloat) (Vector3 1 1 1) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/Torus.hs b/examples/RedBook/Torus.hs deleted file mode 100644 --- a/examples/RedBook/Torus.hs +++ /dev/null @@ -1,93 +0,0 @@ -{- - Torus.hs (adapted from torus.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2006 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates the creation of a display list. --} - -import Data.Char ( toLower ) -import Data.IORef ( IORef, newIORef ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -data State = State { spinX, spinY :: IORef GLfloat } - -makeState :: IO State -makeState = do - x <- newIORef 0 - y <- newIORef 0 - return $ State { spinX = x, spinY = y } - -torus :: Int -> Int -> IO () -torus numC numT = do - let stepC = 2 * pi / fromIntegral numC :: GLfloat - stepT = 2 * pi / fromIntegral numT - flip mapM_ [ 0 .. numC - 1 ] $ \i -> - renderPrimitive QuadStrip $ - flip mapM_ [ 0 .. numT ] $ \j -> - flip mapM_ [ 1, 0 ] $ \k -> do - let s = (fromIntegral ((i + k) `mod` numC) + 0.5) * stepC - t = (fromIntegral ( j `mod` numT) ) * stepT - x = (1 + 0.1 * cos s) * cos t - y = (1 + 0.1 * cos s) * sin t - z = 0.1 * sin s - vertex (Vertex3 x y z) - -myInit :: IO DisplayList -myInit = do - theTorus <- defineNewList Compile $ - torus 8 25 - shadeModel $= Flat - clearColor $= Color4 0 0 0 0 - return theTorus - -display :: State -> DisplayList -> DisplayCallback -display state theTorus = do - clear [ ColorBuffer ] - loadIdentity - lookAt (Vertex3 0 0 10) (Vertex3 0 0 0) (Vector3 0 1 0) - x <- get (spinX state) - rotate x (Vector3 1 0 0) - y <- get (spinY state) - rotate y (Vector3 0 1 0) - color (Color3 1 1 (1 :: GLfloat)) - callList theTorus - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 30 (fromIntegral w / fromIntegral h) 1 100 - matrixMode $= Modelview 0 - -incSpin :: IORef GLfloat -> IO () -incSpin spinRef = do - let wrap n s = if s > n then s - n else s - spinRef $~ (wrap 360 . (+ 30)) - postRedisplay Nothing - -keyboard :: State -> KeyboardMouseCallback -keyboard state (Char c) Down _ _ = case toLower c of - 'x' -> incSpin (spinX state) - 'y' -> incSpin (spinY state) - 'i' -> do spinX state $= 0; spinY state $= 0; postRedisplay Nothing - '\27' -> exitWith ExitSuccess - _ -> return () -keyboard _ _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 200 200 - createWindow progName - state <- makeState - theTorus <- myInit - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboard state) - displayCallback $= display state theTorus - mainLoop diff --git a/examples/RedBook/Trim.hs b/examples/RedBook/Trim.hs deleted file mode 100644 --- a/examples/RedBook/Trim.hs +++ /dev/null @@ -1,107 +0,0 @@ -{- - Trim.hs (adapted from trim.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program draws a NURBS surface in the shape of a symmetrical hill, - using both a NURBS curve and pwl (piecewise linear) curve to trim part - of the surface. - - NOTE: This example does NOT demonstrate the final NURBS API, it's currently - just a test for the internals... --} - -import Foreign.Marshal ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- The control points of the surface form a small hill and --- range from -3 to +3 in x, y, and z. -ctlPoints :: [[Vertex3 GLfloat]] -ctlPoints = - [ [ Vertex3 (2 * u - 3) - (2 * v - 3) - (if (u == 1 || u ==2) && (v == 1 || v == 2) then 3 else -3) - | v <- [ 0 .. 3 ] ] - | u <- [ 0 .. 3 ]] - -myInit :: IO () -myInit = do - clearColor $= Color4 0 0 0 0 - materialDiffuse Front $= Color4 0.7 0.7 0.7 1 - materialSpecular Front $= Color4 1 1 1 1 - materialShininess Front $= 100 - - lighting $= Enabled - light (Light 0) $= Enabled - depthFunc $= Just Less - autoNormal $= Enabled - normalize $= Enabled - --------------------------------------------------------------------------------- - -display :: DisplayCallback -display = do - let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] - edgePt = -- counter clockwise - [ Vertex2 0 0, Vertex2 1 0, Vertex2 1 1, Vertex2 0 1, Vertex2 0 0 ] :: [Vertex2 GLfloat] - curvePt = -- clockwise - [ Vertex2 0.25 0.5, Vertex2 0.25 0.75, Vertex2 0.75 0.75, Vertex2 0.75 0.5 ] :: [Vertex2 GLfloat] - curveKnots = - [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] - pwlPt = -- clockwise - [Vertex2 0.75 0.5, Vertex2 0.5 0.25, Vertex2 0.25 0.5 ] :: [Vertex2 GLfloat] - - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - rotate (330 :: GLfloat) (Vector3 1 0 0) - scale 0.5 0.5 (0.5 :: GLfloat) - - withNURBSObj () $ \nurbsObj -> do - setSamplingMethod nurbsObj (PathLength 25) - setDisplayMode' nurbsObj Fill' - checkForNURBSError nurbsObj $ - nurbsBeginEndSurface nurbsObj $ - withArray (concat ctlPoints) $ \cBuf -> - withArray knots $ \kBuf -> do - nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4 - nurbsBeginEndTrim nurbsObj $ - withArray edgePt $ \edgePtBuf -> - pwlCurve nurbsObj 5 edgePtBuf 2 - nurbsBeginEndTrim nurbsObj $ do - withArray curveKnots $ \curveKnotsBuf -> - withArray curvePt $ \curvePtBuf -> - trimmingCurve nurbsObj 8 curveKnotsBuf 2 curvePtBuf 4 - withArray pwlPt $ \pwlPtBuf -> - pwlCurve nurbsObj 3 pwlPtBuf 2 - - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 45 (fromIntegral w / fromIntegral h) 3 8 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-5 :: GLfloat)) - -keyboard :: KeyboardMouseCallback -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - --- Main Loop -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - myInit - reshapeCallback $= Just reshape - displayCallback $= display - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook/UnProject.hs b/examples/RedBook/UnProject.hs deleted file mode 100644 --- a/examples/RedBook/UnProject.hs +++ /dev/null @@ -1,54 +0,0 @@ -{- - UnProject.hs (adapted from unproject.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - When the left mouse button is pressed, this program reads the mouse - position and determines two 3D points from which it was transformed. - Very little is displayed. --} - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - -display :: DisplayCallback -display = do - clear [ ColorBuffer ] - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 45 (fromIntegral w / fromIntegral h) 1 100 - matrixMode $= Modelview 0 - loadIdentity - -keyboardMouse :: KeyboardMouseCallback -keyboardMouse (MouseButton LeftButton) Down _ (Position x y) = do - v@(_, Size _ h) <- get viewport - mvMatrix <- get (matrix (Just (Modelview 0))) :: IO (GLmatrix GLdouble) - projMatrix <- get (matrix (Just Projection)) :: IO (GLmatrix GLdouble) - let realY = fromIntegral h - y -1 - putStrLn ("Coordinates at cursor are (" ++ show x ++", " ++ show realY ++ ")") - w0 <- unProject (Vertex3 (fromIntegral x) (fromIntegral realY) 0) mvMatrix projMatrix v - putStrLn ("World coords at z=0.0 are " ++ show w0) - w1 <- unProject (Vertex3 (fromIntegral x) (fromIntegral realY) 1) mvMatrix projMatrix v - putStrLn ("World coords at z=1.0 are " ++ show w1) -keyboardMouse (MouseButton RightButton) Down _ _ = exitWith ExitSuccess -keyboardMouse (Char '\27') Down _ _ = exitWith ExitSuccess -keyboardMouse _ _ _ _ = return () - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 500 500 - initialWindowPosition $= Position 100 100 - createWindow progName - displayCallback $= display - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboardMouse - mainLoop diff --git a/examples/RedBook/VArray.hs b/examples/RedBook/VArray.hs deleted file mode 100644 --- a/examples/RedBook/VArray.hs +++ /dev/null @@ -1,141 +0,0 @@ -{- - VArray.hs (adapted from varray.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program demonstrates vertex arrays. --} - -import Control.Monad ( when ) -import Data.IORef ( IORef, newIORef ) -import Foreign ( Ptr, newArray ) -import System.Exit ( exitFailure, exitWith, ExitCode(..) ) -import Graphics.UI.GLUT - -data SetupMethod = Pointer | Interleaved - deriving ( Eq, Bounded, Enum ) - -data DerefMethod = DrawArray | ArrayElement | DrawElements - deriving ( Eq, Bounded, Enum ) - -makeVertices :: IO (Ptr (Vertex2 GLint)) -makeVertices = newArray [ - Vertex2 25 25, - Vertex2 100 325, - Vertex2 175 25, - Vertex2 175 325, - Vertex2 250 25, - Vertex2 325 325 ] - -makeColors :: IO (Ptr (Color3 GLfloat)) -makeColors = newArray [ - Color3 1.0 0.2 0.2, - Color3 0.2 0.2 1.0, - Color3 0.8 1.0 0.2, - Color3 0.75 0.75 0.75, - Color3 0.35 0.35 0.35, - Color3 0.5 0.5 0.5 ] - -makeIntertwined :: IO (Ptr GLfloat) -makeIntertwined = newArray [ - 1.0, 0.2, 1.0, 100.0, 100.0, 0.0, - 1.0, 0.2, 0.2, 0.0, 200.0, 0.0, - 1.0, 1.0, 0.2, 100.0, 300.0, 0.0, - 0.2, 1.0, 0.2, 200.0, 300.0, 0.0, - 0.2, 1.0, 1.0, 300.0, 200.0, 0.0, - 0.2, 0.2, 1.0, 200.0, 100.0, 0.0 ] - -makeIndices :: IO (Ptr GLuint) -makeIndices = newArray [ 0, 1, 3, 4 ] - -data State = State { - vertices :: Ptr (Vertex2 GLint), - colors :: Ptr (Color3 GLfloat), - intertwined :: Ptr GLfloat, - indices :: Ptr GLuint, - setupMethod :: IORef SetupMethod, - derefMethod :: IORef DerefMethod } - -makeState :: IO State -makeState = do - v <- makeVertices - c <- makeColors - i <- makeIntertwined - n <- makeIndices - s <- newIORef Pointer - d <- newIORef DrawArray - return $ State { vertices = v, colors = c, intertwined = i, - indices = n, setupMethod = s, derefMethod = d } - -setup :: State -> IO () -setup state = do - s <- get (setupMethod state) - case s of - Pointer -> do - clientState VertexArray $= Enabled - clientState ColorArray $= Enabled - arrayPointer VertexArray $= VertexArrayDescriptor 2 Int 0 (vertices state) - arrayPointer ColorArray $= VertexArrayDescriptor 3 Float 0 (colors state) - Interleaved -> - interleavedArrays C3fV3f 0 (intertwined state) - -myInit :: State -> IO () -myInit state = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Smooth - setup state - -display :: State -> DisplayCallback -display state = do - clear [ ColorBuffer ] - d <- get (derefMethod state) - case d of - DrawArray -> drawArrays Triangles 0 6 - ArrayElement -> renderPrimitive Triangles $ mapM_ arrayElement [ 2, 3, 5 ] - DrawElements -> drawElements Polygon 4 UnsignedInt (indices state) - flush - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - ortho2D 0 (fromIntegral w) 0 (fromIntegral h) - -- the following line is not in the original example, but it's good style... - matrixMode $= Modelview 0 - -keyboardMouse :: State -> KeyboardMouseCallback -keyboardMouse state (MouseButton LeftButton) Down _ _ = do - setupMethod state $~ nextValue - setup state - postRedisplay Nothing -keyboardMouse state (MouseButton _) Down _ _ = do - derefMethod state $~ nextValue - postRedisplay Nothing -keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess -keyboardMouse _ _ _ _ _ = return () - -nextValue :: (Eq a, Bounded a, Enum a) => a -> a -nextValue x = if x == maxBound then minBound else succ x - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode ] - initialWindowSize $= Size 350 350 - initialWindowPosition $= Position 100 100 - createWindow progName - -- we have to do this *after* createWindow, otherwise we have no OpenGL context - version <- get (majorMinor glVersion) - when (version == (1,0)) $ do - putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." - putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," - putStrLn "you may be able to modify this program to make it run." - exitFailure - state <- makeState - myInit state - displayCallback $= display state - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just (keyboardMouse state) - mainLoop diff --git a/examples/RedBook/Wrap.hs b/examples/RedBook/Wrap.hs deleted file mode 100644 --- a/examples/RedBook/Wrap.hs +++ /dev/null @@ -1,114 +0,0 @@ -{- - Wrap.hs (adapted from wrap.c which is (c) Silicon Graphics, Inc) - Copyright (c) Sven Panne 2002-2005 - This file is part of HOpenGL and distributed under a BSD-style license - See the file libraries/GLUT/LICENSE - - This program texture maps a checkerboard image onto two rectangles. This - program demonstrates the wrapping modes, if the texture coordinates fall - outside 0.0 and 1.0. Interaction: Pressing the 's' and 'S' keys switch the - wrapping between clamping and repeating for the s parameter. The 't' and 'T' - keys control the wrapping for the t parameter. - - Texture objects are only used when GL_EXT_texture_object is supported. --} - -import Control.Monad ( when ) -import Data.Maybe ( isJust, listToMaybe ) -import Data.Bits ( (.&.) ) -import Foreign ( withArray ) -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import Graphics.UI.GLUT - --- Create checkerboard image -checkImageSize :: TextureSize2D -checkImageSize = TextureSize2D 64 64 - -withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) - -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () -withCheckImage (TextureSize2D w h) n f act = - withArray [ f c | - i <- [ 0 .. w - 1 ], - j <- [ 0 .. h - 1 ], - let c | (i .&. n) == (j .&. n) = 0 - | otherwise = 255 ] $ - act. PixelData RGBA UnsignedByte - -myInit :: IO (Maybe TextureObject) -myInit = do - clearColor $= Color4 0 0 0 0 - shadeModel $= Flat - depthFunc $= Just Less - rowAlignment Unpack $= 1 - - exts <- get glExtensions - mbTexName <- if "GL_EXT_texture_object" `elem` exts - then fmap listToMaybe $ genObjectNames 1 - else return Nothing - when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName - - textureWrapMode Texture2D S $= (Repeated, Repeat) - textureWrapMode Texture2D T $= (Repeated, Repeat) - textureFilter Texture2D $= ((Nearest, Nothing), Nearest) - withCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) $ - texImage2D Nothing NoProxy 0 RGBA' checkImageSize 0 - return mbTexName - -display :: Maybe TextureObject -> DisplayCallback -display mbTexName = do - clear [ ColorBuffer, DepthBuffer ] - texture Texture2D $= Enabled - textureFunction $= Decal - when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName - - -- resolve overloading, not needed in "real" programs - let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () - vertex3f = vertex :: Vertex3 GLfloat -> IO () - renderPrimitive Quads $ do - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) - texCoord2f (TexCoord2 0 3); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) - texCoord2f (TexCoord2 3 3); vertex3f (Vertex3 0.0 1.0 0.0 ) - texCoord2f (TexCoord2 3 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) - - texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) - texCoord2f (TexCoord2 0 3); vertex3f (Vertex3 1.0 1.0 0.0 ) - texCoord2f (TexCoord2 3 3); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) - texCoord2f (TexCoord2 3 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) - flush - texture Texture2D $= Disabled - -reshape :: ReshapeCallback -reshape size@(Size w h) = do - viewport $= (Position 0 0, size) - matrixMode $= Projection - loadIdentity - perspective 60 (fromIntegral w / fromIntegral h) 1 30 - matrixMode $= Modelview 0 - loadIdentity - translate (Vector3 0 0 (-3.6 :: GLfloat)) - -keyboard :: KeyboardMouseCallback -keyboard (Char 's' ) Down _ _ = setClamping S Clamp -keyboard (Char 'S' ) Down _ _ = setClamping S Repeat -keyboard (Char 't' ) Down _ _ = setClamping T Clamp -keyboard (Char 'T' ) Down _ _ = setClamping T Repeat -keyboard (Char '\27') Down _ _ = exitWith ExitSuccess -keyboard _ _ _ _ = return () - -setClamping :: TextureCoordName -> Clamping -> IO () -setClamping coord clamp = do - textureWrapMode Texture2D coord $= (Repeated, clamp); - postRedisplay Nothing - -main :: IO () -main = do - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= Size 250 250 - initialWindowPosition $= Position 100 100 - createWindow progName - mbTexName <- myInit - displayCallback $= display mbTexName - reshapeCallback $= Just reshape - keyboardMouseCallback $= Just keyboard - mainLoop diff --git a/examples/RedBook4/00-README b/examples/RedBook4/00-README new file mode 100644 --- /dev/null +++ b/examples/RedBook4/00-README @@ -0,0 +1,189 @@ +This file lists the programs that are referenced in the OpenGL Programming +Guide, Fourth Edition, by chapter. For each program, the version of OpenGL +that is required is listed with the program. + +Chapter 1: Introduction to OpenGL + + Hello.hs (1.0) + Double.hs (1.0) + +Chapter 2: State Management and Drawing Geometric Objects + + Lines.hs (1.0) + Polys.hs (1.0) + VArray.hs (1.1) + MVArray.hs (1.4) + +Chapter 3: Viewing + + Cube.hs (1.0) + Model.hs (1.0) + Clip.hs (1.0) + Planet.hs (1.0) + Robot.hs (1.0) + UnProject.hs (1.1) + +Chapter 4: Color + + Smooth.hs (1.0) + +Chapter 5: Lighting + + Light.hs (1.0) + MoveLight.hs (1.0) + Material.hs (1.0) + ColorMat.hs (1.1) + Scene.hs (1.0) + +Chapter 6: Blending, Antialiasing, Fog, and Polygon Offset + + BlendEqn.hs (1.3 or ARB_imaging_subset) + Alpha.hs (1.0) + Alpha3D.hs (1.1) + AARGB.hs (1.1) + AAIndex.hs (1.1) + Multisamp.hs (1.3) + Fog.hs (1.0) + FogIndex.hs (1.0) + FogCoord.hs (1.4) + PointP.hs (1.4) + PolyOff.hs (1.1) + +Chapter 7: Display Lists + + Torus.hs (1.0) + DList.hs (1.0) + Stroke.hs (1.0) + +Chapter 8: Drawing Pixels, Bitmaps, Fonts, and Images + + DrawF.hs (1.0) + Font.hs (1.0) + Image.hs (1.1) + ColorTable.hs (ARB_imaging_subset) + Convolution.hs (ARB_imaging_subset) + ColorMatrix.hs (ARB_imaging_subset) + Histogram.hs (ARB_imaging_subset) + Minmax.hs (ARB_imaging_subset) + +Chapter 9: Texture Mapping + + Checker.hs (1.0) + TexSub.hs (1.1) + Texture3D.hs (1.2) + Mipmap.hs (1.0) + TexBind.hs (1.1) + TexGen.hs (1.1) + CubeMap.hs (1.3) + MultiTex.hs (1.3 or ARB_multitexture) + Combiner.hs (1.3) + ShadowMap.hs (1.4) + Wrap.hs (1.0) + TexProx.hs (1.1) + +Chapter 10: The Framebuffer + + Stencil.hs (1.0) + AccPersp.hs (1.0) + AccAnti.hs (1.0) + DOF.hs (1.0) + +Chapter 11: Tessellators and Quadrics + + Tess.hs (1.1) + TessWind.hs (1.1) + Quadric.hs (1.1) + +Chapter 12: Evaluators and NURBS + + BezCurve.hs (1.1) + BezSurf.hs (1.1) + BezMesh.hs (1.1) + TextureSurf.hs (1.1) + Surface.hs (1.1) + SurfPoints.hs (1.2) + Trim.hs (1.1) + +Chapter 13: Selection and Feedback + + Select.hs (1.1) + PickSquare.hs (1.0) + PickDepth.hs (1.0) + Feedback.hs (1.0) + +Chapter 14: Now That You Know + + + +Color Plates: + + Teapots.hs (1.1) + +Some remarks regarding the style of the programs: + +To ease comparisons, the Haskell programs in this directory try to stay as +close to the original examples in C as possible. Consequently, they should +not be considered as examples for the best way to implement things in +Haskell. + +The Haskell OpenGL binding uses overloading quite extensively, which makes +its use quite flexible, e.g.: + + class Vertex a where + vertex :: a -> IO () + vertexv :: Ptr a -> IO () + +This single class subsumes all 24 vertex specification calls in OpenGL's C +binding, i.e. glVertex{234}{sifd}[v](), with the help of the following +class and instances: + + class VertexComponent a -- an opaque class + + VertexComponent GLshort + VertexComponent GLint + VertexComponent GLfloat + VertexComponent GLdouble + + VertexComponent a => Vertex (Vertex2 a) + VertexComponent a => Vertex (Vertex3 a) + VertexComponent a => Vertex (Vertex4 a) + +There is a small inconvenience with this when used in "toy" programs: +Haskell's numeric literals are overloaded, too, so the programmer's help is +needed to disambiguate the type of expressions like: + + vertex (Vertex3 0 0 1) + +Let's assume we mean the equivalent of glVertex3f() here. One can either +use an explicitly typed helper function: + + let vertex3f = vertex :: Vertex3 GLfloat -> IO () + in vertex3f (Vertex3 0 0 1) + +This comes in handy when there are a lot of uses of vertex3f. An +alternative is to use a type annotation for the literal: + + vertex (Vertex3 0 0 (1 :: GLfloat)) + +or a type annotation for the vertex: + + vertex (Vertex3 0 0 1 :: Vertex3 GLfloat) + +This is largely a matter of taste and normally not a problem in "real" +programs with type signatures for functions. + +Sometimes different callbacks need to share some state, which is done via +global variables in the C examples. To achieve a unified presentation, all +Haskell examples use a `State' type for this purpose, which collects the +different parts of the global state, i.e. one or more IORefs. There are +alternatives for modeling this, which should be considered in own programs, +depending on the use cases: + + * Separate IORefs: This makes it explicit which parts of the program need + which parts of the state. + + * A single IORef/MVar containing all the state: This enables one to change + the whole state atomically, which is often quite handy in multithreaded + programs. + + * A custom monad: This can hide all the state threading behind the scenes. diff --git a/examples/RedBook4/AAIndex.hs b/examples/RedBook4/AAIndex.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/AAIndex.hs @@ -0,0 +1,104 @@ +{- + AAIndex.hs (adapted from aaindex.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws shows how to draw anti-aliased lines in color index + mode. It draws two diagonal lines to form an X; when 'r' is typed in the + window, the lines are rotated in opposite directions. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { rotAngle :: IORef Int } + +makeState :: IO State +makeState = do + r <- newIORef 0 + return $ State { rotAngle = r } + +rampSize, ramp1Start, ramp2Start :: GLint +rampSize = 16 +ramp1Start = 32 +ramp2Start = 48 + +-- Initialize antialiasing for color index mode, including loading a green color +-- ramp starting at ramp1Start, and a blue color ramp starting at ramp2Start. +-- The ramps must be a multiple of 16. +myInit :: IO () +myInit = do + flip mapM_ [ 0 .. rampSize - 1 ] $ \i -> do + let shade = fromIntegral i / fromIntegral rampSize + colorMapEntry (Index1 (ramp1Start + i)) $= Color3 0 shade 0 + colorMapEntry (Index1 (ramp2Start + i)) $= Color3 0 0 shade + + lineSmooth $= Enabled + hint LineSmooth $= DontCare + lineWidth $= 1.5 + + clearIndex $= Index1 (fromIntegral ramp1Start) + +-- Draw 2 diagonal lines to form an X +display :: State -> DisplayCallback +display state = do + r <- get (rotAngle state) + clear [ ColorBuffer ] + + -- resolve overloading, not needed in "real" programs + let vertex2f = vertex :: Vertex2 GLfloat -> IO () + + index (Index1 ramp1Start) + preservingMatrix $ do + rotate (-(fromIntegral r :: GLfloat)) (Vector3 0 0 0.1) + renderPrimitive Lines $ do + vertex2f (Vertex2 (-0.5) 0.5) + vertex2f (Vertex2 0.5 (-0.5)) + + index (Index1 ramp2Start) + preservingMatrix $ do + rotate (fromIntegral r :: GLfloat) (Vector3 0 0 0.1) + renderPrimitive Lines $ do + vertex2f (Vertex2 0.5 0.5) + vertex2f (Vertex2 (-0.5) (-0.5)) + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D (-1) 1 (-1*hf/wf) (1*hf/wf) + else ortho2D (-1*wf/hf) (1*wf/hf) (-1) 1 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'r' -> do rotAngle state $~ ((`mod` 360) . (+ 30)); postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +-- Main Loop +-- Open window with initial window size, title bar, +-- color index display mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, IndexMode ] + initialWindowSize $= Size 200 200 + _ <- createWindow progName + state <- makeState + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state + mainLoop diff --git a/examples/RedBook4/AARGB.hs b/examples/RedBook4/AARGB.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/AARGB.hs @@ -0,0 +1,104 @@ +{- + AARGB.hs (adapted from aargb.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws shows how to draw anti-aliased lines. It draws two + diagonal lines to form an X; when 'r' is typed in the window, the lines are + rotated in opposite directions. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { rotAngle :: IORef Int } + +makeState :: IO State +makeState = do + r <- newIORef 0 + return $ State { rotAngle = r } + +-- Initialize antialiasing for RGBA mode, including alpha blending, hint, and +-- line width. Print out implementation specific info on line width granularity +-- and width. +myInit :: IO () +myInit = do + g <- get smoothLineWidthGranularity + putStrLn ("smoothLineWidthGranularity is " ++ show g) + + r <- get smoothLineWidthRange + putStrLn ("smoothLineWidthRange is " ++ show r) + + lineSmooth $= Enabled + + blend $= Enabled + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + hint LineSmooth $= DontCare + lineWidth $= 1.5 + + clearColor $= Color4 0 0 0 0 + +-- Draw 2 diagonal lines to form an X +display :: State -> DisplayCallback +display state = do + r <- get (rotAngle state) + clear [ ColorBuffer ] + + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + vertex2f = vertex :: Vertex2 GLfloat -> IO () + + color3f (Color3 0 1 0) + preservingMatrix $ do + rotate (-(fromIntegral r :: GLfloat)) (Vector3 0 0 0.1) + renderPrimitive Lines $ do + vertex2f (Vertex2 (-0.5) 0.5) + vertex2f (Vertex2 0.5 (-0.5)) + + color3f (Color3 0 0 1) + preservingMatrix $ do + rotate (fromIntegral r :: GLfloat) (Vector3 0 0 0.1) + renderPrimitive Lines $ do + vertex2f (Vertex2 0.5 0.5) + vertex2f (Vertex2 (-0.5) (-0.5)) + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D (-1) 1 (-1*hf/wf) (1*hf/wf) + else ortho2D (-1*wf/hf) (1*wf/hf) (-1) 1 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'r' -> do rotAngle state $~ ((`mod` 360) . (+ 30)); postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +-- Main Loop +-- Open window with initial window size, title bar, +-- RGBA display mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 200 200 + _ <- createWindow progName + state <- makeState + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state + mainLoop diff --git a/examples/RedBook4/AccAnti.hs b/examples/RedBook4/AccAnti.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/AccAnti.hs @@ -0,0 +1,132 @@ +{- + AccAnti.hs (adapted from accanti.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Use the accumulation buffer to do full-scene antialiasing on a scene with + orthographic parallel projection. +-} + +import Data.List ( genericLength ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a +-- gaussian distribution around the origin. Use these to do model jittering for +-- scene anti-aliasing and view volume jittering for depth of field effects. Use +-- in conjunction with the accwindow routine. +j8 :: [Vector2 GLdouble] +j8 = [ + Vector2 (-0.334818) 0.435331 , + Vector2 0.286438 (-0.393495), + Vector2 0.459462 0.141540 , + Vector2 (-0.414498) (-0.192829), + Vector2 (-0.183790) 0.082102 , + Vector2 (-0.079263) (-0.317383), + Vector2 0.102254 0.299133 , + Vector2 0.164216 (-0.054399) ] + +-- Initialize lighting and other values. +myInit :: IO () +myInit = do + materialAmbient Front $= Color4 1 1 1 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 50 + position (Light 0) $= Vertex4 0 0 10 1 + lightModelAmbient $= Color4 0.2 0.2 0.2 1 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + shadeModel $= Flat + + clearColor $= Color4 0 0 0 0 + clearAccum $= Color4 0 0 0 0 + +displayObjects :: IO () +displayObjects = do + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + + preservingMatrix $ do + rotatef 30 (Vector3 1 0 0) + + preservingMatrix $ do + translatef (Vector3 (-0.80) 0.35 0) + rotatef 100 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0.7 0.7 0 1 + renderObject Solid (Torus 0.275 0.85 16 16) + + preservingMatrix $ do + translatef (Vector3 (-0.75) (-0.50) 0) + rotatef 45 (Vector3 0 0 1) + rotatef 45 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0 0.7 0.7 1 + renderObject Solid (Cube 1.5) + + preservingMatrix $ do + translatef (Vector3 0.75 0.60 0) + rotatef 30 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0.7 0 0.7 1 + renderObject Solid (Sphere' 1 16 16) + + preservingMatrix $ do + translatef (Vector3 0.70 (-0.90) 0.25) + materialDiffuse Front $= Color4 0.7 0.4 0.4 1 + renderObject Solid Octahedron + +-- display draws 5 teapots into the accumulation buffer several times; each time +-- with a jittered perspective. The focal point is at z = 5.0, so the gold +-- teapot will stay in focus. The amount of jitter is adjusted by the magnitude +-- of the accPerspective jitter; in this example, 0.33. In this example, the +-- teapots are drawn 8 times. +display :: DisplayCallback +display = do + (_, Size w h) <- get viewport + clear [ AccumBuffer ] + + flip mapM_ j8 $ \(Vector2 x y) -> do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + -- Note that 4.5 is the distance in world space between left and right + -- and bottom and top. This formula converts fractional pixel movement + -- to world coordinates. + translate (Vector3 (x*4.5/fromIntegral w) (y*4.5/fromIntegral h) 0) + displayObjects + accum Accum (recip (genericLength j8)) + + accum Return 1 + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-2.25) 2.25 (-2.25*hf/wf) (2.25*hf/wf) (-10) 10 + else ortho (-2.25*wf/hf) (2.25*wf/hf) (-2.25) 2.25 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Be certain to request an accumulation buffer. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/AccPersp.hs b/examples/RedBook4/AccPersp.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/AccPersp.hs @@ -0,0 +1,166 @@ +{- + AccPersp.hs (adapted from accpersp.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Use the accumulation buffer to do full-scene antialiasing on a scene with + perspective projection, using the special routines accFrustum and + accPerspective. +-} + +import Data.List ( genericLength ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a +-- gaussian distribution around the origin. Use these to do model jittering for +-- scene anti-aliasing and view volume jittering for depth of field effects. Use +-- in conjunction with the accwindow routine. +j8 :: [Vector2 GLdouble] +j8 = [ + Vector2 (-0.334818) 0.435331 , + Vector2 0.286438 (-0.393495), + Vector2 0.459462 0.141540 , + Vector2 (-0.414498) (-0.192829), + Vector2 (-0.183790) 0.082102 , + Vector2 (-0.079263) (-0.317383), + Vector2 0.102254 0.299133 , + Vector2 0.164216 (-0.054399) ] + +-- The first 6 arguments are identical to the frustum call. pixD is anti-alias +-- jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD is +-- depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field +-- effects. focus is distance from eye to plane in focus. focus must be greater +-- than, but not equal to 0. Note that accFrustum calls translate. You will +-- probably want to insure that your ModelView matrix has been initialized to +-- identity before calling accFrustum. +accFrustum :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble + -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () +accFrustum left right bottom top zNear zFar + (Vector2 pixDx pixDy) (Vector2 eyeDx eyeDy) focus = do + (_, Size w h) <- get viewport + + let xWSize = right - left; + yWSize = top - bottom; + + dx = -(pixDx * xWSize / fromIntegral w + eyeDx * zNear / focus) + dy = -(pixDy * yWSize / fromIntegral h + eyeDy * zNear / focus) + + matrixMode $= Projection + loadIdentity + frustum (left + dx) (right + dx) (bottom + dy) (top + dy) zNear zFar + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 (-eyeDx) (-eyeDy) 0) + +-- The first 4 arguments are identical to the perspective call. pixD is +-- anti-alias jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD +-- is depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field +-- effects. focus is distance from eye to plane in focus. focus must be greater +-- than, but not equal to 0. Note that accPerspective calls accFrustum. +accPerspective :: GLdouble -> GLdouble -> GLdouble -> GLdouble + -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () +accPerspective fovY aspect zNear zFar pixD eyeD focus = do + let fov2 = ((fovY * pi) / 180) / 2 + + top = zNear / (cos fov2 / sin fov2) + bottom = -top + + right = top * aspect + left = -right + + accFrustum left right bottom top zNear zFar pixD eyeD focus + +-- Initialize lighting and other values. +myInit :: IO () +myInit = do + materialAmbient Front $= Color4 1 1 1 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 50 + position (Light 0) $= Vertex4 0 0 10 1 + lightModelAmbient $= Color4 0.2 0.2 0.2 1 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + shadeModel $= Flat + + clearColor $= Color4 0 0 0 0 + clearAccum $= Color4 0 0 0 0 + +displayObjects :: IO () +displayObjects = do + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + + preservingMatrix $ do + translatef (Vector3 0 0 (-5)) + rotatef 30 (Vector3 1 0 0) + + preservingMatrix $ do + translatef (Vector3 (-0.80) 0.35 0) + rotatef 100 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0.7 0.7 0 1 + renderObject Solid (Torus 0.275 0.85 16 16) + + preservingMatrix $ do + translatef (Vector3 (-0.75) (-0.50) 0) + rotatef 45 (Vector3 0 0 1) + rotatef 45 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0 0.7 0.7 1 + renderObject Solid (Cube 1.5) + + preservingMatrix $ do + translatef (Vector3 0.75 0.60 0) + rotatef 30 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0.7 0 0.7 1 + renderObject Solid (Sphere' 1 16 16) + + preservingMatrix $ do + translatef (Vector3 0.70 (-0.90) 0.25) + materialDiffuse Front $= Color4 0.7 0.4 0.4 1 + renderObject Solid Octahedron + +-- display draws 5 teapots into the accumulation buffer several times; each time +-- with a jittered perspective. The focal point is at z = 5.0, so the gold +-- teapot will stay in focus. The amount of jitter is adjusted by the magnitude +-- of the accPerspective jitter; in this example, 0.33. In this example, the +-- teapots are drawn 8 times. +display :: DisplayCallback +display = do + (_, Size w h) <- get viewport + clear [ AccumBuffer ] + + flip mapM_ j8 $ \(Vector2 x y) -> do + clear [ ColorBuffer, DepthBuffer ] + accPerspective 50 (fromIntegral w / fromIntegral h) 1 15 + (Vector2 x y) (Vector2 0 0) 1 + displayObjects + accum Accum (recip (genericLength j8)) + + accum Return 1 + flush + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Be certain you request an accumulation buffer. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Alpha.hs b/examples/RedBook4/Alpha.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Alpha.hs @@ -0,0 +1,91 @@ +{- + Alpha.hs (adapted from alpha.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws several overlapping filled polygons to demonstrate the + effect order has on alpha blending results. Use the 't' key to toggle the + order of drawing polygons. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { leftFirst :: IORef Bool } + +makeState :: IO State +makeState = do + l <- newIORef True + return $ State { leftFirst = l } + +-- Initialize alpha blending function. +myInit :: IO () +myInit = do + blend $= Enabled + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + shadeModel $= Flat + clearColor $= Color4 0 0 0 0 + +drawLeftTriangle :: IO () +drawLeftTriangle = + -- draw yellow triangle on LHS of screen + renderPrimitive Triangles $ do + color (Color4 1 1 0 (0.75 :: GLfloat)) + vertex (Vertex3 0.1 0.9 (0 :: GLfloat)) + vertex (Vertex3 0.1 0.1 (0 :: GLfloat)) + vertex (Vertex3 0.7 0.5 (0 :: GLfloat)) + +drawRightTriangle :: IO () +drawRightTriangle = + -- draw cyan triangle on RHS of screen + renderPrimitive Triangles $ do + color (Color4 0 1 1 (0.75 :: GLfloat)) + vertex (Vertex3 0.9 0.9 (0 :: GLfloat)) + vertex (Vertex3 0.3 0.5 (0 :: GLfloat)) + vertex (Vertex3 0.9 0.1 (0 :: GLfloat)) + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + l <- get (leftFirst state) + if l + then do drawLeftTriangle; drawRightTriangle + else do drawRightTriangle; drawLeftTriangle + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D 0 1 0 (hf/wf) + else ortho2D 0 (wf/hf) 0 1 + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 't' -> do leftFirst state $~ not; postRedisplay Nothing + '\27' -> exitWith ExitSuccess -- Escape key + _ -> return () +keyboard _ _ _ _ _ = return () + +-- Main Loop +-- Open window with initial window size, title bar, RGBA display mode, and +-- handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 200 200 + _ <- createWindow progName + state <- makeState + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state + mainLoop diff --git a/examples/RedBook4/Alpha3D.hs b/examples/RedBook4/Alpha3D.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Alpha3D.hs @@ -0,0 +1,124 @@ +{- + Alpha3D.hs (adapted from alpha3D.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates how to intermix opaque and alpha blended polygons + in the same scene, by using depthMask. Press the 'a' key to animate moving + the transparent object through the opaque object. Press the 'r' key to reset + the scene. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +maxZ, minZ, zInc :: GLfloat +maxZ = 8 +minZ = -8 +zInc = 0.4 + +-- We don't animate via the idle callback, because this is way too fast on +-- modern computers. A timer with the delay below is used instead for redraw. +delay :: Timeout +delay = 100 + +data State = State { solidZ, transparentZ :: IORef GLfloat } + +makeState :: IO State +makeState = do + s <- newIORef maxZ + t <- newIORef minZ + return $ State { solidZ = s, transparentZ = t } + +data DisplayLists = DisplayLists { sphereList, cubeList :: DisplayList } + +myInit :: IO DisplayLists +myInit = do + materialSpecular Front $= Color4 1 1 1 0.15 + materialShininess Front $= 100 + position (Light 0) $= Vertex4 0.5 0.5 1 0 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + + s <- defineNewList Compile $ renderObject Solid (Sphere' 0.4 16 16) + c <- defineNewList Compile $ renderObject Solid (Cube 0.6) + return $ DisplayLists { sphereList = s, cubeList = c } + +display :: State -> DisplayLists -> DisplayCallback +display state displayLists = do + clear [ ColorBuffer, DepthBuffer ] + + preservingMatrix $ do + s <- get (solidZ state) + translate (Vector3 (-0.15) (-0.15) s) + materialEmission Front $= Color4 0 0 0 1 + materialDiffuse Front $= Color4 0.75 0.75 0 1 + callList (sphereList displayLists) + + preservingMatrix $ do + t <- get (transparentZ state) + translate (Vector3 (0.15) (0.15) t) + rotate (15 :: GLfloat) (Vector3 1 1 0) + rotate (30 :: GLfloat) (Vector3 0 1 0) + materialEmission Front $= Color4 0 0.3 0.3 0.6 + materialDiffuse Front $= Color4 0 0.8 0.8 0.6 + blend $= Enabled + depthMask $= Disabled + blendFunc $= (SrcAlpha, One) + callList (cubeList displayLists) + depthMask $= Enabled + blend $= Disabled + + swapBuffers + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-1.5) 1.5 (-1.5*hf/wf) (1.5*hf/wf) (-10) 10 + else ortho (-1.5*wf/hf) (1.5*wf/hf) (-1.5) 1.5 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +animate :: State -> TimerCallback +animate state = do + s <- get (solidZ state) + t <- get (transparentZ state) + if (s <= minZ || t >= maxZ) + then idleCallback $= Nothing + else do + solidZ state $~ (+ (- zInc)) + transparentZ state $~ (+ zInc) + addTimerCallback delay (animate state) + postRedisplay Nothing + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'a' -> do solidZ state $= maxZ; transparentZ state $= minZ; addTimerCallback delay (animate state) + 'r' -> do solidZ state $= maxZ; transparentZ state $= minZ; postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + -- The original C example uses single buffering, which flickers a lot. + initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + _ <- createWindow progName + state <- makeState + displayLists <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state displayLists + mainLoop diff --git a/examples/RedBook4/BezCurve.hs b/examples/RedBook4/BezCurve.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/BezCurve.hs @@ -0,0 +1,67 @@ +{- + BezCurve.hs (adapted from bezcurve.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program uses evaluators to draw a Bezier curve. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +ctrlPoints :: [Vertex3 GLfloat] +ctrlPoints = [ Vertex3 (-4)(-4) 0, Vertex3 (-2) 4 0, + Vertex3 2 (-4) 0, Vertex3 4 4 0 ] + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + m <- newMap1 (0, 1) ctrlPoints + map1 $= Just (m :: GLmap1 Vertex3 GLfloat) + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 1 1 1) + renderPrimitive LineStrip $ + mapM_ evalCoord1 [ i/30.0 :: GLfloat | i <- [0..30] ] + -- The following code displays the control points as dots. + pointSize $= 5 + color3f (Color3 1 1 0) + renderPrimitive Points $ + mapM_ vertex ctrlPoints + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-5.0) 5.0 (-5.0*hf/wf) (5.0*hf/wf) (-5.0) 5.0 + else ortho (-5.0*wf/hf) (5.0*wf/hf) (-5.0) 5.0 (-5.0) 5.0 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/BezMesh.hs b/examples/RedBook4/BezMesh.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/BezMesh.hs @@ -0,0 +1,84 @@ +{- + BezMesh.hs (adapted from bezmesh.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program renders a lighted, filled Bezier surface, using two-dimensional + evaluators. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Data.List ( transpose ) +import Graphics.UI.GLUT + +ctrlPoints :: [[Vertex3 GLfloat]] +ctrlPoints = [ + [ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0, + Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ], + [ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0, + Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ], + [ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0, + Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ], + [ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0), + Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]] + +initlights :: IO () +initlights = do + lighting $= Enabled + light (Light 0) $= Enabled + + ambient (Light 0) $= Color4 0.2 0.2 0.2 1.0 + position (Light 0) $= Vertex4 0 0 2 1 + + materialDiffuse Front $= Color4 0.6 0.6 0.6 1.0 + materialSpecular Front $= Color4 1.0 1.0 1.0 1.0 + materialShininess Front $= 50 + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + rotate (85 :: GLfloat) (Vector3 1 1 1) + evalMesh2 Fill (0, 20) (0, 20) + flush + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + depthFunc $= Just Less + m <- newMap2 (0, 1) (0, 1) (transpose ctrlPoints) + map2 $= Just (m :: GLmap2 Vertex3 GLfloat) + autoNormal $= Enabled + mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat))) + initlights -- for lighted version only + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0 + else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/BezSurf.hs b/examples/RedBook4/BezSurf.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/BezSurf.hs @@ -0,0 +1,79 @@ +{- + BezSurf.hs (adapted from bezsurf.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program renders a wireframe Bezier surface, using two-dimensional + evaluators. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +ctrlPoints :: [[Vertex3 GLfloat]] +ctrlPoints = [ + [ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0, + Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ], + [ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0, + Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ], + [ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0, + Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ], + [ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0), + Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]] + +-- Hey mom, look, it's C! ;-) +for :: GLfloat -> GLfloat -> (GLfloat -> IO ()) -> IO () +for s e f = mapM_ f [ i | i <- [ s, if s <= e then s + 1 else s - 1 .. e ] ] + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + color (Color3 1 1 1 :: Color3 GLfloat) + preservingMatrix $ do + rotate (85 :: GLfloat) (Vector3 1 1 1) + for 0 8 $ \j -> do + renderPrimitive LineStrip $ do + for 0 30 $ \i -> evalCoord2 (i/30, j/ 8) + renderPrimitive LineStrip $ do + for 0 30 $ \i -> evalCoord2 (j/ 8, i/30) + flush + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + m <- newMap2 (0, 1) (0, 1) ctrlPoints + map2 $= Just (m :: GLmap2 Vertex3 GLfloat) + mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat))) + depthFunc $= Just Less + shadeModel $= Flat + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0 + else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/BlendEqn.hs b/examples/RedBook4/BlendEqn.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/BlendEqn.hs @@ -0,0 +1,95 @@ +{- + BlendEqn.hs (adapted from blendeqn.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Demonstrate the different blending functions available with the OpenGL + imaging subset. This program demonstrates use of blendEquation. + + The following keys change the selected blend equation function: + + 'a' -> FuncAdd + 's' -> FuncSubtract + 'r' -> FuncReverseSubtract + 'm' -> Min + 'x' -> Max +-} + +import Data.Char ( toLower ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 1 1 0 0 + blendFunc $= (One, One) + blend $= Enabled + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + + color (Color3 0 0 (1 :: GLfloat)) + rect (Vertex2 (-0.5) (-0.5)) (Vertex2 0.5 (0.5 :: GLfloat)) + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + let aspect = fromIntegral w / fromIntegral h + + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + if aspect < 1 + then let aspect' = recip aspect + in ortho (-aspect') aspect' (-1) 1 (-1) 1 + else ortho (-1) 1 (-aspect) aspect (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char c) Down _ _ = case toLower c of + -- Colors are added as: (0, 0, 1) + (1, 1, 0) = (1, 1, 1) + -- which will produce a white square on a yellow background. + 'a' -> setBlendEquation FuncAdd + + -- Colors are subtracted as: (0, 0, 1) - (1, 1, 0) = (-1, -1, 1) + -- which is clamped to (0, 0, 1), producing a blue square on a + -- yellow background + 's' -> setBlendEquation FuncSubtract + + -- Colors are subtracted as: (1, 1, 0) - (0, 0, 1) = (1, 1, -1) + -- which is clamed to (1, 1, 0). This produces yellow for both + -- the square and the background. + 'r' -> setBlendEquation FuncReverseSubtract + + -- The minimum of each component is computed, as + -- [min(0, 1), min(0, 1), min(1, 0)] which equates to (0, 0, 0). + -- This will produce a black square on the yellow background. + 'm' -> setBlendEquation Min + + -- The minimum of each component is computed, as + -- [max(0, 1), max(0, 1), max(1, 0)] which equates to (1, 1, 1) + -- This will produce a white square on the yellow background. + 'x' -> setBlendEquation Max + + '\27' -> exitWith ExitSuccess + _ -> return () + where setBlendEquation e = do + blendEquation $= e + postRedisplay Nothing +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 512 512 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display + mainLoop diff --git a/examples/RedBook4/Checker.hs b/examples/RedBook4/Checker.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Checker.hs @@ -0,0 +1,101 @@ +{- + Checker.hs (adapted from checker.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program texture maps a checkerboard image onto two rectangles. + + Texture objects are only used when GL_EXT_texture_object is supported. +-} + +import Control.Monad ( when ) +import Data.Maybe ( isJust ) +import Data.Bits ( (.&.) ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Create checkerboard image +checkImageSize :: TextureSize2D +checkImageSize = TextureSize2D 64 64 + +withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) + -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () +withCheckImage (TextureSize2D w h) n f act = + withArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] $ + act. PixelData RGBA UnsignedByte + +myInit :: IO (Maybe TextureObject) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + rowAlignment Unpack $= 1 + + exts <- get glExtensions + mbTexName <- if "GL_EXT_texture_object" `elem` exts + then fmap Just genObjectName + else return Nothing + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + withCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) $ + texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 + return mbTexName + +display :: Maybe TextureObject -> DisplayCallback +display mbTexName = do + clear [ ColorBuffer, DepthBuffer ] + texture Texture2D $= Enabled + textureFunction $= Decal + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + + -- resolve overloading, not needed in "real" programs + let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) + + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) + flush + texture Texture2D $= Disabled + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-3.6 :: GLfloat)) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + mbTexName <- myInit + displayCallback $= display mbTexName + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Clip.hs b/examples/RedBook4/Clip.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Clip.hs @@ -0,0 +1,63 @@ +{- + Clip.hs (adapted from clip.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates arbitrary clipping planes. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + color3f (Color3 1 1 1) + + preservingMatrix $ do + translatef (Vector3 0 0 (-5)) + + -- clip lower half -- y < 0 + clipPlane (ClipPlaneName 0) $= Just (Plane 0 1 0 0) + -- clip left half -- x < 0 + clipPlane (ClipPlaneName 1) $= Just (Plane 1 0 0 0) + + rotatef 90 (Vector3 1 0 0) + renderObject Wireframe (Sphere' 1 20 16) + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 20 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/ColorMat.hs b/examples/RedBook4/ColorMat.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/ColorMat.hs @@ -0,0 +1,94 @@ +{- + Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + After initialization, the program will be in ColorMaterial mode. + Interaction: pressing the mouse buttons will change the diffuse + reflection values. +-} + +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { r, g, b :: IORef GLfloat } + +diffuseMaterial :: State -> IO (Color4 GLfloat) +diffuseMaterial state = do + r' <- get (r state) + g' <- get (g state) + b' <- get (b state) + return $ Color4 r' g' b' 1 + +makeState :: IO State +makeState = do + r' <- newIORef 0.5 + g' <- newIORef 0.5 + b' <- newIORef 0.5 + return $ State { r = r', g = g', b = b' } + +-- Initialize material property, light source, lighting model, +-- and depth buffer. +myInit :: State -> IO () +myInit state = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + depthFunc $= Just Less + dm <- diffuseMaterial state + materialDiffuse Front $= dm + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 25 + position (Light 0) $= Vertex4 1 1 1 0 + lighting $= Enabled + light (Light 0) $= Enabled + colorMaterial $= Just (Front, Diffuse) + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + renderObject Solid (Sphere' 1 20 16) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-1.5) 1.5 (-1.5 * hf/wf) (1.5 * hf/wf) (-10) 10 + else ortho (-1.5 * wf/hf) (1.5 * wf/hf) (-1.5) 1.5 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +keyboardMouse :: State -> KeyboardMouseCallback +keyboardMouse state (MouseButton button) Down _ _ = case button of + LeftButton -> update r + MiddleButton -> update g + RightButton -> update b + _ -> return () + where update component = do + component state $~ inc + dm <- diffuseMaterial state + color dm + postRedisplay Nothing + inc x = let s = x + 0.1 in if s > 1 then 0 else s +keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboardMouse _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + myInit state + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboardMouse state) + mainLoop diff --git a/examples/RedBook4/ColorMatrix.hs b/examples/RedBook4/ColorMatrix.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/ColorMatrix.hs @@ -0,0 +1,65 @@ +{- + ColorMatrix.hs (adapted from colormatrix.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program uses the color matrix to exchange the color channels of an image. + + Red -> Green + Green -> Blue + Blue -> Red +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT +import ReadImage + +myInit :: IO () +myInit = do + m <- newMatrix ColumnMajor [ 0, 1, 0, 0, + 0, 0, 1, 0, + 1, 0, 0, 0, + 0, 0, 0, 1 ] + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + matrixMode $= Color + matrix Nothing $= (m :: GLmatrix GLfloat) + matrixMode $= Modelview 0 + +display :: Size -> PixelData a -> DisplayCallback +display size pixels = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 1 1) + drawPixels size pixels + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, args) <- getArgsAndInitialize + (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= size + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display size pixels + mainLoop diff --git a/examples/RedBook4/ColorTable.hs b/examples/RedBook4/ColorTable.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/ColorTable.hs @@ -0,0 +1,62 @@ +{- + ColorTable.hs (adapted from colortable.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Invert a passed block of pixels. This program illustrates the use of the + colorTable function. +-} + +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT +import ReadImage + +myInit :: IO () +myInit = do + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + -- Set up an inverse color table + let tableSize = 256 + t = fromIntegral (tableSize - 1) :: GLubyte + withArray [ Color3 i i i | i <- [ t, t - 1 .. 0 ] ] $ \buf -> + colorTable NoProxy ColorTable RGB' tableSize (PixelData RGB UnsignedByte buf) + colorTableStage ColorTableStage $= Enabled + +display :: Size -> PixelData a -> DisplayCallback +display size pixels = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 1 1) + drawPixels size pixels + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, args) <- getArgsAndInitialize + (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= size + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display size pixels + mainLoop diff --git a/examples/RedBook4/Combiner.hs b/examples/RedBook4/Combiner.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Combiner.hs @@ -0,0 +1,236 @@ +{- + Combiner.hs (adapted from combiner.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program renders a variety of quads showing different effects of + texture combiner functions. + + The first row renders an untextured polygon (so you can compare the + fragment colors) and then the 2 textures. + + The second row shows several different combiner functions on a single + texture: replace, modulate, add, add-signed, and subtract. + + The third row shows the interpolate combiner function on a single texture + with a constant color/alpha value, varying the amount of interpolation. + + The fourth row uses multitexturing with two textures and different + combiner functions. + + The fifth row are some combiner experiments: using the scaling factor and + reversing the order of subtraction for a combination function. +-} + +import Data.Bits ( (.&.) ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Create checkerboard image +imageSize :: TextureSize2D +imageSize = TextureSize2D 8 8 + +makeImage :: TextureSize2D -> (GLsizei -> GLsizei -> Color4 GLubyte) + -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () +makeImage (TextureSize2D w h) f act = + withArray [ f i j | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ] ] $ + act . PixelData RGBA UnsignedByte + +myInit :: IO (TextureObject, TextureObject, DisplayList) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + + rowAlignment Unpack $= 1 + + [texName0, texName1] <- genObjectNames 2 + + textureBinding Texture2D $= Just texName0 + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + -- horiz b & w stripes + makeImage imageSize (\i _ -> let c = if i .&. 2 == 0 then 255 else 0 in Color4 c c c 255) $ + texImage2D Texture2D NoProxy 0 RGBA' imageSize 0 + + textureBinding Texture2D $= Just texName1 + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + textureFunction $= Decal + -- wider vertical 50% cyan and black stripes + makeImage imageSize (\_ j -> let c = if j .&. 4 /= 0 then 128 else 0 in Color4 0 c c 255) $ + texImage2D Texture2D NoProxy 0 RGBA' imageSize 0 + + -- smooth-shaded polygon with multiple texture coordinates + let vert :: TexCoord2 GLfloat -> Color3 GLfloat -> Vertex3 GLfloat -> IO () + vert t c v = do + multiTexCoord (TextureUnit 0) t + multiTexCoord (TextureUnit 1) t + color c + vertex v + + dl <- defineNewList Compile $ + renderPrimitive Quads $ do + vert (TexCoord2 0 0) (Color3 0.5 1 0.25) (Vertex3 0 0 0) + vert (TexCoord2 0 2) (Color3 1 1 1 ) (Vertex3 0 1 0) + vert (TexCoord2 2 2) (Color3 1 1 1 ) (Vertex3 1 1 0) + vert (TexCoord2 2 0) (Color3 1 0.5 0.25) (Vertex3 1 0 0) + + return (texName0, texName1, dl) + +display :: (TextureObject, TextureObject, DisplayList) -> DisplayCallback +display (texName0, texName1, dl) = do + clear [ ColorBuffer ] + + let drawAt :: GLfloat -> GLfloat -> IO () + drawAt x y = preservingMatrix $ do + translate (Vector3 x y 0) + callList dl + + -- untextured polygon -- see the "fragment" colors + texture Texture2D $= Disabled + drawAt 0 5 + + texture Texture2D $= Enabled + -- draw ordinary textured polys; 1 texture unit; combine mode disabled + textureFunction $= Modulate + textureBinding Texture2D $= Just texName0 + drawAt 1 5 + + textureBinding Texture2D $= Just texName1 + drawAt 2 5 + + -- different combine modes enabled; 1 texture unit + -- defaults are: + -- argRGB Arg0 $= Arg SrcColor CurrentUnit + -- argRGB Arg1 $= Arg SrcColor Previous + + textureBinding Texture2D $= Just texName0 + textureFunction $= Combine + combineRGB $= Replace' + argRGB Arg0 $= Arg SrcColor CurrentUnit + drawAt 1 4 + + combineRGB $= Modulate' + argRGB Arg1 $= Arg SrcColor Previous + drawAt 2 4 + + combineRGB $= AddUnsigned' + drawAt 3 4 + + combineRGB $= AddSigned + drawAt 4 4 + + combineRGB $= Subtract + drawAt 5 4 + + -- interpolate combine with constant color; 1 texture unit + -- use different alpha values for constant color + -- defaults are: + -- argRGB Arg0 $= Arg SrcColor CurrentUnit + -- argRGB Arg1 $= Arg SrcColor Previous + -- argRGB Arg2 $= Arg SrcAlpha Constant + + constantColor $= Color4 0 0 0 0.2 + textureBinding Texture2D $= Just texName0 + textureFunction $= Combine + combineRGB $= Interpolate + argRGB Arg0 $= Arg SrcColor CurrentUnit + argRGB Arg1 $= Arg SrcColor Previous + argRGB Arg2 $= Arg SrcAlpha Constant + drawAt 1 3 + + constantColor $= Color4 0 0 0 0.4 + drawAt 2 3 + + constantColor $= Color4 0 0 0 0.6 + drawAt 3 3 + + constantColor $= Color4 0 0 0 0.8 + drawAt 4 3 + + -- combine textures 0 & 1 + -- defaults are: + -- argRGB Arg0 $= Arg SrcColor CurrentUnit + -- argRGB Arg1 $= Arg SrcColor Previous + + activeTexture $= TextureUnit 0 + texture Texture2D $= Enabled + textureBinding Texture2D $= Just texName0 + textureFunction $= Modulate + + activeTexture $= TextureUnit 1 + texture Texture2D $= Enabled + textureBinding Texture2D $= Just texName1 + textureFunction $= Combine + combineRGB $= Replace' + drawAt 1 2 + + -- try different combiner modes of texture unit 1 + combineRGB $= Modulate' + drawAt 2 2 + + combineRGB $= AddUnsigned' + drawAt 3 2 + + combineRGB $= AddSigned + drawAt 4 2 + + combineRGB $= Subtract + drawAt 5 2 + + -- some experiments + + -- see the effect of rgbScale + rgbScale $= 2 + combineRGB $= Replace' + drawAt 1 1 + + combineRGB $= Modulate' + drawAt 2 1 + rgbScale $= 1 + + -- reverse the order of subtraction Arg1-Arg0 + + textureFunction $= Combine + combineRGB $= Subtract + argRGB Arg0 $= Arg SrcColor Previous + argRGB Arg1 $= Arg SrcColor CurrentUnit + drawAt 5 1 + + activeTexture $= TextureUnit 1 -- deactivate multitexturing + texture Texture2D $= Disabled + activeTexture $= TextureUnit 0 -- activate single texture unit + + flush + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 7 0 7 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 400 400 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + texNamesAndDL <- myInit + displayCallback $= display texNamesAndDL + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Convolution.hs b/examples/RedBook4/Convolution.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Convolution.hs @@ -0,0 +1,83 @@ +{- + Convolution.hs (adapted from convolution.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Use various 2D convolutions filters to find edges in an image. +-} + +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT +import ReadImage + +data Filter = Filter String [GLfloat] + +filterTable :: [(Key,Filter)] +filterTable = [ + (Char 'h', Filter "horizontal" [ 0, -1, 0, + 0, 1, 0, + 0, 0, 0 ]), + + (Char 'v', Filter "vertical" [ 0, 0, 0, + -1, 1, 0, + 0, 0, 0 ]), + + (Char 'l', Filter "laplacian" [ -0.125, -0.125, -0.125, + -0.125, 1.0 , -0.125, + -0.125, -0.125, -0.125 ])] + +setFilter :: Filter -> IO () +setFilter (Filter filterName filterData) = do + putStrLn ("Using the " ++ filterName ++ " filter") + withArray filterData $ \buf -> + convolutionFilter2D Luminance' (Size 3 3) (PixelData Luminance Float buf) + +myInit :: IO () +myInit = do + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + setFilter (snd (head filterTable)) + convolution Convolution2D $= Enabled + +display :: Size -> PixelData a -> DisplayCallback +display size pixels = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 1 1) + drawPixels size pixels + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard key Down _ _ = + maybe (return ()) + (\f -> do setFilter f; postRedisplay Nothing) + (lookup key filterTable) +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, args) <- getArgsAndInitialize + (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) + initialDisplayMode $= [ SingleBuffered, RGBAMode ] + initialWindowSize $= size + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display size pixels + mainLoop diff --git a/examples/RedBook4/Cube.hs b/examples/RedBook4/Cube.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Cube.hs @@ -0,0 +1,56 @@ +{- + Cube.hs (adapted from cube.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates a single modeling transformation, scale and a + single viewing transformation, lookAt. A wireframe cube is rendered. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () + color3f (Color3 1 1 1) + loadIdentity -- clear the matrix + -- viewing transformation + lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) + scalef 1 2 1 -- modeling transformation + renderObject Wireframe (Cube 1) + flush + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + frustum (-1) 1 (-1) 1 1.5 20 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/CubeMap.hs b/examples/RedBook4/CubeMap.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/CubeMap.hs @@ -0,0 +1,118 @@ +{- + CubeMap.hs (adapted from CubeMap.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates cube map textures. Six different colored checker + board textures are created and applied to a lit sphere. + + Pressing the 'f' and 'b' keys translate the viewer forward and backward. +-} + +import Data.Bits ( (.&.) ) +import Data.IORef ( IORef, newIORef ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { zTrans :: IORef GLfloat } + +makeState :: IO State +makeState = do + z <- newIORef 0 + return $ State { zTrans = z } + +imageSize :: TextureSize2D +imageSize = TextureSize2D 4 4 + +withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) + -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () +withCheckImage (TextureSize2D w h) n f act = + withArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] $ + act. PixelData RGBA UnsignedByte + +makeImage :: TextureTargetCubeMapFace -> (GLubyte -> (Color4 GLubyte)) -> IO () +makeImage target f = + withCheckImage imageSize 0x1 f $ + texImage2D target NoProxy 0 RGBA' imageSize 0 + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + depthFunc $= Just Less + shadeModel $= Smooth + + rowAlignment Unpack $= 1 + textureWrapMode TextureCubeMap S $= (Repeated, Repeat) + textureWrapMode TextureCubeMap T $= (Repeated, Repeat) + textureWrapMode TextureCubeMap R $= (Repeated, Repeat) + textureFilter TextureCubeMap $= ((Nearest, Nothing), Nearest) + + makeImage TextureCubeMapPositiveX (\c -> Color4 c c c 255) + makeImage TextureCubeMapNegativeX (\c -> Color4 0 c c 255) + makeImage TextureCubeMapPositiveY (\c -> Color4 c c 0 255) + makeImage TextureCubeMapNegativeY (\c -> Color4 255 c c 255) + makeImage TextureCubeMapPositiveZ (\c -> Color4 c 0 c 255) + makeImage TextureCubeMapNegativeZ (\c -> Color4 c c 255 255) + + textureGenMode S $= Just NormalMap + textureGenMode T $= Just NormalMap + textureGenMode R $= Just NormalMap + + textureFunction $= Modulate + + texture TextureCubeMap $= Enabled + lighting $= Enabled + light (Light 0) $= Enabled + autoNormal $= Enabled + normalize $= Enabled + materialDiffuse Front $= Color4 1 1 1 1 + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + z <- get (zTrans state) + translate (Vector3 0 0 z) + renderObject Solid (Sphere' 5 20 10) + swapBuffers + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 40 (fromIntegral w / fromIntegral h) 1 300 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-20 :: GLfloat)) + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char 'f') Down _ _ = move state (-0.2) +keyboard state (Char 'b') Down _ _ = move state 0.2 +keyboard _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ _ = return () + +move :: State -> GLfloat -> IO () +move state inc = do + zTrans state $~ (+ inc) + postRedisplay Nothing + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 400 400 + initialWindowPosition $= Position 50 50 + _ <- createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + mainLoop diff --git a/examples/RedBook4/DList.hs b/examples/RedBook4/DList.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/DList.hs @@ -0,0 +1,85 @@ +{- + DList.hs (adapted from list.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates how to make and execute a + display list. Note that attributes, such as current + color and matrix, are changed. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO DisplayList +myInit = do + listName <- genObjectName + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + vertex2f = vertex :: Vertex2 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + defineList listName Compile $ do + color3f (Color3 1 0 0) -- current color red + renderPrimitive Triangles $ do + vertex2f (Vertex2 0 0) + vertex2f (Vertex2 1 0) + vertex2f (Vertex2 0 1) + translatef (Vector3 1.5 0.0 0.0) -- move position + shadeModel $= Flat + return listName + +drawLine :: IO () +drawLine = do + -- resolve overloading, not needed in "real" programs + let vertex2f = vertex :: Vertex2 GLfloat -> IO () + renderPrimitive Lines $ do + vertex2f (Vertex2 0.0 0.5) + vertex2f (Vertex2 15.0 0.5) + +display :: DisplayList -> DisplayCallback +display listName = do + -- NOTE: The following 'loadIdentity' is missing in the original + -- example, but without it the translatef calls accumulate and + -- the graphics wander out of the window after a few redraws... + loadIdentity + + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 0 1 0) -- current color green + sequence_ (replicate 10 (callList listName)) -- draw 10 triangles + drawLine -- is this line green? NO! + -- where is the line drawn? + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D 0.0 2.0 (-0.5*hf/wf) (1.5*hf/wf) + else ortho2D 0.0 (2.0*wf/hf) (-0.5) 1.5 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Open window with initial window size, title bar, +-- RGBA display mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 650 50 + _ <- createWindow progName + listName <- myInit + reshapeCallback $= Just reshape + displayCallback $= display listName + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/DOF.hs b/examples/RedBook4/DOF.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/DOF.hs @@ -0,0 +1,182 @@ +{- + DOF.hs (adapted from dof.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates use of the accumulation buffer to create an + out-of-focus depth-of-field effect. The teapots are drawn several times into + the accumulation buffer. The viewing volume is jittered, except at the focal + point, where the viewing volume is at the same position, each time. In this + case, the gold teapot remains in focus. +-} + +import Data.List ( genericLength ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a +-- gaussian distribution around the origin. Use these to do model jittering for +-- scene anti-aliasing and view volume jittering for depth of field effects. Use +-- in conjunction with the accwindow routine. +j8 :: [Vector2 GLdouble] +j8 = [ + Vector2 (-0.334818) 0.435331 , + Vector2 0.286438 (-0.393495), + Vector2 0.459462 0.141540 , + Vector2 (-0.414498) (-0.192829), + Vector2 (-0.183790) 0.082102 , + Vector2 (-0.079263) (-0.317383), + Vector2 0.102254 0.299133 , + Vector2 0.164216 (-0.054399) ] + +-- The first 6 arguments are identical to the frustum call. pixD is anti-alias +-- jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD is +-- depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field +-- effects. focus is distance from eye to plane in focus. focus must be greater +-- than, but not equal to 0. Note that accFrustum calls translate. You will +-- probably want to insure that your ModelView matrix has been initialized to +-- identity before calling accFrustum. +accFrustum :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble + -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () +accFrustum left right bottom top zNear zFar + (Vector2 pixDx pixDy) (Vector2 eyeDx eyeDy) focus = do + (_, Size w h) <- get viewport + + let xWSize = right - left; + yWSize = top - bottom; + + dx = -(pixDx * xWSize / fromIntegral w + eyeDx * zNear / focus) + dy = -(pixDy * yWSize / fromIntegral h + eyeDy * zNear / focus) + + matrixMode $= Projection + loadIdentity + frustum (left + dx) (right + dx) (bottom + dy) (top + dy) zNear zFar + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 (-eyeDx) (-eyeDy) 0) + +-- The first 4 arguments are identical to the perspective call. pixD is +-- anti-alias jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD +-- is depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field +-- effects. focus is distance from eye to plane in focus. focus must be greater +-- than, but not equal to 0. Note that accPerspective calls accFrustum. +accPerspective :: GLdouble -> GLdouble -> GLdouble -> GLdouble + -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () +accPerspective fovY aspect zNear zFar pixD eyeD focus = do + let fov2 = ((fovY * pi) / 180) / 2 + + top = zNear / (cos fov2 / sin fov2) + bottom = -top + + right = top * aspect + left = -right + + accFrustum left right bottom top zNear zFar pixD eyeD focus + +myInit :: IO DisplayList +myInit = do + ambient (Light 0) $= Color4 0 0 0 1 + diffuse (Light 0) $= Color4 1 1 1 1 + position (Light 0) $= Vertex4 0 3 3 0 + + lightModelAmbient $= Color4 0.2 0.2 0.2 1 + lightModelLocalViewer $= Disabled + + frontFace $= CW + lighting $= Enabled + light (Light 0) $= Enabled + autoNormal $= Enabled + normalize $= Enabled + depthFunc $= Just Less + + clearColor $= Color4 0 0 0 0 + clearAccum $= Color4 0 0 0 0 + -- make teapot display list + defineNewList Compile $ + renderObject Solid (Teapot 0.5) + +-- Move object into position, specify the material properties, draw a teapot. +renderTeapot :: DisplayList -> Vector3 GLfloat -> Color4 GLfloat + -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> IO () +renderTeapot teapotList pos amb dif spec shine = + preservingMatrix $ do + translate pos + materialAmbient Front $= amb + materialDiffuse Front $= dif + materialSpecular Front $= spec + materialShininess Front $= shine * 128 + callList teapotList + +-- display draws 5 teapots into the accumulation buffer several times; each time +-- with a jittered perspective. The focal point is at z = 5.0, so the gold +-- teapot will stay in focus. The amount of jitter is adjusted by the magnitude +-- of the accPerspective jitter; in this example, 0.33. In this example, the +-- teapots are drawn 8 times. +display :: DisplayList -> DisplayCallback +display teapotList = do + (_, Size w h) <- get viewport + clear [ AccumBuffer ] + + flip mapM_ j8 $ \(Vector2 x y) -> do + clear [ ColorBuffer, DepthBuffer ] + accPerspective 45 (fromIntegral w / fromIntegral h) 1 15 + (Vector2 0 0) (Vector2 (0.33 * x) (0.33 * y)) 5 + + -- ruby, gold, silver, emerald, and cyan teapots + renderTeapot teapotList + (Vector3 (-1.1) (-0.5) (-4.5)) + (Color4 0.1745 0.01175 0.01175 1) + (Color4 0.61424 0.04136 0.04136 1) + (Color4 0.727811 0.626959 0.626959 1) + 0.6 + renderTeapot teapotList + (Vector3 (-0.5) (-0.5) (-5.0)) + (Color4 0.24725 0.1995 0.0745 1) + (Color4 0.75164 0.60648 0.22648 1) + (Color4 0.628281 0.555802 0.366065 1) + 0.4 + renderTeapot teapotList + (Vector3 0.2 (-0.5) (-5.5)) + (Color4 0.19225 0.19225 0.19225 1) + (Color4 0.50754 0.50754 0.50754 1) + (Color4 0.508273 0.508273 0.508273 1) + 0.4 + renderTeapot teapotList + (Vector3 1.0 (-0.5) (-6.0)) + (Color4 0.0215 0.1745 0.0215 1) + (Color4 0.07568 0.61424 0.07568 1) + (Color4 0.633 0.727811 0.633 1) + 0.6 + renderTeapot teapotList + (Vector3 1.8 (-0.5) (-6.5)) + (Color4 0.0 0.1 0.06 1) + (Color4 0.0 0.50980392 0.50980392 1) + (Color4 0.50196078 0.50196078 0.50196078 1) + 0.25 + accum Accum (recip (genericLength j8)) + + accum Return 1 + flush + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Be certain you request an accumulation buffer. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ] + initialWindowSize $= Size 400 400 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + teapotList <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display teapotList + mainLoop diff --git a/examples/RedBook4/Data/leeds.bin b/examples/RedBook4/Data/leeds.bin new file mode 100644 Binary files /dev/null and b/examples/RedBook4/Data/leeds.bin differ diff --git a/examples/RedBook4/Double.hs b/examples/RedBook4/Double.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Double.hs @@ -0,0 +1,76 @@ +{- + Double.hs (adapted from double.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This is a simple double buffered program. + Pressing the left mouse button rotates the rectangle. + Pressing the middle mouse button stops the rotation. +-} + +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { spin :: IORef GLfloat } + +makeState :: IO State +makeState = do + s <- newIORef 0 + return $ State { spin = s } + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + preservingMatrix $ do + s <- get (spin state) + rotate s (Vector3 0 0 1) + color (Color3 1 1 1 :: Color3 GLfloat) + rect (Vertex2 (-25) (-25)) (Vertex2 25 25 :: Vertex2 GLfloat) + swapBuffers + +spinDisplay :: State -> IdleCallback +spinDisplay state = do + let wrap n s = if s > n then s - n else s + spin state $~ (wrap 360 . (+ 2)) + postRedisplay Nothing + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho (-50) 50 (-50) 50 (-1) 1 + matrixMode $= Modelview 0 + loadIdentity + +keyboardMouse :: State -> KeyboardMouseCallback +keyboardMouse state (MouseButton b) Down _ _ = + idleCallback $= case b of + LeftButton -> Just (spinDisplay state) + _ -> Nothing +-- ESC not handled in the original example, but useful nevertheless +keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboardMouse _ _ _ _ _ = return () + +-- Request double buffer display mode. +-- Register mouse input callback functions +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboardMouse state) + mainLoop diff --git a/examples/RedBook4/DrawF.hs b/examples/RedBook4/DrawF.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/DrawF.hs @@ -0,0 +1,62 @@ +{- + DrawF.hs (adapted from drawf.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Draws the bitmapped letter F on the screen (several times). + This demonstrates use of the bitmap call. +-} + +import Foreign ( Ptr, newArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO (Ptr GLubyte) +myInit = do + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + newArray [ + 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, + 0xff, 0x00, 0xff, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, + 0xff, 0xc0, 0xff, 0xc0 ] + +display :: Ptr GLubyte -> DisplayCallback +display rasters = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + color3f (Color3 1 1 1) + rasterPos2i (Vertex2 20 20) + sequence_ $ replicate 3 $ + bitmap (Size 10 12) (Vertex2 0 0) (Vector2 11 0) rasters + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop +-- Open window with initial window size, title bar, +-- RGBA display mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 100 100 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + rasters <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display rasters + mainLoop diff --git a/examples/RedBook4/Feedback.hs b/examples/RedBook4/Feedback.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Feedback.hs @@ -0,0 +1,77 @@ +{- + Feedback.hs (adapted from feedback.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates use of OpenGL feedback. First, a lighting + environment is set up and a few lines are drawn. Then feedback mode is + entered, and the same lines are drawn. The results in the feedback buffer are + printed. +-} + +import Control.Monad ( when ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Initialize lighting. +myInit :: IO () +myInit = do + lighting $= Enabled + light (Light 0) $= Enabled + +-- Draw a few lines and two points, one of which will be clipped. If in feedback +-- mode, a passthrough token is issued between each primitive +drawGeometry :: IO () +drawGeometry = do + mode <- get renderMode + -- resolve overloading, not needed in "real" programs + let normal3f = normal :: Normal3 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive LineStrip $ do + normal3f (Normal3 0 0 1) + vertex3f (Vertex3 30 30 0) + vertex3f (Vertex3 50 60 0) + vertex3f (Vertex3 70 40 0) + when (mode == Feedback) $ + passThrough (PassThroughValue 1) + renderPrimitive Points $ + vertex3f (Vertex3 (-100) (-100) (-100)) -- will be clipped + when (mode == Feedback) $ + passThrough (PassThroughValue 2) + renderPrimitive Points $ do + normal3f (Normal3 0 0 1) + vertex3f (Vertex3 50 50 0) + flush -- not in original example + +printBuffer :: Maybe [FeedbackToken] -> IO () +printBuffer = maybe (putStrLn "feedback buffer overflow") (mapM_ print) + +display :: DisplayCallback +display = do + matrixMode $= Projection + loadIdentity + ortho 0 100 0 100 0 1 + + clearColor $= Color4 0 0 0 0 + clear [ ColorBuffer ] + drawGeometry + + (_, tokens) <- getFeedbackTokens 1024 ThreeDColor drawGeometry + printBuffer tokens + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 100 100 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Fog.hs b/examples/RedBook4/Fog.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Fog.hs @@ -0,0 +1,90 @@ +{- + Fog.hs (adapted from fog.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws 5 red spheres, each at a different z distance from the + eye, in different types of fog. Pressing the f key chooses between 3 types + of fog: exponential, exponential squared, and linear. In this program, there + is a fixed density value, as well as fixed start and end values for the + linear fog. +-} + +import Data.Char ( toLower ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + depthFunc $= Just Less + + position (Light 0) $= Vertex4 0.5 0.5 3.0 0.0 + lighting $= Enabled + light (Light 0) $= Enabled + + -- NOTE: The alpha values are missing from fog.c! + materialAmbient Front $= Color4 0.1745 0.01175 0.01175 1.0 + materialDiffuse Front $= Color4 0.61424 0.04136 0.04136 1.0 + materialSpecular Front $= Color4 0.727811 0.626959 0.626959 1.0 + materialShininess Front $= 0.6 * 128 + + fog $= Enabled + let c = Color4 0.5 0.5 0.5 1.0 + fogMode $= Exp 0.35 + fogColor $= c + hint Fog $= DontCare + clearColor $= c + +renderSpehere :: Vector3 GLfloat -> IO () +renderSpehere xyz = + preservingMatrix $ do + translate xyz + renderObject Solid (Sphere' 0.4 16 16) + +-- display draws 5 spheres at different z positions. +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + mapM_ renderSpehere [ Vector3 x (-0.5) (-3 - x) | x <- [-2 .. 2] ] + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10.0) 10.0 + else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10.0) 10.0 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char c) Down _ _ = case toLower c of + 'f' -> do + mode <- get fogMode + case mode of + Linear _ _ -> do fogMode $= Exp 0.35; putStrLn "Fog mode is Exp" + Exp _ -> do fogMode $= Exp2 0.35; putStrLn "Fog mode is Exp2" + Exp2 _ -> do fogMode $= Linear 1 5; putStrLn "Fog mode is Linear" + postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, depth buffer, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display + mainLoop diff --git a/examples/RedBook4/FogCoord.hs b/examples/RedBook4/FogCoord.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/FogCoord.hs @@ -0,0 +1,122 @@ +{- + FogCoord.hs (adapted from fogcoord.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the use of explicit fog coordinates. You can press + the keyboard and change the fog coordinate value at any vertex. You can also + switch between using explicit fog coordinates and the default fog generation + mode. + + Pressing the 'f' and 'b' keys move the viewer forward and backwards. Pressing + 'c' initiates the default fog generation. Pressing capital 'C' restores + explicit fog coordinates. Pressing '1', '2', '3', '8', '9', and '0' add or + subtract from the fog coordinate values at one of the three vertices of the + triangle. +-} + +import Control.Monad ( when ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { f1, f2, f3 :: IORef (FogCoord1 GLfloat) } + +makeState :: IO State +makeState = do + f1' <- newIORef (FogCoord1 1) + f2' <- newIORef (FogCoord1 5) + f3' <- newIORef (FogCoord1 10) + return $ State { f1 = f1', f2 = f2', f3 = f3' } + +-- Initialize fog +myInit :: IO () +myInit = do + let theFogColor = Color4 0 0.25 0.25 1 + fog $= Enabled + fogMode $= Exp 0.25 + fogColor $= theFogColor + hint Fog $= DontCare + fogCoordSrc $= FogCoord + clearColor $= theFogColor + +drawTriangle :: State -> (State -> IORef (FogCoord1 GLfloat)) -> Vertex3 GLfloat -> IO () +drawTriangle state f v = do + fc <- get (f state) + fogCoord fc + vertex v + +-- display draws a triangle at an angle. +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + + color (Color3 1 0.75 (0 :: GLfloat)) + renderPrimitive Triangles $ do + drawTriangle state f1 (Vertex3 2 (-2) 0 ) + drawTriangle state f2 (Vertex3 (-2) 0 (-5)) + drawTriangle state f3 (Vertex3 0 2 (-10)) + + swapBuffers + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 45 1 0.25 25 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-5 :: GLfloat)) + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case c of + 'c' -> setSrc FragmentDepth + 'C' -> setSrc FogCoord + '1' -> inc f1 0.25 + '2' -> inc f2 0.25 + '3' -> inc f3 0.25 + '8' -> inc f1 (-0.25) + '9' -> inc f2 (-0.25) + '0' -> inc f3 (-0.25) + 'b' -> trans (-0.25) + 'f' -> trans 0.25 + '\27' -> exitWith ExitSuccess + _ -> return () + where setSrc :: FogCoordSrc -> IO () + setSrc s = do + fogCoordSrc $= s + postRedisplay Nothing + + inc :: (State -> IORef (FogCoord1 GLfloat)) -> GLfloat -> IO () + inc f x = do + FogCoord1 oldValue <- get (f state) + let newValue = oldValue + x + when (newValue > 0) $ do + f state $= FogCoord1 newValue + postRedisplay Nothing + + trans :: GLfloat -> IO () + trans x = do + matrixMode $= Modelview 0 + translate (Vector3 0 0 x) + postRedisplay Nothing +keyboard _ _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + _ <- createWindow progName + state <- makeState + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state + mainLoop + + diff --git a/examples/RedBook4/FogIndex.hs b/examples/RedBook4/FogIndex.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/FogIndex.hs @@ -0,0 +1,76 @@ +{- + FogIndex.hs (adapted from fogindex.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws 5 wireframe spheres, each at a different z distance from + the eye, in linear fog. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Initialize color map and fog. Set screen clear color to end of color ramp. +numColors, rampStart :: GLint +numColors = 32 +rampStart = 16 + +myInit :: IO () +myInit = do + depthFunc $= Just Less + + flip mapM_ [ 0 .. numColors - 1 ] $ \i -> do + let shade = fromIntegral (numColors - i) / fromIntegral numColors + colorMapEntry (Index1 (rampStart + i)) $= Color3 shade shade shade + fog $= Enabled + + fogMode $= Linear 1 6 + fogIndex $= Index1 numColors + hint Fog $= Nicest + clearIndex $= Index1 (fromIntegral (numColors + rampStart - 1)) + +renderSpehere :: Vector3 GLfloat -> IO () +renderSpehere xyz = + preservingMatrix $ do + translate xyz + renderObject Wireframe (Sphere' 0.4 16 16) + +-- display draws 5 spheres at different z positions. +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + index (Index1 rampStart) + mapM_ renderSpehere [ Vector3 x (-0.5) (-3 - x) | x <- [-2 .. 2] ] + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10.0) 10.0 + else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10.0) 10.0 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, color index +-- display mode, depth buffer, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, IndexMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display + mainLoop diff --git a/examples/RedBook4/Font.hs b/examples/RedBook4/Font.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Font.hs @@ -0,0 +1,127 @@ +{- + Font.hs (adapted from font.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Draws some text in a bitmapped font. Uses bitmap and other pixel routines. + Also demonstrates use of display lists. +-} + +import Control.Monad ( zipWithM_ ) +import Data.List ( genericDrop, genericLength ) +import Foreign.C.String ( castCharToCChar ) +import Foreign.Marshal.Array ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +space :: [GLubyte] +space = [ + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 ] + +letters :: [[GLubyte]] +letters = [ + [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xff, 0xc3, 0xc3, 0xc3, 0x66, 0x3c, 0x18 ], + [ 0x00, 0x00, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ], + [ 0x00, 0x00, 0x7e, 0xe7, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xe7, 0x7e ], + [ 0x00, 0x00, 0xfc, 0xce, 0xc7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc7, 0xce, 0xfc ], + [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0xc0, 0xc0, 0xfc, 0xc0, 0xc0, 0xc0, 0xc0, 0xff ], + [ 0x00, 0x00, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xfc, 0xc0, 0xc0, 0xc0, 0xff ], + [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xcf, 0xc0, 0xc0, 0xc0, 0xc0, 0xe7, 0x7e ], + [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xff, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], + [ 0x00, 0x00, 0x7e, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x7e ], + [ 0x00, 0x00, 0x7c, 0xee, 0xc6, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06 ], + [ 0x00, 0x00, 0xc3, 0xc6, 0xcc, 0xd8, 0xf0, 0xe0, 0xf0, 0xd8, 0xcc, 0xc6, 0xc3 ], + [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0 ], + [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xdb, 0xff, 0xff, 0xe7, 0xc3 ], + [ 0x00, 0x00, 0xc7, 0xc7, 0xcf, 0xcf, 0xdf, 0xdb, 0xfb, 0xf3, 0xf3, 0xe3, 0xe3 ], + [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xe7, 0x7e ], + [ 0x00, 0x00, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ], + [ 0x00, 0x00, 0x3f, 0x6e, 0xdf, 0xdb, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0x66, 0x3c ], + [ 0x00, 0x00, 0xc3, 0xc6, 0xcc, 0xd8, 0xf0, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ], + [ 0x00, 0x00, 0x7e, 0xe7, 0x03, 0x03, 0x07, 0x7e, 0xe0, 0xc0, 0xc0, 0xe7, 0x7e ], + [ 0x00, 0x00, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0xff ], + [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], + [ 0x00, 0x00, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], + [ 0x00, 0x00, 0xc3, 0xe7, 0xff, 0xff, 0xdb, 0xdb, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], + [ 0x00, 0x00, 0xc3, 0x66, 0x66, 0x3c, 0x3c, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3 ], + [ 0x00, 0x00, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3 ], + [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0x60, 0x30, 0x7e, 0x0c, 0x06, 0x03, 0x03, 0xff ]] + +charToGLubyte :: Char -> GLubyte +charToGLubyte = fromIntegral . castCharToCChar + +makeRasterFont :: IO DisplayList +makeRasterFont = do + rowAlignment Unpack $= 1 + + fontDisplayLists@(fontOffset:_) <- genObjectNames 128 + let listsStartingWith ch = genericDrop (charToGLubyte ch) fontDisplayLists + makeLetter dl letter = + defineList dl Compile $ + withArray letter $ + bitmap (Size 8 13) (Vertex2 0 2) (Vector2 10 0) + + zipWithM_ makeLetter (listsStartingWith 'A') letters + makeLetter (head (listsStartingWith ' ')) space + return fontOffset + +myInit :: IO DisplayList +myInit = do + shadeModel $= Flat + makeRasterFont + +printString :: DisplayList -> String -> IO () +printString fontOffset s = + preservingAttrib [ ListAttributes ] $ do + listBase $= fontOffset + withArray (map charToGLubyte s) $ + callLists (genericLength s) UnsignedByte + +-- Everything above this line could be in a library +-- that defines a font. To make it work, you've got +-- to call makeRasterFont before you start making +-- calls to printString. +display :: DisplayList -> DisplayCallback +display fontOffset = do + let white = Color3 1 1 1 + + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + color3f white + + rasterPos2i (Vertex2 20 60) + printString fontOffset "THE QUICK BROWN FOX JUMPS" + rasterPos2i (Vertex2 20 40) + printString fontOffset "OVER A LAZY DOG" + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop +-- Open window with initial window size, title bar, +-- RGBA display mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 300 100 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + fontOffset <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display fontOffset + mainLoop diff --git a/examples/RedBook4/Hello.hs b/examples/RedBook4/Hello.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Hello.hs @@ -0,0 +1,55 @@ +{- + Hello.hs (adapted from hello.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This is a simple, introductory OpenGL program. +-} + +import Graphics.UI.GLUT + +display :: DisplayCallback +display = do + -- clear all pixels + clear [ ColorBuffer ] + + -- draw white polygon (rectangle) with corners at + -- (0.25, 0.25, 0.0) and (0.75, 0.75, 0.0) + color (Color3 1.0 1.0 (1.0 :: GLfloat)) + -- resolve overloading, not needed in "real" programs + let vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Polygon $ mapM_ vertex3f [ + Vertex3 0.25 0.25 0.0, + Vertex3 0.75 0.25 0.0, + Vertex3 0.75 0.75 0.0, + Vertex3 0.25 0.75 0.0] + + -- don't wait! + -- start processing buffered OpenGL routines + flush + +myInit :: IO () +myInit = do + -- select clearing color + clearColor $= Color4 0 0 0 0 + + -- initialize viewing values + matrixMode $= Projection + loadIdentity + ortho 0 1 0 1 (-1) 1 + +-- Declare initial window size, position, and display mode (single buffer and +-- RGBA). Open window with "hello" in its title bar. Call initialization +-- routines. Register callback function to display graphics. Enter main loop and +-- process events. +main :: IO () +main = do + _ <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow "hello" + myInit + displayCallback $= display + mainLoop diff --git a/examples/RedBook4/Histogram.hs b/examples/RedBook4/Histogram.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Histogram.hs @@ -0,0 +1,85 @@ +{- + Histogram.hs (adapted from histogram.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Compute the histogram of the image. This program illustrates the use of + the histogram function. +-} + +import Control.Monad ( zipWithM_ ) +import Foreign ( allocaArray, peekArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT +import ReadImage + +histogramSize :: Int +histogramSize = 256 -- Must be a power of 2 + +myInit :: IO () +myInit = do + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + + histogram NoProxy $= Just (fromIntegral histogramSize, RGB', PassThrough) + +display :: Size -> PixelData a -> DisplayCallback +display size pixels = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 1 1) + drawPixels size pixels + + values <- allocaArray histogramSize $ \buf -> do + -- Note: The example in the Red Book uses GL_UNSIGNED_SHORT here, + -- but we are more honest by using Short... + getHistogram Reset (PixelData RGB Short buf) + peekArray histogramSize buf + + -- Plot histogram + zipWithM_ (plotHistogram values) + [ Color3 1 0 0, Color3 0 1 0, Color3 0 0 1 ] + [\(Color3 r _ _) -> r, \(Color3 _ g _) -> g, \(Color3 _ _ b) -> b ] + flush + +plotHistogram :: + [Color3 GLshort] -> Color3 GLfloat -> (Color3 GLshort -> GLshort) -> IO () +plotHistogram values c selectComponent = + renderPrimitive LineStrip $ do + color c + zipWithM_ (\i h -> vertex (Vertex2 i (selectComponent h))) [ 0 .. ] values + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral histogramSize) 0 10000 (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char 's') Down _ _ = do + Just (width, format, sink) <- get (histogram NoProxy) + let newSink = if sink == Sink then PassThrough else Sink + histogram NoProxy $= Just (width, format, newSink) + postRedisplay Nothing +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, args) <- getArgsAndInitialize + (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= size + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display size pixels + mainLoop diff --git a/examples/RedBook4/Image.hs b/examples/RedBook4/Image.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Image.hs @@ -0,0 +1,116 @@ +{- + Image.hs (adapted from image.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates drawing pixels and shows the effect of + drawPixels, copyPixels, and pixelZoom. + + Interaction: moving the mouse while pressing the mouse button will copy + the image in the lower-left corner of the window to the mouse position, + using the current pixel zoom factors. There is no attempt to prevent you + from drawing over the original image. If you press the 'r' key, the + original image and zoom factors are reset. If you press the 'z' or 'Z' + keys, you change the zoom factors. +-} + +import Data.Bits ( (.&.) ) +import Data.IORef ( IORef, newIORef ) +import Foreign ( newArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { zoomFactor :: IORef GLfloat } + +makeState :: IO State +makeState = do + z <- newIORef 1 + return $ State { zoomFactor = z } + +-- Create checkerboard image +checkImageSize :: Size +checkImageSize = Size 64 64 + +type Image = PixelData (Color3 GLubyte) + +makeCheckImage :: Size -> GLsizei -> (GLubyte -> (Color3 GLubyte)) -> IO Image +makeCheckImage (Size w h) n f = + fmap (PixelData RGB UnsignedByte) $ + newArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] + +myInit :: IO Image +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + rowAlignment Unpack $= 1 + makeCheckImage checkImageSize 0x8 (\c -> Color3 c c c) + +display :: Image -> DisplayCallback +display pixelData = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 0 0) + drawPixels checkImageSize pixelData + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + matrixMode $= Modelview 0 + loadIdentity + +motion :: State -> MotionCallback +motion state (Position x y) = do + Size _ height <- get windowSize + let screenY = fromIntegral height - y + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 x screenY) + z <- get (zoomFactor state) + pixelZoom $= (z, z) + copyPixels (Position 0 0) checkImageSize CopyColor + pixelZoom $= (1, 1) + flush + +resetZoomFactor :: State -> IO () +resetZoomFactor state = do + zoomFactor state $= 1.0 + postRedisplay Nothing + putStrLn "zoomFactor reset to 1.0" + +incZoomFactor :: State -> GLfloat -> IO () +incZoomFactor state inc = do + zoomFactor state $~! (max 0.5 . min 3.0 . (+ inc)) + get (zoomFactor state) >>= putStrLn . ("zoomFactor is now " ++) . show + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char 'r') Down _ _ = resetZoomFactor state +keyboard state (Char 'R') Down _ _ = resetZoomFactor state +keyboard state (Char 'z') Down _ _ = incZoomFactor state 0.5 +keyboard state (Char 'Z') Down _ _ = incZoomFactor state (-0.5) +keyboard _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + checkImage <- myInit + displayCallback $= display checkImage + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + motionCallback $= Just (motion state) + mainLoop diff --git a/examples/RedBook4/Light.hs b/examples/RedBook4/Light.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Light.hs @@ -0,0 +1,62 @@ +{- + Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the use of the OpenGL lighting model. A sphere + is drawn using a grey material characteristic. A single light source + illuminates the object. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 50 + position (Light 0) $= Vertex4 1 1 1 0 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + renderObject Solid (Sphere' 1 20 16) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-1.5) 1.5 (-1.5 * hf/wf) (1.5 * hf/wf) (-10) 10 + else ortho (-1.5 * wf/hf) (1.5 * wf/hf) (-1.5) 1.5 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Lines.hs b/examples/RedBook4/Lines.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Lines.hs @@ -0,0 +1,88 @@ +{- + Lines.hs (adapted from lines.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates geometric primitives and their attributes. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +drawOneLine :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO () +drawOneLine p1 p2 = renderPrimitive Lines $ do vertex p1; vertex p2 + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + -- select white for all lines + color (Color3 1.0 1.0 1.0 :: Color3 GLfloat) + + -- in 1st row, 3 lines, each with a different stipple + lineStipple $= Just (1, 0x0101) -- dotted + drawOneLine (Vertex2 50 125) (Vertex2 150 125) + lineStipple $= Just (1, 0x00FF) -- dashed + drawOneLine (Vertex2 150 125) (Vertex2 250 125) + lineStipple $= Just (1, 0x1C47) -- dash/dot/dash + drawOneLine (Vertex2 250 125) (Vertex2 350 125) + + -- in 2nd row, 3 wide lines, each with different stipple + lineWidth $= 5.0 + lineStipple $= Just (1, 0x0101) -- dotted + drawOneLine (Vertex2 50 100) (Vertex2 150 100) + lineStipple $= Just (1, 0x00FF) -- dashed + drawOneLine (Vertex2 150 100) (Vertex2 250 100) + lineStipple $= Just (1, 0x1C47) -- dash/dot/dash + drawOneLine (Vertex2 250 100) (Vertex2 350 100) + lineWidth $= 1.0 + + -- in 3rd row, 6 lines, with dash/dot/dash stipple + -- as part of a single connected line strip + lineStipple $= Just (1, 0x1C47) -- dash/dot/dash + renderPrimitive LineStrip $ mapM_ vertex [ Vertex2 (50+(i*50)) (75 :: GLint) | i <- [0..6] ] + + -- in 4th row, 6 independent lines with same stipple + sequence_ [ drawOneLine (Vertex2 (50+( i *50)) 50) + (Vertex2 (50+((i+1)*50)) 50) | i <- [0..5] ] + + -- in 5th row, 1 line, with dash/dot/dash stipple + -- and a stipple repeat factor of 5 + lineStipple $= Just (5, 0x1C47) -- dash/dot/dash + drawOneLine (Vertex2 50 25) (Vertex2 350 25) + + lineStipple $= Nothing + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + -- the following line is not in the original example, but it's good style... + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Request double buffer display mode. +-- Register mouse input callback functions +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 400 150 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/MVArray.hs b/examples/RedBook4/MVArray.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/MVArray.hs @@ -0,0 +1,87 @@ +{- + MVArray.hs (adapted from mvarray.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates multiple vertex arrays, specifically the OpenGL + routine multiDrawElements. +-} + +import Control.Monad ( unless ) +import Data.List ( genericLength ) +import Foreign ( Storable, Ptr, newArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(..) ) +import Graphics.UI.GLUT + +data MultiDrawInfo a = MultiDrawInfo (Ptr GLsizei) (Ptr (Ptr a)) GLsizei + +makeMultiDrawInfo :: Storable a => [[a]] -> IO (MultiDrawInfo a) +makeMultiDrawInfo indicesLists = do + count <- newArray $ map genericLength indicesLists + indices <- newArray =<< mapM newArray indicesLists + return $ MultiDrawInfo count indices (genericLength indicesLists) + +setupPointer :: IO () +setupPointer = do + clientState VertexArray $= Enabled + vertices <- newArray ([ + Vertex2 25 25, + Vertex2 75 75, + Vertex2 100 125, + Vertex2 150 75, + Vertex2 200 175, + Vertex2 250 150, + Vertex2 300 125, + Vertex2 100 200, + Vertex2 150 250, + Vertex2 200 225, + Vertex2 250 300, + Vertex2 300 250 ] :: [Vertex2 GLint]) + arrayPointer VertexArray $= VertexArrayDescriptor 2 Int 0 vertices + +myInit :: IO (MultiDrawInfo GLubyte) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + setupPointer + makeMultiDrawInfo [ [ 0, 1, 2, 3, 4, 5, 6 ], + [ 1, 7, 8, 9, 10, 11 ] ] + +display :: MultiDrawInfo GLubyte -> DisplayCallback +display (MultiDrawInfo count indices primCount) = do + clear [ ColorBuffer ] + color (Color3 1 1 1 :: Color3 GLfloat) + multiDrawElements LineStrip count UnsignedByte indices primCount + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + -- the following line is not in the original example, but it's good style... + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 350 350 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + exts <- get glExtensions + unless ("GL_EXT_multi_draw_arrays" `elem` exts) $ do + putStrLn "Sorry, this demo requires the GL_EXT_multi_draw_arrays extension." + exitFailure + multiDrawInfo <- myInit + displayCallback $= display multiDrawInfo + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Material.hs b/examples/RedBook4/Material.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Material.hs @@ -0,0 +1,149 @@ +{- + Material.hs (adapted from material.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the use of the GL lighting model. Several + objects are drawn using different material characteristics. A single + light source illuminates the objects. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Initialize z-buffer, projection matrix, light source, and lighting model. +-- Do not specify a material property here. + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0.1 0.1 0 + depthFunc $= Just Less + shadeModel $= Smooth + + ambient (Light 0) $= Color4 0 0 0 1 + diffuse (Light 0) $= Color4 1 1 1 1 + position (Light 0) $= Vertex4 0 3 2 0 + lightModelAmbient $= Color4 0.4 0.4 0.4 1 + lightModelLocalViewer $= Disabled + + lighting $= Enabled + light (Light 0) $= Enabled + +-- Draw twelve spheres in 3 rows with 4 columns. +-- The spheres in the first row have materials with no ambient reflection. +-- The second row has materials with significant ambient reflection. +-- The third row has materials with colored ambient reflection. +-- +-- The first column has materials with blue, diffuse reflection only. +-- The second column has blue diffuse reflection, as well as specular +-- reflection with a low shininess exponent. +-- The third column has blue diffuse reflection, as well as specular +-- reflection with a high shininess exponent (a more concentrated highlight). +-- The fourth column has materials which also include an emissive component. +-- +-- translate is used to move spheres to their appropriate locations. + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + + let draw :: GLfloat -> GLfloat -> Color4 GLfloat -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> Color4 GLfloat -> IO () + draw row column amb dif spc shi emi = + preservingMatrix $ do + translate (Vector3 (2.5 * (column - 2.5)) (3 * (2 - row)) 0) + materialAmbient Front $= amb + materialDiffuse Front $= dif + materialSpecular Front $= spc + materialShininess Front $= shi + materialEmission Front $= emi + renderObject Solid (Sphere' 1 16 16) + + noMat = Color4 0 0 0 1 + matAmbient = Color4 0.7 0.7 0.7 1 + matAmbientColor = Color4 0.8 0.8 0.2 1 + matDiffuse = Color4 0.1 0.5 0.8 1 + matSpecular = Color4 1 1 1 1 + noShininess = 0 + lowShininess = 5 + highShininess = 100 + matEmission = Color4 0.3 0.2 0.2 0 + + -- draw sphere in first row, first column + -- diffuse reflection only; no ambient or specular + draw 1 1 noMat matDiffuse noMat noShininess noMat + + -- draw sphere in first row, second column + -- diffuse and specular reflection; low shininess; no ambient + draw 1 2 noMat matDiffuse matSpecular lowShininess noMat + + -- draw sphere in first row, third column + -- diffuse and specular reflection; high shininess; no ambient + draw 1 3 noMat matDiffuse matSpecular highShininess noMat + + -- draw sphere in first row, fourth column + -- diffuse reflection; emission; no ambient or specular reflection + draw 1 4 noMat matDiffuse noMat noShininess matEmission + + -- draw sphere in second row, first column + -- ambient and diffuse reflection; no specular + draw 2 1 matAmbient matDiffuse noMat noShininess noMat + + -- draw sphere in second row, second column + -- ambient, diffuse and specular reflection; low shininess + draw 2 2 matAmbient matDiffuse matSpecular lowShininess noMat + + -- draw sphere in second row, third column + -- ambient, diffuse and specular reflection; high shininess + draw 2 3 matAmbient matDiffuse matSpecular highShininess noMat + + -- draw sphere in second row, fourth column + -- ambient and diffuse reflection; emission; no specular + draw 2 4 matAmbient matDiffuse noMat noShininess matEmission + + -- draw sphere in third row, first column + -- colored ambient and diffuse reflection; no specular + draw 3 1 matAmbientColor matDiffuse noMat noShininess noMat + + -- draw sphere in third row, second column + -- colored ambient, diffuse and specular reflection; low shininess + draw 3 2 matAmbientColor matDiffuse matSpecular lowShininess noMat + + -- draw sphere in third row, third column + -- colored ambient, diffuse and specular reflection; high shininess + draw 3 3 matAmbientColor matDiffuse matSpecular highShininess noMat + + -- draw sphere in third row, fourth column + -- colored ambient and diffuse reflection; emission; no specular + draw 3 4 matAmbientColor matDiffuse noMat noShininess matEmission + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h * 2 + then ortho (-6) 6 (-3 * (hf * 2) / wf) (3 * (hf * 2) / wf) (-10) 10 + else ortho (-6 * wf / (hf * 2)) (6 * wf / (hf * 2)) (-3) 3 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 600 450 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Minmax.hs b/examples/RedBook4/Minmax.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Minmax.hs @@ -0,0 +1,64 @@ +{- + Minmax.hs (adapted from minmax.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Determine the minimum and maximum values of a group of pixels. This + demonstrates use of the minmax function. +-} + +import Foreign ( allocaArray, peekArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT +import ReadImage + +myInit :: IO () +myInit = do + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + minmax $= Just (RGB', PassThrough) + +display :: Size -> PixelData a -> DisplayCallback +display size pixels = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 1 1) + drawPixels size pixels + flush + + [Color3 minR minG minB, Color3 maxR maxG maxB] <- allocaArray 2 $ \buf -> do + getMinmax Reset (PixelData RGB UnsignedByte buf) + peekArray 2 buf :: IO [Color3 GLubyte] + putStrLn (" Red : min = " ++ show minR ++ " max = " ++ show maxR) + putStrLn (" Green : min = " ++ show minG ++ " max = " ++ show maxG) + putStrLn (" Blue : min = " ++ show minB ++ " max = " ++ show maxB) + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, args) <- getArgsAndInitialize + (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= size + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display size pixels + mainLoop diff --git a/examples/RedBook4/Mipmap.hs b/examples/RedBook4/Mipmap.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Mipmap.hs @@ -0,0 +1,97 @@ +{- + Mipmap.hs (adapted from mipmap.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates using mipmaps for texture maps. To overtly show + the effect of mipmaps, each mipmap reduction level has a solidly colored, + contrasting texture image. Thus, the quadrilateral which is drawn is drawn + with several different colors. +-} + +import Control.Monad ( when ) +import Data.Maybe ( isJust ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +makeImage :: Level -> TextureSize2D -> Color4 GLubyte -> IO () +makeImage level size@(TextureSize2D w h) col = + withArray (replicate (fromIntegral (w * h)) col) $ + texImage2D Texture2D NoProxy level RGBA' size 0 . PixelData RGBA UnsignedByte + +makeImages :: [Color4 GLubyte] -> IO () +makeImages colors = sequence_ $ zipWith3 makeImage levels sizes colors + where numLevels = length colors + levels = [ 0 .. fromIntegral numLevels - 1 ] + sizes = reverse (take numLevels [ TextureSize2D s s | s <- iterate (* 2) 1 ]) + +myInit :: IO (Maybe TextureObject) +myInit = do + depthFunc $= Just Less + shadeModel $= Flat + + translate (Vector3 0 0 (-3.6 :: GLfloat)) + rowAlignment Unpack $= 1 + + exts <- get glExtensions + mbTexName <- if "GL_EXT_texture_object" `elem` exts + then fmap Just genObjectName + else return Nothing + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Just Nearest), Nearest) + + makeImages [ Color4 255 255 0 255, + Color4 255 0 255 255, + Color4 255 0 0 255, + Color4 0 255 0 255, + Color4 0 0 255 255, + Color4 255 255 255 255 ] + + textureFunction $= Decal + texture Texture2D $= Enabled + return mbTexName + +display :: Maybe TextureObject -> DisplayCallback +display mbTexName = do + clear [ ColorBuffer, DepthBuffer ] + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + -- resolve overloading, not needed in "real" programs + let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 ( -2) (-1) 0 ) + texCoord2f (TexCoord2 0 8); vertex3f (Vertex3 ( -2) 1 0 ) + texCoord2f (TexCoord2 8 8); vertex3f (Vertex3 2000 1 (-6000)) + texCoord2f (TexCoord2 8 0); vertex3f (Vertex3 2000 (-1) (-6000)) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30000 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 50 50 + _ <- createWindow progName + texName <- myInit + displayCallback $= display texName + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Model.hs b/examples/RedBook4/Model.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Model.hs @@ -0,0 +1,86 @@ +{- + Model.hs (adapted from model.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates modeling transformations. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +drawTriangle :: IO () +drawTriangle = do + -- resolve overloading, not needed in "real" programs + let vertex2f = vertex :: Vertex2 GLfloat -> IO () + renderPrimitive LineLoop $ do + vertex2f (Vertex2 0 25 ) + vertex2f (Vertex2 25 (-25)) + vertex2f (Vertex2 (-25) (-25)) + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + color3f (Color3 1 1 1) + + loadIdentity + color3f (Color3 1 1 1) + drawTriangle + + lineStipple $= Just (1, 0xF0F0) + loadIdentity + translatef (Vector3 (-20) 0 0) + drawTriangle + + lineStipple $= Just (1, 0xF00F) + loadIdentity + scalef 1.5 0.5 1.0 + drawTriangle + + lineStipple $= Just (1, 0x8888) + loadIdentity + rotatef 90 (Vector3 0 0 1) + drawTriangle + lineStipple $= Nothing + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-50) 50 (-50 * hf/wf) (50 * hf/wf) (-1) 1 + else ortho (-50 * wf/hf) (50 * wf/hf) (-50) 50 (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/MoveLight.hs b/examples/RedBook4/MoveLight.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/MoveLight.hs @@ -0,0 +1,85 @@ +{- + MoveLight.hs (adapted from movelight.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates when to issue lighting and transformation + commands to render a model with a light which is moved by a + modeling transformation (rotate or translate). The light position + is reset after the modeling transformation is called. The eye + position does not change. + + A sphere is drawn using a grey material characteristic. A single + light source illuminates the object. + + Interaction: pressing the left mouse button alters the modeling + transformation (x rotation) by 30 degrees. The scene is then + redrawn with the light in a new position. +-} + +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { spin :: IORef Int } + +makeState :: IO State +makeState = do + s <- newIORef 0 + return $ State { spin = s } + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) + preservingMatrix $ do + s <- get (spin state) + rotate (fromIntegral s :: GLdouble) (Vector3 1 0 0) + position (Light 0) $= Vertex4 0 0 1.5 1 + translate (Vector3 0 0 1.5 :: Vector3 GLdouble) + lighting $= Disabled + color (Color3 0 1 1 :: Color3 GLfloat) + renderObject Wireframe (Cube 0.1) + lighting $= Enabled + renderObject Solid (Torus 0.275 0.85 8 15) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 40 (fromIntegral w / fromIntegral h) 1 20 + matrixMode $= Modelview 0 + loadIdentity + +keyboardMouse :: State -> KeyboardMouseCallback +keyboardMouse state (MouseButton LeftButton) Down _ _ = do + spin state $~ ((`mod` 360) . (+ 30)) + postRedisplay Nothing +keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboardMouse _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboardMouse state) + mainLoop diff --git a/examples/RedBook4/MultiTex.hs b/examples/RedBook4/MultiTex.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/MultiTex.hs @@ -0,0 +1,111 @@ +{- + MultiTex.hs (adapted from multitex.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( unless ) +import Foreign ( withArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +specifyTexture :: TextureSize2D -> (GLubyte -> GLubyte -> Color4 GLubyte) -> IO () +specifyTexture size@(TextureSize2D w h) f = + withArray [ f i j | i <- [ 0 .. fromIntegral w - 1 ], + j <- [ 0 .. fromIntegral h - 1] ] $ + texImage2D Texture2D NoProxy 0 RGBA' size 0 . PixelData RGBA UnsignedByte + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + rowAlignment Unpack $= 1 + + [texName0, texName1] <- genObjectNames 2 + textureBinding Texture2D $= Just texName0 + -- Note: We use much brighter colors than in the original example where + -- everything was almost black. + specifyTexture (TextureSize2D 32 32) (\i j -> Color4 (i*8) (j*8) ((i*j) `div` 4) 255) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + + textureBinding Texture2D $= Just texName1 + specifyTexture (TextureSize2D 16 16) (\i j -> Color4 255 (i*16) (j*16) 255) + textureFilter Texture2D $= ((Linear', Nothing), Linear') + textureWrapMode Texture2D S $= (Repeated, ClampToEdge) + textureWrapMode Texture2D T $= (Repeated, ClampToEdge) + -- Use the two texture objects to define two texture units + -- for use in multitexturing + activeTexture $= TextureUnit 0 + texture Texture2D $= Enabled + textureBinding Texture2D $= Just texName0 + textureFunction $= Replace + matrixMode $= Texture + loadIdentity + translate (Vector3 0.5 0.5 (0 :: GLfloat)) + rotate (45 :: GLfloat) (Vector3 0 0 1) + translate (Vector3 (-0.5) (-0.5) (0 :: GLfloat)) + matrixMode $= Modelview 0 + activeTexture $= TextureUnit 1 + texture Texture2D $= Enabled + textureBinding Texture2D $= Just texName1 + textureFunction $= Modulate + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + -- resolve overloading, not needed in "real" programs + let multiTexCoord2f = multiTexCoord :: TextureUnit -> TexCoord2 GLfloat -> IO () + vertex2f = vertex :: Vertex2 GLfloat -> IO () + renderPrimitive Triangles $ do + multiTexCoord2f (TextureUnit 0) (TexCoord2 0 0) + multiTexCoord2f (TextureUnit 1) (TexCoord2 1 0) + vertex2f (Vertex2 0 0) + multiTexCoord2f (TextureUnit 0) (TexCoord2 0.5 1) + multiTexCoord2f (TextureUnit 1) (TexCoord2 0.5 0) + vertex2f (Vertex2 50 100) + multiTexCoord2f (TextureUnit 0) (TexCoord2 1 0) + multiTexCoord2f (TextureUnit 1) (TexCoord2 1 1) + vertex2f (Vertex2 100 0) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D 0 100 0 (100*hf/wf) + else ortho2D 0 (100*wf/hf) 0 100 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + version <- get (majorMinor glVersion) + unless (version >= (1, 3)) $ do + exts <- get glExtensions + unless ("GL_ARB_multitexture" `elem` exts && -- part of 1.3 core + "GL_EXT_texture_object" `elem` exts) $ do -- part of 1.1 core + putStrLn "Sorry, this demo requires the GL_ARB_multitexture and GL_EXT_texture_object extensions." + exitFailure + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Multisamp.hs b/examples/RedBook4/Multisamp.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Multisamp.hs @@ -0,0 +1,137 @@ +{- + Multisamp.hs (adapted from multisamp.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws shows how to use multisampling to draw anti-aliased + geometric primitives. The same display list, a pinwheel of triangles and + lines of varying widths, is rendered twice. Multisampling is enabled when the + left side is drawn. Multisampling is disabled when the right side is drawn. + + Pressing the 'b' key toggles drawing of the checkerboard background. + Antialiasing is sometimes easier to see when objects are rendered over a + contrasting background. +-} + +import Control.Monad ( when ) +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { bgToggle :: IORef Bool } + +makeState :: IO State +makeState = do + b <- newIORef True + return $ State { bgToggle = b } + +data DisplayLists = DisplayLists { pinwheelList, backgroundList :: DisplayList } + +-- Print out state values related to multisampling. Create display list with +-- "pinwheel" of lines and triangles. +myInit :: IO DisplayLists +myInit = do + clearColor $= Color4 0 0 0 0 + sb <- get sampleBuffers + putStrLn ("number of sample buffers is " ++ show sb) + s <- get samples + putStrLn ("number of samples is " ++ show s) + + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + vertex2f = vertex :: Vertex2 GLfloat -> IO () + + p <- defineNewList Compile $ do + flip mapM_ [ 0 .. 18 ] $ \i -> + preservingMatrix $ do + rotate (360 * fromIntegral i / 19 :: GLfloat) (Vector3 0 0 1) + color3f (Color3 1 1 1) + lineWidth $= fromIntegral ((i `mod` 3 :: Int) + 1) + renderPrimitive Lines $ do + vertex2f (Vertex2 0.25 0.05) + vertex2f (Vertex2 0.9 0.2) + color3f (Color3 0 1 1) + renderPrimitive Triangles $ do + vertex2f (Vertex2 0.25 0) + vertex2f (Vertex2 0.9 0) + vertex2f (Vertex2 0.875 0.1) + + b <- defineNewList Compile $ do + color3f (Color3 1 0.5 0) + renderPrimitive Quads $ + flip mapM_ [ 0 .. 15 ] $ \i -> + flip mapM_ [ 0 .. 15 ] $ \j -> + when (((i + j) `mod` 2 :: Int) == 0) $ do + let ii = fromIntegral i * 0.25 + jj = fromIntegral j * 0.25 + vertex2f (Vertex2 (-2.0 + ii) (-2.0 + jj)) + vertex2f (Vertex2 (-2.0 + ii) (-1.75 + jj)) + vertex2f (Vertex2 (-1.75 + ii) (-1.75 + jj)) + vertex2f (Vertex2 (-1.75 + ii) (-2.0 + jj)) + + return $ DisplayLists { pinwheelList = p, backgroundList = b } + +-- Draw two sets of primitives, so that you can compare the user of +-- multisampling against its absence. +-- +-- This code enables antialiasing and draws one display list and disables and +-- draws the other display list +display :: State -> DisplayLists -> DisplayCallback +display state displayLists = do + clear [ ColorBuffer ] + + t <- get (bgToggle state) + when t $ + callList (backgroundList displayLists) + + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + + multisample $= Enabled + preservingMatrix $ do + translatef (Vector3 (-1) 0 0) + callList (pinwheelList displayLists) + + multisample $= Disabled + preservingMatrix $ do + translatef (Vector3 1 0 0) + callList (pinwheelList displayLists) + + swapBuffers + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= 2 * h + then ortho2D (-2) 2 (-2*hf/wf) (2*hf/wf) + else ortho2D (-2*wf/hf) (2*wf/hf) (-2) 2 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'b' -> do bgToggle state $~ not; postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode, Multisampling ] + initialWindowSize $= Size 600 300 + _ <- createWindow progName + state <- makeState + displayLists <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state displayLists + mainLoop diff --git a/examples/RedBook4/PickDepth.hs b/examples/RedBook4/PickDepth.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/PickDepth.hs @@ -0,0 +1,126 @@ +{- + PickDepth.hs (adapted from pickdepth.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Picking is demonstrated in this program. In rendering mode, three + overlapping rectangles are drawn. When the left mouse button is pressed, + selection mode is entered with the picking matrix. Rectangles which are drawn + under the cursor position are "picked." Pay special attention to the depth + value range, which is returned. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + depthFunc $= Just Less + shadeModel $= Flat + depthRange $= (0, 1) -- The default z mapping + +-- The nine squares are drawn. Each square is given two names: one for the row +-- and the other for the column on the grid. The color of each square is +-- determined by its position on the grid, and the value in the board array. +-- Note: In contrast to the the original example, we always give names to +-- squares, regardless of the render mode. This simplifies the code a bit and +-- is even suggested by the Red Book. + +-- The three rectangles are drawn, each with a different name. Note that each +-- rectangle is drawn with a different z value. Note: In contrast to the the +-- original example, we always give names to squares, regardless of the render +-- mode. This simplifies the code a bit and is even suggested by the Red Book. +drawRects :: IO () +drawRects = do + -- resolve overloading, not needed in "real" programs + let color3 = color :: Color3 GLfloat -> IO () + vertex3 = vertex :: Vertex3 GLint -> IO () + loadName (Name 1) + renderPrimitive Quads $ do + color3 (Color3 1.0 1.0 0.0) + vertex3 (Vertex3 2 0 0) + vertex3 (Vertex3 2 6 0) + vertex3 (Vertex3 6 6 0) + vertex3 (Vertex3 6 0 0) + loadName (Name 2) + renderPrimitive Quads $ do + color3 (Color3 0.0 1.0 1.0) + vertex3 (Vertex3 3 2 (-1)) + vertex3 (Vertex3 3 8 (-1)) + vertex3 (Vertex3 8 8 (-1)) + vertex3 (Vertex3 8 2 (-1)) + loadName (Name 3) + renderPrimitive Quads $ do + color3 (Color3 1.0 0.0 1.0) + vertex3 (Vertex3 0 2 (-2)) + vertex3 (Vertex3 0 7 (-2)) + vertex3 (Vertex3 5 7 (-2)) + vertex3 (Vertex3 5 2 (-2)) + +-- processHits prints the hit records. +processHits :: Maybe[HitRecord] -> IO () +processHits Nothing = putStrLn "selection buffer overflow" +processHits (Just hitRecords) = do + putStrLn ("hits = " ++ show (length hitRecords)) + flip mapM_ hitRecords $ \(HitRecord z1 z2 names) -> do + putStrLn (" number of names for hit = " ++ show (length names)) + putStr (" z1 is " ++ show z1) + putStrLn ("; z2 is " ++ show z2) + putStr " the name is" + sequence_ [ putStr (" " ++ show n) | Name n <- names ] + putChar '\n' + +-- pickRects() sets up selection mode, name stack, and projection matrix for +-- picking. Then the objects are drawn. + +bufSize :: GLsizei +bufSize = 512 + +pickRects :: KeyboardMouseCallback +pickRects (MouseButton LeftButton) Down _ (Position x y) = do + vp@(_, (Size _ height)) <- get viewport + (_, maybeHitRecords) <- getHitRecords bufSize $ + withName (Name 0) $ do + matrixMode $= Projection + preservingMatrix $ do + loadIdentity + -- create 5x5 pixel picking region near cursor location + pickMatrix (fromIntegral x, fromIntegral height - fromIntegral y) (5, 5) vp + ortho 0 8 0 8 (-0.5) 2.5 + drawRects + flush + processHits maybeHitRecords + postRedisplay Nothing +pickRects (Char '\27') Down _ _ = exitWith ExitSuccess +pickRects _ _ _ _ = return () + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + drawRects + flush + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 8 0 8 (-0.5) 2.5 + matrixMode $= Modelview 0 + loadIdentity + +-- Main Loop +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 200 200 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just pickRects + mainLoop diff --git a/examples/RedBook4/PickSquare.hs b/examples/RedBook4/PickSquare.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/PickSquare.hs @@ -0,0 +1,121 @@ +{- + PickSquare.hs (adapted from picksquare.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Use of multiple names and picking are demonstrated. A 3x3 grid of squares is + drawn. When the left mouse button is pressed, all squares under the cursor + position have their color changed. +-} + +import Data.Array ( Array, listArray, (!) ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +type Board = Array (Int,Int) (IORef Int) + +data State = State { board :: Board } + +makeState :: IO State +makeState = do + refs <- sequence . replicate 9 . newIORef $ 0 + return $ State { board = listArray ((0,0),(2,2)) refs } + +-- Clear color value for every square on the board +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + +-- The nine squares are drawn. Each square is given two names: one for the row +-- and the other for the column on the grid. The color of each square is +-- determined by its position on the grid, and the value in the board array. +-- Note: In contrast to the the original example, we always give names to +-- squares, regardless of the render mode. This simplifies the code a bit and +-- is even suggested by the Red Book. +drawSquares :: State -> IO () +drawSquares state = + flip mapM_ [ 0 .. 2 ] $ \i -> do + loadName (Name (fromIntegral i)) + flip mapM_ [ 0 .. 2 ] $ \j -> + withName (Name (fromIntegral j)) $ do + val <- get (board state ! (i,j)) + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 (fromIntegral i / 3.0) + (fromIntegral j / 3.0) + (fromIntegral val / 3.0)) + let vertex2i :: Int -> Int -> Vertex2 GLint + vertex2i x y = Vertex2 (fromIntegral x) (fromIntegral y) + rect (vertex2i i j) (vertex2i (i + 1) (j + 1)) + +-- processHits prints the hit records and updates the board array. +processHits :: Maybe[HitRecord] -> State -> IO () +processHits Nothing _ = putStrLn "selection buffer overflow" +processHits (Just hitRecords) state = do + putStrLn ("hits = " ++ show (length hitRecords)) + mapM_ (\(HitRecord z1 z2 names) -> do + putStrLn (" number of names for this hit = " ++ show (length names)) + putStr (" z1 is " ++ show z1) + putStrLn ("; z2 is " ++ show z2) + putStr " names are" + sequence_ [ putStr (" " ++ show n) | Name n <- names ] + putChar '\n' + let [i, j] = [ fromIntegral n | Name n <- names ] + (board state ! (i,j)) $~ (\x -> (x + 1) `mod` 3)) + hitRecords + +-- pickSquares sets up selection mode, name stack, and projection matrix for +-- picking. Then the objects are drawn. + +bufSize :: GLsizei +bufSize = 512 + +pickSquares :: State -> KeyboardMouseCallback +pickSquares state (MouseButton LeftButton) Down _ (Position x y) = do + vp@(_, (Size _ height)) <- get viewport + (_, maybeHitRecords) <- getHitRecords bufSize $ + withName (Name 0) $ do + matrixMode $= Projection + preservingMatrix $ do + loadIdentity + -- create 5x5 pixel picking region near cursor location + pickMatrix (fromIntegral x, fromIntegral height - fromIntegral y) (5, 5) vp + ortho2D 0 3 0 3 + drawSquares state + flush + processHits maybeHitRecords state + postRedisplay Nothing +pickSquares _ (Char '\27') Down _ _ = exitWith ExitSuccess +pickSquares _ _ _ _ _ = return () + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + drawSquares state + flush + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 3 0 3 + matrixMode $= Modelview 0 + loadIdentity + +-- Main Loop +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 100 100 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + myInit + reshapeCallback $= Just reshape + displayCallback $= display state + keyboardMouseCallback $= Just (pickSquares state) + mainLoop diff --git a/examples/RedBook4/Planet.hs b/examples/RedBook4/Planet.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Planet.hs @@ -0,0 +1,83 @@ +{- + Planet.hs (adapted from planet.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program shows how to composite modeling transformations to draw + translated and rotated models. Interaction: pressing the d and y keys + (day and year) alters the rotation of the planet around the sun. +-} + +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { year, day :: IORef GLint } + +makeState :: IO State +makeState = do + y <- newIORef 0 + d <- newIORef 0 + return $ State { year = y, day = d } + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + color3f (Color3 1 1 1) + + preservingMatrix $ do + renderObject Wireframe (Sphere' 1 20 16) -- draw sun + y <- get (year state) + rotate (fromIntegral y :: GLfloat) (Vector3 0 1 0) + translatef (Vector3 2 0 0) + d <- get (day state) + rotate (fromIntegral d :: GLfloat) (Vector3 0 1 0) + renderObject Wireframe (Sphere' 0.2 10 8) -- draw smaller planet + + swapBuffers + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 20 + matrixMode $= Modelview 0 + loadIdentity + lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case c of + 'd' -> update day 10 + 'D' -> update day (-10) + 'y' -> update year 10 + 'Y' -> update year (-10) + '\27' -> exitWith ExitSuccess + _ -> return () + where update angle inc = do + angle state $~ ((`mod` 360) . (+ inc)) + postRedisplay Nothing +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + mainLoop diff --git a/examples/RedBook4/PointP.hs b/examples/RedBook4/PointP.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/PointP.hs @@ -0,0 +1,152 @@ +{- + PointP.hs (adapted from pointp.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates point parameters and their effect on point + primitives. 250 points are randomly generated within a 10 by 10 by 40 region, + centered at the origin. In some modes (including the default), points that + are closer to the viewer will appear larger. + + Pressing the 'c', 'l', and 'q' keys switch the point parameters attenuation + mode to constant, linear, or quadratic, respectively. + + Pressing the 'f' and 'b' keys move the viewer forward and backwards. In + either linear or quadratic attenuation mode, the distance from the viewer to + the point will change the size of the point primitive. + + Pressing the '+' and '-' keys will change the current point size. In this + program, the point size is bounded, so it will not get less than 2, nor + greater than the maximum returned by pointSizeRange. +-} + +import Control.Monad ( when, unless ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure ) +import System.Random ( randomRIO ) +import Graphics.UI.GLUT + +type Attenuation = (GLfloat,GLfloat,GLfloat) + +constant, linear, quadratic :: Attenuation +constant = (1, 0, 0 ) +linear = (0, 0.12, 0 ) +quadratic = (0, 0, 0.01) + +data State = State { distance :: IORef GLfloat } + +makeState :: IO State +makeState = do + d <- newIORef (-10) + return $ State { distance = d } + +-- CFloat has no Random instance, so we go via Float +randomGLfloat :: (GLfloat, GLfloat) -> IO GLfloat +randomGLfloat = fmap floatToGLfloat . randomRIO . fmapPair glFloatToFloat + where fmapPair f (x, y) = (f x, f y) + floatToGLfloat = realToFrac :: Float -> GLfloat + glFloatToFloat = realToFrac :: GLfloat -> Float + +randomColor :: IO (Color3 GLfloat) +randomColor = do + g <- randomGLfloat (0.5, 1) + b <- randomGLfloat (0, 1) + return $ Color3 1 g b + +randomVertex :: IO (Vertex3 GLfloat) +randomVertex = do + x <- randomGLfloat (-5, 5) + y <- randomGLfloat (-5, 5) + z <- randomGLfloat (-5, -45) + return $ Vertex3 x y z + +myInit :: IO DisplayList +myInit = do + pointList <- defineNewList Compile $ + renderPrimitive Points $ + sequence_ $ replicate 250 $ do + color =<< randomColor + vertex =<< randomVertex + + depthFunc $= Just Less + pointSmooth $= Enabled + blend $= Enabled + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + pointSize $= 7 + + pointDistanceAttenuation $= linear + pointFadeThresholdSize $= 2 + + return pointList + +display :: State -> DisplayList -> DisplayCallback +display state pointList = do + clear [ ColorBuffer, DepthBuffer ] + d <- get (distance state) + loadIdentity + translate (Vector3 0 0 d) + callList pointList + swapBuffers + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 35 1 0.25 200 + matrixMode $= Modelview 0 + +setPointDistanceAttenuation :: Attenuation -> IO () +setPointDistanceAttenuation att = do + pointDistanceAttenuation $= att + postRedisplay Nothing + +incDistance :: State -> GLfloat -> IO () +incDistance state inc = do + distance state $~ (+ inc) + postRedisplay Nothing + +incPointSize :: GLfloat -> IO () +incPointSize inc = do + newPointSize <- fmap (+ inc) $ get pointSize + (_,maxPointSize) <- get pointSizeRange + when (2 <= newPointSize && newPointSize <= maxPointSize) $ do + pointSize $= newPointSize + postRedisplay Nothing + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case c of + 'c' -> setPointDistanceAttenuation constant + 'l' -> setPointDistanceAttenuation linear + 'q' -> setPointDistanceAttenuation quadratic + 'b' -> incDistance state (-0.5) + 'f' -> incDistance state 0.5 + '+' -> incPointSize 1 + '-' -> incPointSize (-1) + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ RGBMode, DoubleBuffered, WithDepthBuffer, Multisampling ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + + -- We have to do this *after* createWindow, otherwise we have no OpenGL + -- context. Note that the original C example simply tests for OpenGL 1.4 at + -- compile time, we do a runtime check for the needed extension. + extensions <- get glExtensions + unless ("GL_ARB_point_parameters" `elem` extensions) $ do + putStrLn "Sorry, this demo requires the GL_ARB_point_parameters extension." + exitFailure + + state <- makeState + pointList <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state pointList + mainLoop diff --git a/examples/RedBook4/PolyOff.hs b/examples/RedBook4/PolyOff.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/PolyOff.hs @@ -0,0 +1,151 @@ +{- + PolyOff.hs (adapted from polyoff.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates polygon offset to draw a shaded polygon and its + wireframe counterpart without ugly visual artifacts ("stitching"). +-} + +import Control.Monad ( when ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure ) +import Graphics.UI.GLUT + +data State = State { + spinX, spinY :: IORef GLfloat, + tDist :: IORef GLfloat, + polyFactor :: IORef GLfloat, + polyUnits :: IORef GLfloat + } + +makeState :: IO State +makeState = do + x <- newIORef 0 + y <- newIORef 0 + t <- newIORef 0 + f <- newIORef 1 + u <- newIORef 1 + return $ State { spinX = x, spinY = y, tDist = t, polyFactor = f, polyUnits = u } + +-- display draws two spheres, one with a gray, diffuse material, the other +-- sphere with a magenta material with a specular highlight. +display :: State -> DisplayList -> DisplayCallback +display state sphereList = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + t <- get (tDist state) + translate (Vector3 0 0 t) + x <- get (spinX state) + rotate x (Vector3 1 0 0) + y <- get (spinY state) + rotate y (Vector3 0 1 0) + + materialAmbientAndDiffuse Front $= Color4 0.8 0.8 0.8 1 + materialSpecular Front $= Color4 0 0 0 1 + materialShininess Front $= 0 + lighting $= Enabled + light (Light 0) $= Enabled + polygonOffsetFill $= Enabled + f <- get (polyFactor state) + u <- get (polyUnits state) + polygonOffset $= (f, u) + callList sphereList + polygonOffsetFill $= Disabled + + lighting $= Disabled + light (Light 0) $= Disabled + color (Color3 1 1 (1 :: GLfloat)) + polygonMode $= (Line, Line) + callList sphereList + polygonMode $= (Fill, Fill) + + flush + +-- specify initial properties +-- create display list with sphere +-- initialize lighting and depth buffer +gfxinit :: IO DisplayList +gfxinit = do + clearColor $= Color4 0 0 0 1 + + sphereList <- defineNewList Compile $ + renderObject Solid (Sphere' 1 20 12) + + depthFunc $= Just Less + + ambient (Light 0) $= Color4 0 0 0 1 + diffuse (Light 0) $= Color4 1 1 1 1 + specular (Light 0) $= Color4 1 1 1 1 + position (Light 0) $= Vertex4 1 1 1 0 + lightModelAmbient $= Color4 0.2 0.2 0.2 1 + + return sphereList + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 45 (fromIntegral w / fromIntegral h) 1 10 + matrixMode $= Modelview 0 + loadIdentity + lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) + +incSpin :: IORef GLfloat -> IO () +incSpin spinRef = do + let wrap n s = if s > n then s - n else s + spinRef $~ (wrap 360 . (+ 5)) + postRedisplay Nothing + +incDist :: State -> GLfloat -> IO () +incDist state inc = do + newDist <- fmap (+ inc) $ get (tDist state) + when (-5 <= newDist && newDist <= 4) $ do + tDist state $= newDist + postRedisplay Nothing + +incPoly :: String -> IORef GLfloat -> GLfloat -> IO () +incPoly name polyRef inc = do + polyRef $~ (+ inc) + p <- get polyRef + putStrLn (name ++ " is " ++ show p) + postRedisplay Nothing + +keyboardMouse :: State -> KeyboardMouseCallback +keyboardMouse state k Down _ _ = case k of + (MouseButton LeftButton) -> incSpin (spinX state) + (MouseButton MiddleButton) -> incSpin (spinY state) + (MouseButton RightButton) -> exitWith ExitSuccess + (Char 't') -> incDist state 0.5 + (Char 'T') -> incDist state (-0.5) + (Char 'F') -> incPoly "polyFactor" (polyFactor state) 0.1 + (Char 'f') -> incPoly "polyFactor" (polyFactor state) (-0.1) + (Char 'U') -> incPoly "polyUnits" (polyUnits state) 1 + (Char 'u') -> incPoly "polyUnits" (polyUnits state) (-1) + _ -> return () +keyboardMouse _ _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + _ <- createWindow progName + + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + version <- get (majorMinor glVersion) + when (version == (1,0)) $ do + putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." + putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," + putStrLn "you may be able to modify this program to make it run." + exitFailure + + state <- makeState + sphereList <- gfxinit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboardMouse state) + displayCallback $= display state sphereList + mainLoop diff --git a/examples/RedBook4/Polys.hs b/examples/RedBook4/Polys.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Polys.hs @@ -0,0 +1,84 @@ +{- + Polys.hs (adapted from polys.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates polygon stippling. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +fly :: IO GLpolygonstipple +fly = newPolygonStipple [ + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x03, 0x80, 0x01, 0xC0, 0x06, 0xC0, 0x03, 0x60, + 0x04, 0x60, 0x06, 0x20, 0x04, 0x30, 0x0C, 0x20, + 0x04, 0x18, 0x18, 0x20, 0x04, 0x0C, 0x30, 0x20, + 0x04, 0x06, 0x60, 0x20, 0x44, 0x03, 0xC0, 0x22, + 0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22, + 0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22, + 0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22, + 0x66, 0x01, 0x80, 0x66, 0x33, 0x01, 0x80, 0xCC, + 0x19, 0x81, 0x81, 0x98, 0x0C, 0xC1, 0x83, 0x30, + 0x07, 0xe1, 0x87, 0xe0, 0x03, 0x3f, 0xfc, 0xc0, + 0x03, 0x31, 0x8c, 0xc0, 0x03, 0x33, 0xcc, 0xc0, + 0x06, 0x64, 0x26, 0x60, 0x0c, 0xcc, 0x33, 0x30, + 0x18, 0xcc, 0x33, 0x18, 0x10, 0xc4, 0x23, 0x08, + 0x10, 0x63, 0xC6, 0x08, 0x10, 0x30, 0x0c, 0x08, + 0x10, 0x18, 0x18, 0x08, 0x10, 0x00, 0x00, 0x08] + +halftone :: IO GLpolygonstipple +halftone = newPolygonStipple . take 128 . cycle $ [ + 0xAA, 0xAA, 0xAA, 0xAA, 0x55, 0x55, 0x55, 0x55] + +display :: (GLpolygonstipple, GLpolygonstipple) -> DisplayCallback +display (flyStipple, halftoneStipple) = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + rectf = rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO () + color3f (Color3 1 1 1) + + -- draw one solid, unstippled rectangle, + -- then two stippled rectangles + rectf (Vertex2 25 25) (Vertex2 125 125) + polygonStipple $= Just flyStipple + rectf (Vertex2 125 25) (Vertex2 225 125) + polygonStipple $= Just halftoneStipple + rectf (Vertex2 225 25) (Vertex2 325 125) + polygonStipple $= (Nothing :: Maybe GLpolygonstipple) + + flush + +myInit :: IO (GLpolygonstipple, GLpolygonstipple) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + flyStipple <- fly + halftoneStipple <- halftone + return (flyStipple, halftoneStipple) + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0.0 (fromIntegral w) 0.0 (fromIntegral h) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 350 150 + _ <- createWindow progName + stipples <- myInit + displayCallback $= display stipples + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Quadric.hs b/examples/RedBook4/Quadric.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Quadric.hs @@ -0,0 +1,106 @@ +{- + Quadric.hs (adapted from quadric.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the use of the renderQuadric routine. Quadric + objects are created with some quadric properties and errors are reported. + Note that the cylinder has no top or bottom and the circle has a hole in it. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO (DisplayList, DisplayList, DisplayList, DisplayList) +myInit = do + clearColor $= Color4 0 0 0 0 + + materialAmbient Front $= Color4 0.5 0.5 0.5 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 50 + position (Light 0) $= Vertex4 1 1 1 0 + lightModelAmbient $= Color4 0.5 0.5 0.5 1 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + + -- Create 4 display lists, each with a different quadric object. + -- Different drawing styles and surface normal specifications + -- are demonstrated. + -- smooth shaded + dl1 <- newQuadricDL (Just Smooth) FillStyle (Sphere 0.75 15 10) + -- flat shaded + dl2 <- newQuadricDL (Just Flat) FillStyle (Cylinder 0.5 0.3 1 15 5) + -- all polygons wireframe + dl3 <- newQuadricDL Nothing LineStyle (Disk 0.25 1 20 4) + -- boundary only + dl4 <- newQuadricDL Nothing SilhouetteStyle (PartialDisk 0 1 20 4 0 225) + return (dl1, dl2, dl3, dl4) + +newQuadricDL :: QuadricNormal -> QuadricDrawStyle -> QuadricPrimitive -> IO DisplayList +newQuadricDL n s p = + defineNewList Compile $ do + renderQuadric (QuadricStyle n NoTextureCoordinates Outside s) p + reportErrors + +display :: (DisplayList, DisplayList, DisplayList, DisplayList) -> DisplayCallback +display (dl1, dl2, dl3, dl4) = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + color3f = color :: Color3 GLfloat -> IO () + + lighting $= Enabled + shadeModel $= Smooth + translatef (Vector3 (-1) (-1) 0) + callList dl1 + + shadeModel $= Flat + translatef (Vector3 0 2 0) + preservingMatrix $ do + rotatef 300 (Vector3 1 0 0) + callList dl2 + + lighting $= Disabled + color3f (Color3 0 1 1) + translatef (Vector3 2 (-2) 0) + callList dl3 + + color3f (Color3 1 1 0) + translatef (Vector3 0 2 0) + callList dl4 + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10) 10 + else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10) 10 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + displayLists <- myInit + displayCallback $= display displayLists + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/ReadImage.hs b/examples/RedBook4/ReadImage.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/ReadImage.hs @@ -0,0 +1,65 @@ +{- + ReadImage.hs (adapted from readImage.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Support for reading a file of raw RGB data: + 4 bytes big-endian width + 4 bytes big-endian height + width * height RGB byte triples +-} + +module ReadImage ( readImage ) where + +import Data.Word ( Word8, Word32 ) +import Control.Exception ( bracket ) +import Control.Monad ( when ) +import System.IO ( Handle, IOMode(ReadMode), openBinaryFile, hGetBuf, hClose ) +import System.IO.Error ( mkIOError, eofErrorType ) +import Foreign ( Ptr, alloca, mallocBytes, Storable(..) ) +import Graphics.UI.GLUT + +-- This is probably overkill, but anyway... +newtype Word32BigEndian = Word32BigEndian Word32 + +word32BigEndianToGLsizei :: Word32BigEndian -> GLsizei +word32BigEndianToGLsizei (Word32BigEndian x) = fromIntegral x + +instance Storable Word32BigEndian where + sizeOf ~(Word32BigEndian x) = sizeOf x + alignment ~(Word32BigEndian x) = alignment x + peek ptr = do + let numBytes = sizeOf (undefined :: Word32BigEndian) + bytes <- mapM (peekByteOff ptr) [ 0 .. numBytes - 1 ] :: IO [Word8] + let value = foldl (\val byte -> val * 256 + fromIntegral byte) 0 bytes + return $ Word32BigEndian value + poke = error "" + +-- This is the reason for all this stuff above... +readGLsizei :: Handle -> IO GLsizei +readGLsizei handle = + alloca $ \buf -> do + hGetBufFully handle buf (sizeOf (undefined :: Word32BigEndian)) + fmap word32BigEndianToGLsizei $ peek buf + +-- A handy variant of hGetBuf with additional error checking +hGetBufFully :: Handle -> Ptr a -> Int -> IO () +hGetBufFully handle ptr numBytes = do + bytesRead <- hGetBuf handle ptr numBytes + when (bytesRead /= numBytes) $ + ioError $ mkIOError eofErrorType "hGetBufFully" (Just handle) Nothing + +-- Closing a file is nice, even when an error occurs during reading. +withBinaryFile :: FilePath -> (Handle -> IO a) -> IO a +withBinaryFile filePath = bracket (openBinaryFile filePath ReadMode) hClose + +readImage :: FilePath -> IO (Size, PixelData a) +readImage filePath = + withBinaryFile filePath $ \handle -> do + width <- readGLsizei handle + height <- readGLsizei handle + let numBytes = fromIntegral (3 * width * height) + buf <- mallocBytes numBytes + hGetBufFully handle buf numBytes + return (Size width height, PixelData RGB UnsignedByte buf) diff --git a/examples/RedBook4/Robot.hs b/examples/RedBook4/Robot.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Robot.hs @@ -0,0 +1,89 @@ +{- + Robot.hs (adapted from robot.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program shows how to composite modeling transformations to draw + translated and rotated hierarchical models. Interaction: pressing the s + and e keys (shoulder and elbow) alters the rotation of the robot arm. +-} + +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { shoulder, elbow :: IORef GLint } + +makeState :: IO State +makeState = do + s <- newIORef 0 + e <- newIORef 0 + return $ State { shoulder = s, elbow = e } + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () + preservingMatrix $ do + translatef (Vector3 (-1) 0 0) + s <- get (shoulder state) + rotate (fromIntegral s :: GLfloat) (Vector3 0 0 1) + translatef (Vector3 1 0 0) + preservingMatrix $ do + scalef 2 0.4 1 + renderObject Wireframe (Cube 1) + translatef (Vector3 1 0 0) + e <- get (elbow state) + rotate (fromIntegral e :: GLfloat) (Vector3 0 0 1) + translatef (Vector3 1 0 0) + preservingMatrix $ do + scalef 2 0.4 1 + renderObject Wireframe (Cube 1) + swapBuffers + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 65 (fromIntegral w / fromIntegral h) 1 20 + matrixMode $= Modelview 0 + loadIdentity + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + translatef (Vector3 0 0 (-5)) + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case c of + 's' -> update shoulder 5 + 'S' -> update shoulder (-5) + 'e' -> update elbow 5 + 'E' -> update elbow (-5) + '\27' -> exitWith ExitSuccess + _ -> return () + where update joint inc = do + joint state $~ ((`mod` 360) . (+ inc)) + postRedisplay Nothing +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + mainLoop diff --git a/examples/RedBook4/Scene.hs b/examples/RedBook4/Scene.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Scene.hs @@ -0,0 +1,73 @@ +{- + Scene.hs (adapted from scene.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the use of the GL lighting model. Objects are + drawn using a grey material characteristic. A single light source + illuminates the objects. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Initialize material property and light source. +myInit :: IO () +myInit = do + ambient (Light 0) $= Color4 0 0 0 1 + diffuse (Light 0) $= Color4 1 1 1 1 + specular (Light 0) $= Color4 1 1 1 1 + -- light position is NOT default value + position (Light 0) $= Vertex4 1 1 1 0 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + rotate (20 :: GLfloat) (Vector3 1 0 0) + preservingMatrix $ do + translate (Vector3 (-0.75) 0.5 (0 :: GLfloat)) + rotate (90 :: GLfloat) (Vector3 1 0 0) + renderObject Solid (Torus 0.275 0.85 15 15) + preservingMatrix $ do + translate (Vector3 (-0.75) (-0.5) (0 :: GLfloat)) + rotate (270 :: GLfloat) (Vector3 1 0 0) + renderObject Solid (Cone 1 2 15 15) + preservingMatrix $ do + translate (Vector3 0.75 0 (-1 :: GLfloat)) + renderObject Solid (Sphere' 1 15 15) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-2.5) 2.5 (-2.5 * hf/wf) (2.5 * hf/wf) (-10) 10 + else ortho (-2.5 * wf/hf) (2.5 * wf/hf) (-2.5) 2.5 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Select.hs b/examples/RedBook4/Select.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Select.hs @@ -0,0 +1,150 @@ +{- + Select.hs (adapted from select.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This is an illustration of the selection mode and name stack, which detects + whether objects which collide with a viewing volume. First, four triangles + and a rectangular box representing a viewing volume are drawn (drawScene + routine). The green triangle and yellow triangles appear to lie within the + viewing volume, but the red triangle appears to lie outside it. Then the + selection mode is entered (selectObjects routine). Drawing to the screen + ceases. To see if any collisions occur, the four triangles are called. In + this example, the green triangle causes one hit with the name 1, and the + yellow triangles cause one hit with the name 3. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- draw a triangle with vertices at (x1, y1), (x2, y2) and (x3, y3) at z units +-- away from the origin. +drawTriangle :: + Vertex2 GLfloat -> Vertex2 GLfloat -> Vertex2 GLfloat -> GLfloat -> IO () +drawTriangle (Vertex2 x1 y1) (Vertex2 x2 y2) (Vertex2 x3 y3) z = do + renderPrimitive Triangles $ mapM_ vertex [ + Vertex3 x1 y1 z, + Vertex3 x2 y2 z, + Vertex3 x3 y3 z] + +-- draw a rectangular box with these outer x, y, and z values +drawViewVolume :: Vertex3 GLfloat -> Vertex3 GLfloat -> IO () +drawViewVolume (Vertex3 x1 y1 z1) (Vertex3 x2 y2 z2) = do + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 1 1 1) + renderPrimitive LineLoop $ mapM_ vertex [ + Vertex3 x1 y1 (-z1), + Vertex3 x2 y1 (-z1), + Vertex3 x2 y2 (-z1), + Vertex3 x1 y2 (-z1)] + + renderPrimitive LineLoop $ mapM_ vertex [ + Vertex3 x1 y1 (-z2), + Vertex3 x2 y1 (-z2), + Vertex3 x2 y2 (-z2), + Vertex3 x1 y2 (-z2)] + + renderPrimitive Lines $ mapM_ vertex [ -- 4 lines + Vertex3 x1 y1 (-z1), + Vertex3 x1 y1 (-z2), + Vertex3 x1 y2 (-z1), + Vertex3 x1 y2 (-z2), + Vertex3 x2 y1 (-z1), + Vertex3 x2 y1 (-z2), + Vertex3 x2 y2 (-z1), + Vertex3 x2 y2 (-z2)] + +-- drawScene draws 4 triangles and a wire frame which represents the viewing +-- volume. +drawScene :: IO () +drawScene = do + matrixMode $= Projection + loadIdentity + perspective 40 (4/3) 1 100 + + matrixMode $= Modelview 0 + loadIdentity + lookAt (Vertex3 7.5 7.5 12.5) (Vertex3 2.5 2.5 (-5)) (Vector3 0 1 0) + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 0 1 0) -- green triangle + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-5) + color3f (Color3 1 0 0) -- red triangle + drawTriangle (Vertex2 2 7) (Vertex2 3 7) (Vertex2 2.5 8) (-5) + color3f (Color3 1 1 0) -- yellow triangles + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-1) + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-9) + drawViewVolume (Vertex3 0 0 0) (Vertex3 5 5 10) + +processHits :: Maybe [HitRecord] -> IO () +processHits Nothing = putStrLn "selection buffer overflow" +processHits (Just hitRecords) = do + putStrLn ("hits = " ++ show (length hitRecords)) + mapM_ (\(HitRecord z1 z2 names) -> do + putStrLn (" number of names for hit = " ++ show (length names)) + putStr (" z1 is " ++ show z1) + putStrLn ("; z2 is " ++ show z2) + putStr " the name is" + sequence_ [ putStr (" " ++ show n) | Name n <- names ] + putChar '\n') + hitRecords + +-- selectObjects "draws" the triangles in selection mode, assigning names for +-- the triangles. Note that the third and fourth triangles share one name, so +-- that if either or both triangles intersects the viewing/clipping volume, +-- only one hit will be registered. + +bufSize :: GLsizei +bufSize = 512 + +selectObjects :: IO () +selectObjects = do + (_, maybeHitRecords) <- getHitRecords bufSize $ do + withName (Name 0) $ do + preservingMatrix $ do + matrixMode $= Projection + loadIdentity + ortho 0 5 0 5 0 10 + matrixMode $= Modelview 0 + loadIdentity + loadName (Name 1) + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-5) + loadName (Name 2) + drawTriangle (Vertex2 2 7) (Vertex2 3 7) (Vertex2 2.5 8) (-5) + loadName (Name 3) + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-1) + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-9) + flush + processHits maybeHitRecords + +myInit :: IO () +myInit = do + depthFunc $= Just Less + shadeModel $= Flat + +display :: DisplayCallback +display = do + clearColor $= Color4 0 0 0 0 + clear [ ColorBuffer, DepthBuffer ] + drawScene + selectObjects + flush + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 200 200 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/ShadowMap.hs b/examples/RedBook4/ShadowMap.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/ShadowMap.hs @@ -0,0 +1,255 @@ +{- + ShadowMap.hs (adapted from shadowmap.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( when, unless ) +import Data.IORef ( IORef, newIORef ) +import Foreign.Marshal.Array ( allocaArray ) +import Foreign.Ptr ( nullPtr ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +shadowMapSize :: TextureSize2D +shadowMapSize = TextureSize2D 256 256 + +fovy, nearPlane, farPlane :: GLdouble +fovy = 60 +nearPlane = 10 +farPlane = 100 + +lightPos :: Vertex4 GLfloat +lightPos = Vertex4 25 25 25 1 + +lookat :: Vertex3 GLdouble +lookat = Vertex3 0 0 0 + +up :: Vector3 GLdouble +up = Vector3 0 0 1 + +data State = State { + angle :: IORef GLdouble, + torusAngle :: IORef GLfloat, + showShadow :: IORef Bool, + animate :: IORef Bool, + funcMode :: IORef ComparisonFunction } + +makeState :: IO State +makeState = do + a <- newIORef 0 + t <- newIORef 0 + s <- newIORef False + n <- newIORef True + f <- newIORef Lequal + return $ State { angle = a, torusAngle = t, showShadow = s, + animate = n, funcMode = f } + +myInit :: IO () +myInit = do + texImage2D Texture2D NoProxy 0 DepthComponent' shadowMapSize 0 + (PixelData DepthComponent UnsignedByte nullPtr) + + position (Light 0) $= lightPos + let white = Color4 1 1 1 1 + specular (Light 0) $= white + diffuse (Light 0) $= white + + textureWrapMode Texture2D S $= (Repeated, ClampToEdge) + textureWrapMode Texture2D T $= (Repeated, ClampToEdge) + textureFilter Texture2D $= ((Linear', Nothing), Linear') + textureCompareMode Texture2D $= Just Lequal + depthTextureMode Texture2D $= Luminance' + + colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse) + + cullFace $= Just Back + + depthFunc $= Just Less + light (Light 0) $= Enabled + lighting $= Enabled + texture Texture2D $= Enabled + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective fovy (fromIntegral w / fromIntegral h) nearPlane farPlane + matrixMode $= Modelview 0 + +idle :: State -> IdleCallback +idle state = do + angle state $~! (+ (pi / 10000)) + torusAngle state $~! (+ 0.1) + postRedisplay Nothing + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = do + case c of + '\27' -> exitWith ExitSuccess + 't' -> + texture Texture2D $~ \cap -> if cap == Enabled then Disabled else Enabled + 'm' -> do + fm <- get (funcMode state) + textureCompareMode Texture2D $~ maybe (Just fm) (const Nothing) + compareMode <- get (textureCompareMode Texture2D) + putStrLn ("Compare mode " ++ maybe "Off" (const "On") compareMode) + 'f' -> do + funcMode state $~ \fm -> if fm == Lequal then Gequal else Lequal + fm <- get (funcMode state) + putStrLn ("Operator " ++ show fm) + textureCompareMode Texture2D $~ maybe Nothing (const (Just fm)) + 's' -> showShadow state $~ not + 'p' -> do + animate state $~ not + animate' <- get (animate state) + idleCallback $= if animate' then Just (idle state) else Nothing + _ -> return () + postRedisplay Nothing +keyboard _ _ _ _ _ = return () + +drawObjects :: GLfloat -> Bool -> IO () +drawObjects torusAngle' shadowRender = do + textureOn <- get (texture Texture2D) + + when shadowRender $ + texture Texture2D $= Disabled + + -- resolve overloading, not needed in "real" programs + let normal3f = normal :: Normal3 GLfloat -> IO () + color3f = color :: Color3 GLfloat -> IO () + rectf = rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + + unless shadowRender $ do + normal3f (Normal3 0 0 1) + color3f (Color3 1 1 1) + rectf (Vertex2 (-20) (-20)) (Vertex2 20 20) + + preservingMatrix $ do + translatef (Vector3 11 11 11) + rotatef 54.73 (Vector3 (-5) 5 0) + rotate torusAngle' (Vector3 1 0 0) + color3f (Color3 1 0 0) + renderObject Solid (Torus 1 4 8 36) + + preservingMatrix $ do + translatef (Vector3 2 2 2) + color3f (Color3 0 0 1) + renderObject Solid (Cube 4) + + preservingMatrix $ do + getLightPos Vector3 >>= translate + color3f (Color3 1 1 1) + renderObject Wireframe (Sphere' 0.5 6 6) + + when (shadowRender && textureOn == Enabled) $ + texture Texture2D $= Enabled + +getLightPos :: (GLdouble -> GLdouble -> GLdouble -> a) -> IO a +getLightPos f = do + Vertex4 x y z _ <- get (position (Light 0)) + return $ f (realToFrac x) (realToFrac y) (realToFrac z) + +generateShadowMap :: GLfloat -> Bool -> IO () +generateShadowMap torusAngle' showShadow' = do + lightPos' <- getLightPos Vertex3 + let (TextureSize2D shadowMapWidth shadowMapHeight) = shadowMapSize + shadowMapSize' = Size shadowMapWidth shadowMapHeight + + preservingViewport $ do + viewport $= (Position 0 0, shadowMapSize') + + clear [ ColorBuffer, DepthBuffer ] + + matrixMode $= Projection + preservingMatrix $ do + loadIdentity + perspective 80 1 10 1000 + matrixMode $= Modelview 0 + preservingMatrix $ do + loadIdentity + lookAt lightPos' lookat up + drawObjects torusAngle' True + matrixMode $= Projection + matrixMode $= Modelview 0 + + copyTexImage2D Texture2D 0 DepthComponent' (Position 0 0) shadowMapSize 0 + + when showShadow' $ do + let numShadowMapPixels = fromIntegral (shadowMapWidth * shadowMapHeight) + allocaArray numShadowMapPixels $ \depthImage -> do + let pixelData fmt = PixelData fmt Float depthImage :: PixelData GLfloat + readPixels (Position 0 0) shadowMapSize' (pixelData DepthComponent) + (_, Size viewPortWidth _) <- get viewport + windowPos (Vertex2 (fromIntegral viewPortWidth / 2 :: GLfloat) 0) + drawPixels shadowMapSize' (pixelData Luminance) + swapBuffers + +-- Note: preservingViewport is not exception safe, but it doesn't matter here +preservingViewport :: IO a -> IO a +preservingViewport act = do + v <- get viewport + x <- act + viewport $= v + return x + +generateTextureMatrix :: IO () +generateTextureMatrix = do + -- Set up projective texture matrix. We use the Modelview matrix stack and + -- OpenGL matrix commands to make the matrix. + m <- preservingMatrix $ do + loadIdentity + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () + translatef (Vector3 0.5 0.5 0.0) + scalef 0.5 0.5 1.0 + perspective 60 1 1 1000 + lightPos' <- getLightPos Vertex3 + lookAt lightPos' lookat up + get (matrix (Just (Modelview 0))) + + [ sx, sy, sz, sw, + tx, ty, tz, tw, + rx, ry, rz, rw, + qx, qy, qz, qw ] <- getMatrixComponents RowMajor (m :: GLmatrix GLdouble) + + textureGenMode S $= Just (ObjectLinear (Plane sx sy sz sw)) + textureGenMode T $= Just (ObjectLinear (Plane tx ty tz tw)) + textureGenMode R $= Just (ObjectLinear (Plane rx ry rz rw)) + textureGenMode Q $= Just (ObjectLinear (Plane qx qy qz qw)) + +display :: State -> DisplayCallback +display state = do + let radius = 30 + torusAngle' <- get (torusAngle state) + showShadow' <- get (showShadow state) + generateShadowMap torusAngle' showShadow' + generateTextureMatrix + unless showShadow' $ do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + angle' <- get (angle state) + lookAt (Vertex3 (radius * cos angle') (radius * sin angle') 30) lookat up + drawObjects torusAngle' False + swapBuffers + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ RGBAMode, WithDepthBuffer, DoubleBuffered ] + initialWindowSize $= Size 521 512 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + idleCallback $= Just (idle state) + + mainLoop diff --git a/examples/RedBook4/Smooth.hs b/examples/RedBook4/Smooth.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Smooth.hs @@ -0,0 +1,65 @@ +{- + Smooth.hs (adapted from smooth.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates smooth shading. A smooth shaded polygon is drawn in + a 2-D projection. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + +triangle :: IO () +triangle = + -- resolve overloading, not needed in "real" programs + let vertex2f = vertex :: Vertex2 GLfloat -> IO () + color3f = color :: Color3 GLfloat -> IO () + in renderPrimitive Triangles $ do + color3f (Color3 1 0 0) + vertex2f (Vertex2 5 5) + color3f (Color3 0 1 0) + vertex2f (Vertex2 25 5) + color3f (Color3 0 0 1) + vertex2f (Vertex2 5 25) + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + triangle + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D 0 30 0 (30 * hf/wf) + else ortho2D 0 (30 * wf/hf) 0 30 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Stencil.hs b/examples/RedBook4/Stencil.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Stencil.hs @@ -0,0 +1,123 @@ +{- + Stencil.hs (adapted from stencil.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates use of the stencil buffer for masking + nonrectangular regions. Whenever the window is redrawn, a value of 1 is drawn + into a diamond-shaped region in the stencil buffer. Elsewhere in the stencil + buffer, the value is 0. Then a blue sphere is drawn where the stencil value + is 1, and yellow torii are drawn where the stencil value is not 1. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data DisplayLists = DisplayLists { yellowMat, blueMat :: DisplayList } + +myInit :: IO DisplayLists +myInit = do + y <- defineNewList Compile $ do + materialDiffuse Front $= Color4 0.7 0.7 0 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 64 + + b <- defineNewList Compile $ do + materialDiffuse Front $= Color4 0.1 0.1 0.7 1 + materialSpecular Front $= Color4 0.1 1 1 1 + materialShininess Front $= 45 + + position (Light 0) $= Vertex4 1 1 1 0 + + light (Light 0) $= Enabled + lighting $= Enabled + depthFunc $= Just Less + + clearStencil $= 0 + stencilTest $= Enabled + + return $ DisplayLists { yellowMat = y, blueMat = b } + +-- Draw a sphere in a diamond-shaped section in the middle of a window with 2 +-- torii. +display :: DisplayLists -> DisplayCallback +display displayLists = do + clear [ ColorBuffer, DepthBuffer ] + + -- draw blue sphere where the stencil is 1 + stencilFunc $= (Equal, 1, 1) + stencilOp $= (OpKeep, OpKeep, OpKeep) + callList (blueMat displayLists) + renderObject Solid (Sphere' 0.5 15 15) + + -- resolve overloading, not needed in "real" programs + let rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + + -- draw the tori where the stencil is not 1 + stencilFunc $= (Notequal, 1, 1) + preservingMatrix $ do + rotatef 45 (Vector3 0 0 1) + rotatef 45 (Vector3 0 1 0) + callList (yellowMat displayLists) + renderObject Solid (Torus 0.275 0.85 15 15) + preservingMatrix $ do + rotatef 90 (Vector3 1 0 0) + renderObject Solid (Torus 0.275 0.85 15 15) + + flush + +-- Whenever the window is reshaped, redefine the coordinate system and redraw +-- the stencil area. +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + + -- create a diamond shaped stencil area + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D (-3) 3 (-3*hf/wf) (3*hf/wf) + else ortho2D (-3*wf/hf) (3*wf/hf) (-3) 3 + matrixMode $= Modelview 0 + loadIdentity + + -- resolve overloading, not needed in "real" programs + let vertex2f = vertex :: Vertex2 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + + clear [ StencilBuffer ] + stencilFunc $= (Always, 1, 1) + stencilOp $= (OpReplace, OpReplace, OpReplace) + renderPrimitive Quads $ do + vertex2f (Vertex2 (-1) 0) + vertex2f (Vertex2 0 1) + vertex2f (Vertex2 1 0) + vertex2f (Vertex2 0 (-1)) + + matrixMode $= Projection + loadIdentity + perspective 45 (wf/hf) 3 7 + matrixMode $= Modelview 0 + loadIdentity + translatef (Vector3 0 0 (-5)) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Be certain to request stencil bits. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer, WithStencilBuffer ] + initialWindowSize $= Size 400 400 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + displayLists <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display displayLists + mainLoop diff --git a/examples/RedBook4/Stroke.hs b/examples/RedBook4/Stroke.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Stroke.hs @@ -0,0 +1,127 @@ +{- + Stroke.hs (adapted from stroke.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates some characters of a stroke (vector) font. The + characters are represented by display lists, which are given numbers which + correspond to the ASCII values of the characters. Use of callLists is + demonstrated. +-} + +import Data.List ( genericLength ) +import Foreign.C.String ( castCharToCChar ) +import Foreign.Marshal.Array ( withArray ) +import Graphics.UI.GLUT +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) + +aData, eData, pData, rData, sData :: [[Vertex2 GLfloat]] +aData = [ + [ Vertex2 0 0, Vertex2 0 9, Vertex2 1 10, Vertex2 4 10, Vertex2 5 9, + Vertex2 5 0 ], + [ Vertex2 0 5, Vertex2 5 5 ] ] + +eData = [ + [ Vertex2 5 0, Vertex2 0 0, Vertex2 0 10, Vertex2 5 10 ], + [ Vertex2 0 5, Vertex2 4 5 ] ] + +pData = [ + [ Vertex2 0 0, Vertex2 0 10, Vertex2 4 10, Vertex2 5 9, Vertex2 5 6, + Vertex2 4 5, Vertex2 0 5 ] ] + +rData = [ + [ Vertex2 0 0, Vertex2 0 10, Vertex2 4 10, Vertex2 5 9, Vertex2 5 6, + Vertex2 4 5, Vertex2 0 5 ], + [ Vertex2 3 5, Vertex2 5 0 ] ] + +sData = [ + [ Vertex2 0 1, Vertex2 1 0, Vertex2 4 0, Vertex2 5 1, Vertex2 5 4, + Vertex2 4 5, Vertex2 1 5, Vertex2 0 6, Vertex2 0 9, Vertex2 1 10, + Vertex2 4 10, Vertex2 5 9 ] ] + +advance :: IO () +advance = translate (Vector3 8 0 (0 :: GLfloat)) + +-- drawLetter renders a letter with line segments given by the list of line +-- strips. +drawLetter :: [[Vertex2 GLfloat]] -> IO () +drawLetter lineStrips = do + mapM_ (renderPrimitive LineStrip . mapM_ vertex) lineStrips + advance + +charToGLubyte :: Char -> GLubyte +charToGLubyte = fromIntegral . castCharToCChar + +myInit :: IO () +myInit = do + shadeModel $= Flat + + (base@(DisplayList b):_) <- genObjectNames 128 + listBase $= base + let charToDisplayList c = DisplayList (b + fromIntegral (charToGLubyte c)) + mapM_ (\(c, d) -> defineList (charToDisplayList c) Compile d) + [ ('A', drawLetter aData), + ('E', drawLetter eData), + ('P', drawLetter pData), + ('R', drawLetter rData), + ('S', drawLetter sData), + (' ', advance) ] + +test1, test2 :: String +test1 = "A SPARE SERAPE APPEARS AS" +test2 = "APES PREPARE RARE PEPPERS" + +printStrokedString :: String -> IO () +printStrokedString s = + withArray (map charToGLubyte s) $ + callLists (genericLength s) UnsignedByte + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + + color3f (Color3 1 1 1) + preservingMatrix $ do + scalef 2 2 2 + translatef (Vector3 10 30 0) + printStrokedString test1 + preservingMatrix $ do + scalef 2 2 2 + translatef (Vector3 10 13 0) + printStrokedString test2 + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char c) Down _ _ = case c of + ' ' -> postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 440 120 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display + mainLoop diff --git a/examples/RedBook4/SurfPoints.hs b/examples/RedBook4/SurfPoints.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/SurfPoints.hs @@ -0,0 +1,129 @@ +{- + SurfPoints.hs (adapted from surfpoints.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program is a modification of the earlier Surface.hs program. The + vertex data are not directly rendered, but are instead passed to the + callback function. The values of the tessellated vertices are printed + out there. + + This program draws a NURBS surface in the shape of a symmetrical hill. + The 'c' keyboard key allows you to toggle the visibility of the control + points themselves. Note that some of the control points are hidden by + the surface itself. + + NOTE: This example does NOT demonstrate the final NURBS API, it's currently + just a test for the internals... +-} + +import Control.Monad ( when ) +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import Foreign.Marshal ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { showPoints :: IORef Bool } + +makeState :: IO State +makeState = do + s <- newIORef False + return $ State { showPoints = s } + +-- The control points of the surface form a small hill and +-- range from -3 to +3 in x, y, and z. +ctlPoints :: [[Vertex3 GLfloat]] +ctlPoints = + [ [ Vertex3 (2 * u - 3) + (2 * v - 3) + (if (u == 1 || u ==2) && (v == 1 || v == 2) then 3 else -3) + | v <- [ 0 .. 3 ] ] + | u <- [ 0 .. 3 ]] + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + materialDiffuse Front $= Color4 0.7 0.7 0.7 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 100 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + autoNormal $= Enabled + normalize $= Enabled + +-------------------------------------------------------------------------------- + +display :: State -> DisplayCallback +display state = do + let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + rotate (330 :: GLfloat) (Vector3 1 0 0) + scale 0.5 0.5 (0.5 :: GLfloat) + + withNURBSObj () $ \nurbsObj -> do + setNURBSMode nurbsObj NURBSTessellator + setSamplingMethod nurbsObj (PathLength 25) + setDisplayMode' nurbsObj Fill' + checkForNURBSError nurbsObj $ + withNURBSBeginCallback nurbsObj print $ + withNURBSVertexCallback nurbsObj print $ + withNURBSNormalCallback nurbsObj print $ + withNURBSEndCallback nurbsObj (putStrLn "end") $ + nurbsBeginEndSurface nurbsObj $ + withArray (concat ctlPoints) $ \cBuf -> + withArray knots $ \kBuf -> + nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4 + + s <- get (showPoints state) + when s $ do + pointSize $= 5 + lighting $= Disabled + color (Color3 1 1 (0 :: GLfloat)) + renderPrimitive Points $ + mapM_ (mapM_ vertex) ctlPoints + lighting $= Enabled + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 45 (fromIntegral w / fromIntegral h) 3 8 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-5 :: GLfloat)) + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'c' -> do showPoints state $~ not; postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + version <- get (majorMinor gluVersion) + when (version < (1,3)) $ do + putStrLn "This program demonstrates a feature which is introduced in the" + putStrLn "OpenGL Utility Library (GLU) Version 1.3." + putStrLn "If your implementation of GLU has the right extensions," + putStrLn "you may be able to modify this program to make it run." + putStrLn "Continuing anyway..." + state <- makeState + myInit + reshapeCallback $= Just reshape + displayCallback $= display state + keyboardMouseCallback $= Just (keyboard state) + mainLoop diff --git a/examples/RedBook4/Surface.hs b/examples/RedBook4/Surface.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Surface.hs @@ -0,0 +1,112 @@ +{- + Surface.hs (adapted from surface.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws a NURBS surface in the shape of a symmetrical hill. + The 'c' keyboard key allows you to toggle the visibility of the control + points themselves. Note that some of the control points are hidden by + the surface itself. + + NOTE: This example does NOT demonstrate the final NURBS API, it's currently + just a test for the internals... +-} + +import Control.Monad ( when ) +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import Foreign.Marshal ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { showPoints :: IORef Bool } + +makeState :: IO State +makeState = do + s <- newIORef False + return $ State { showPoints = s } + +-- The control points of the surface form a small hill and +-- range from -3 to +3 in x, y, and z. +ctlPoints :: [[Vertex3 GLfloat]] +ctlPoints = + [ [ Vertex3 (2 * u - 3) + (2 * v - 3) + (if (u == 1 || u ==2) && (v == 1 || v == 2) then 3 else -3) + | v <- [ 0 .. 3 ] ] + | u <- [ 0 .. 3 ]] + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + materialDiffuse Front $= Color4 0.7 0.7 0.7 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 100 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + autoNormal $= Enabled + normalize $= Enabled + +-------------------------------------------------------------------------------- + +display :: State -> DisplayCallback +display state = do + let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + rotate (330 :: GLfloat) (Vector3 1 0 0) + scale 0.5 0.5 (0.5 :: GLfloat) + + withNURBSObj () $ \nurbsObj -> do + setSamplingMethod nurbsObj (PathLength 25) + setDisplayMode' nurbsObj Fill' + checkForNURBSError nurbsObj $ + nurbsBeginEndSurface nurbsObj $ + withArray (concat ctlPoints) $ \cBuf -> + withArray knots $ \kBuf -> + nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4 + + s <- get (showPoints state) + when s $ do + pointSize $= 5 + lighting $= Disabled + color (Color3 1 1 (0 :: GLfloat)) + renderPrimitive Points $ + mapM_ (mapM_ vertex) ctlPoints + lighting $= Enabled + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 45 (fromIntegral w / fromIntegral h) 3 8 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-5 :: GLfloat)) + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'c' -> do showPoints state $~ not; postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + state <- makeState + myInit + reshapeCallback $= Just reshape + displayCallback $= display state + keyboardMouseCallback $= Just (keyboard state) + mainLoop diff --git a/examples/RedBook4/Teapots.hs b/examples/RedBook4/Teapots.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Teapots.hs @@ -0,0 +1,226 @@ +{- + Teapots.hs (adapted from teapots.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates lots of material properties. A single light + source illuminates the objects. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Initialize depth buffer, projection matrix, light source, and lighting +-- model. Do not specify a material property here. +myInit :: IO DisplayList +myInit = do + ambient (Light 0) $= Color4 0 0 0 1 + diffuse (Light 0) $= Color4 1 1 1 1 + position (Light 0) $= Vertex4 0 3 3 0 + lightModelAmbient $= Color4 0.2 0.2 0.2 1 + lightModelLocalViewer $= Disabled + + frontFace $= CW + lighting $= Enabled + light (Light 0) $= Enabled + autoNormal $= Enabled + normalize $= Enabled + depthFunc $= Just Less + -- be efficient--make teapot display list + defineNewList Compile $ + renderObject Solid (Teapot 1) + +-- Move object into position, specify the material properties, draw a teapot. +renderTeapot :: DisplayList -> Vector3 GLfloat -> Color4 GLfloat + -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> IO () +renderTeapot teapotList pos amb dif spec shine = do + preservingMatrix $ do + translate pos + materialAmbient Front $= amb + materialDiffuse Front $= dif + materialSpecular Front $= spec + materialShininess Front $= shine * 128 + callList teapotList + +-- 1st column: emerald, jade, obsidian, pearl, ruby, turquoise +-- 2nd column: brass, bronze, chrome, copper, gold, silver +-- 3rd column: black, cyan, green, red, white, yellow plastic +-- 4th column: black, cyan, green, red, white, yellow rubber +display :: DisplayList -> DisplayCallback +display teapotList = do + clear [ ColorBuffer, DepthBuffer ] + renderTeapot teapotList + (Vector3 2 17 0) + (Color4 0.0215 0.1745 0.0215 1) + (Color4 0.07568 0.61424 0.07568 1) + (Color4 0.633 0.727811 0.633 1) + 0.6 + renderTeapot teapotList + (Vector3 2 14 0) + (Color4 0.135 0.2225 0.1575 1) + (Color4 0.54 0.89 0.63 1) + (Color4 0.316228 0.316228 0.316228 1) + 0.1 + renderTeapot teapotList + (Vector3 2 11 0) + (Color4 0.05375 0.05 0.06625 1) + (Color4 0.18275 0.17 0.22525 1) + (Color4 0.332741 0.328634 0.346435 1) + 0.3 + renderTeapot teapotList + (Vector3 2 8 0) + (Color4 0.25 0.20725 0.20725 1) + (Color4 1 0.829 0.829 1) + (Color4 0.296648 0.296648 0.296648 1) + 0.088 + renderTeapot teapotList + (Vector3 2 5 0) + (Color4 0.1745 0.01175 0.01175 1) + (Color4 0.61424 0.04136 0.04136 1) + (Color4 0.727811 0.626959 0.626959 1) + 0.6 + renderTeapot teapotList + (Vector3 2 2 0) + (Color4 0.1 0.18725 0.1745 1) + (Color4 0.396 0.74151 0.69102 1) + (Color4 0.297254 0.30829 0.306678 1) + 0.1 + renderTeapot teapotList + (Vector3 6 17 0) + (Color4 0.329412 0.223529 0.027451 1) + (Color4 0.780392 0.568627 0.113725 1) + (Color4 0.992157 0.941176 0.807843 1) + 0.21794872 + renderTeapot teapotList + (Vector3 6 14 0) + (Color4 0.2125 0.1275 0.054 1) + (Color4 0.714 0.4284 0.18144 1) + (Color4 0.393548 0.271906 0.166721 1) + 0.2 + renderTeapot teapotList + (Vector3 6 11 0) + (Color4 0.25 0.25 0.25 1) + (Color4 0.4 0.4 0.4 1) + (Color4 0.774597 0.774597 0.774597 1) + 0.6 + renderTeapot teapotList + (Vector3 6 8 0) + (Color4 0.19125 0.0735 0.0225 1) + (Color4 0.7038 0.27048 0.0828 1) + (Color4 0.256777 0.137622 0.086014 1) + 0.1 + renderTeapot teapotList + (Vector3 6 5 0) + (Color4 0.24725 0.1995 0.0745 1) + (Color4 0.75164 0.60648 0.22648 1) + (Color4 0.628281 0.555802 0.366065 1) + 0.4 + renderTeapot teapotList + (Vector3 6 2 0) + (Color4 0.19225 0.19225 0.19225 1) + (Color4 0.50754 0.50754 0.50754 1) + (Color4 0.508273 0.508273 0.508273 1) + 0.4 + renderTeapot teapotList + (Vector3 10 17 0) + (Color4 0 0 0 1) + (Color4 0.01 0.01 0.01 1) + (Color4 0.50 0.50 0.50 1) + 0.25 + renderTeapot teapotList + (Vector3 10 14 0) + (Color4 0 0.1 0.06 1) + (Color4 0 0.50980392 0.50980392 1) + (Color4 0.50196078 0.50196078 0.50196078 1) + 0.25 + renderTeapot teapotList + (Vector3 10 11 0) + (Color4 0 0 0 1) + (Color4 0.1 0.35 0.1 1) + (Color4 0.45 0.55 0.45 1) + 0.25 + renderTeapot teapotList + (Vector3 10 8 0) + (Color4 0 0 0 1) + (Color4 0.5 0 0 1) + (Color4 0.7 0.6 0.6 1) + 0.25 + renderTeapot teapotList + (Vector3 10 5 0) + (Color4 0 0 0 1) + (Color4 0.55 0.55 0.55 1) + (Color4 0.70 0.70 0.70 1) + 0.25 + renderTeapot teapotList + (Vector3 10 2 0) + (Color4 0 0 0 1) + (Color4 0.5 0.5 0 1) + (Color4 0.60 0.60 0.50 1) + 0.25 + renderTeapot teapotList + (Vector3 14 17 0) + (Color4 0.02 0.02 0.02 1) + (Color4 0.01 0.01 0.01 1) + (Color4 0.4 0.4 0.4 1) + 0.078125 + renderTeapot teapotList + (Vector3 14 14 0) + (Color4 0 0.05 0.05 1) + (Color4 0.4 0.5 0.5 1) + (Color4 0.04 0.7 0.7 1) + 0.078125 + renderTeapot teapotList + (Vector3 14 11 0) + (Color4 0 0.05 0 1) + (Color4 0.4 0.5 0.4 1) + (Color4 0.04 0.7 0.04 1) + 0.078125 + renderTeapot teapotList + (Vector3 14 8 0) + (Color4 0.05 0 0 1) + (Color4 0.5 0.4 0.4 1) + (Color4 0.7 0.04 0.04 1) + 0.078125 + renderTeapot teapotList + (Vector3 14 5 0) + (Color4 0.05 0.05 0.05 1) + (Color4 0.5 0.5 0.5 1) + (Color4 0.7 0.7 0.7 1) + 0.078125 + renderTeapot teapotList + (Vector3 14 2 0) + (Color4 0.05 0.05 0 1) + (Color4 0.5 0.5 0.4 1) + (Color4 0.7 0.7 0.04 1) + 0.078125 + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho 0 16 0 (16 * hf/wf) (-10) 10 + else ortho 0 (16 * wf/hf) 0 16 (-10) 10 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 600 + initialWindowPosition $= Position 50 50 + _ <- createWindow progName + teapotList <- myInit + reshapeCallback $= Just reshape + displayCallback $= display teapotList + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Tess.hs b/examples/RedBook4/Tess.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Tess.hs @@ -0,0 +1,117 @@ +{- + Tess.hs (adapted from tess.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates polygon tessellation. Two tesselated objects are + drawn. The first is a rectangle with a triangular hole. The second is a + smooth shaded, self-intersecting star. + + Note the exterior rectangle is drawn with its vertices in counter-clockwise + order, but its interior clockwise. Note the combineCallback is needed for the + self-intersecting star. Also note that removing the TessProperty for the + star will make the interior unshaded (TessWindingOdd). +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +display :: [DisplayList] -> DisplayCallback +display displayLists = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 1 1 1) + mapM_ callList displayLists + flush + +-- 'Float' is a dummy, any marshalable type would do +type DontCare = Float + +rectangle :: ComplexContour DontCare +rectangle = ComplexContour [ + AnnotatedVertex (Vertex3 50 50 0) 0, + AnnotatedVertex (Vertex3 200 50 0) 0, + AnnotatedVertex (Vertex3 200 200 0) 0, + AnnotatedVertex (Vertex3 50 200 0) 0 ] + +tri :: ComplexContour DontCare +tri = ComplexContour [ + AnnotatedVertex (Vertex3 75 75 0) 0, + AnnotatedVertex (Vertex3 125 175 0) 0, + AnnotatedVertex (Vertex3 175 75 0) 0 ] + +rectAndTri :: ComplexPolygon DontCare +rectAndTri = ComplexPolygon [ rectangle, tri ] + +noOpCombiner :: Combiner DontCare +noOpCombiner _newVertex _weightedProperties = 0 + +star :: ComplexPolygon (Color3 GLfloat) +star = ComplexPolygon [ + ComplexContour [ + AnnotatedVertex (Vertex3 250 50 0) (Color3 1 0 1), + AnnotatedVertex (Vertex3 325 200 0) (Color3 1 1 0), + AnnotatedVertex (Vertex3 400 50 0) (Color3 0 1 1), + AnnotatedVertex (Vertex3 250 150 0) (Color3 1 0 0), + AnnotatedVertex (Vertex3 400 150 0) (Color3 0 1 0) ] ] + +combineColors :: Combiner (Color3 GLfloat) +combineColors + _newVertex + (WeightedProperties + (w0, Color3 r0 g0 b0) + (w1, Color3 r1 g1 b1) + (w2, Color3 r2 g2 b2) + (w3, Color3 r3 g3 b3)) = + Color3 (w0*r0 + w1*r1 + w2*r2 + w3*r3) + (w0*g0 + w1*g1 + w2*g2 + w3*g3) + (w0*b0 + w1*b1 + w2*b2 + w3*b3) + +myInit :: IO [DisplayList] +myInit = do + clearColor $= Color4 0 0 0 0 + + rectAndTriList <- defineNewList Compile $ + drawSimplePolygon (\_ -> return ()) =<< + tessellate TessWindingOdd 0 (Normal3 0 0 0) noOpCombiner rectAndTri + + starList <- defineNewList Compile $ + drawSimplePolygon color =<< + tessellate TessWindingPositive 0 (Normal3 0 0 0) combineColors star + + return [ rectAndTriList, starList ] + +drawSimplePolygon :: (v -> IO ()) -> SimplePolygon v -> IO () +drawSimplePolygon colorHandler (SimplePolygon primitives) = + flip mapM_ primitives $ \(Primitive primitiveMode vertices) -> + renderPrimitive primitiveMode $ + flip mapM_ vertices $ \(AnnotatedVertex plainVertex col) -> do + colorHandler col + vertex plainVertex + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + _ <- createWindow progName + displayLists <- myInit + displayCallback $= display displayLists + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/TessWind.hs b/examples/RedBook4/TessWind.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/TessWind.hs @@ -0,0 +1,195 @@ +{- + TessWind.hs (adapted from tesswind.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the winding rule polygon tessellation property. + Four tessellated objects are drawn, each with very different contours. When + the w key is pressed, the objects are drawn with a different winding rule. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { currentWindingRule :: IORef TessWinding } + +makeState :: IO State +makeState = do + c <- newIORef TessWindingOdd + return $ State { currentWindingRule = c } + +type DisplayLists = (DisplayList, DisplayList, DisplayList, DisplayList) + +-- 'Float' is a dummy, any marshalable type would do +type DontCare = Float + +rect1 :: ComplexContour DontCare +rect1 = ComplexContour [ + AnnotatedVertex (Vertex3 50 50 0) 0, + AnnotatedVertex (Vertex3 300 50 0) 0, + AnnotatedVertex (Vertex3 300 300 0) 0, + AnnotatedVertex (Vertex3 50 300 0) 0 ] + +rect2 :: ComplexContour DontCare +rect2 = ComplexContour [ + AnnotatedVertex (Vertex3 100 100 0) 0, + AnnotatedVertex (Vertex3 250 100 0) 0, + AnnotatedVertex (Vertex3 250 250 0) 0, + AnnotatedVertex (Vertex3 100 250 0) 0 ] + +rect3 :: ComplexContour DontCare +rect3 = ComplexContour [ + AnnotatedVertex (Vertex3 150 150 0) 0, + AnnotatedVertex (Vertex3 200 150 0) 0, + AnnotatedVertex (Vertex3 200 200 0) 0, + AnnotatedVertex (Vertex3 150 200 0) 0 ] + +rects1 :: ComplexPolygon DontCare +rects1 = ComplexPolygon [ rect1, rect2, rect3 ] + +rects2 :: ComplexPolygon DontCare +rects2 = ComplexPolygon [ + rect1, reverseComplexContour rect2, reverseComplexContour rect3 ] + +spiral :: ComplexPolygon DontCare +spiral = ComplexPolygon [ + ComplexContour [ + AnnotatedVertex (Vertex3 400 250 0) 0, + AnnotatedVertex (Vertex3 400 50 0) 0, + AnnotatedVertex (Vertex3 50 50 0) 0, + AnnotatedVertex (Vertex3 50 400 0) 0, + AnnotatedVertex (Vertex3 350 400 0) 0, + AnnotatedVertex (Vertex3 350 100 0) 0, + AnnotatedVertex (Vertex3 100 100 0) 0, + AnnotatedVertex (Vertex3 100 350 0) 0, + AnnotatedVertex (Vertex3 300 350 0) 0, + AnnotatedVertex (Vertex3 300 150 0) 0, + AnnotatedVertex (Vertex3 150 150 0) 0, + AnnotatedVertex (Vertex3 150 300 0) 0, + AnnotatedVertex (Vertex3 250 300 0) 0, + AnnotatedVertex (Vertex3 250 200 0) 0, + AnnotatedVertex (Vertex3 200 200 0) 0, + AnnotatedVertex (Vertex3 200 250 0) 0 ] ] + +quad1 :: ComplexContour DontCare +quad1 = ComplexContour [ + AnnotatedVertex (Vertex3 50 150 0) 0, + AnnotatedVertex (Vertex3 350 150 0) 0, + AnnotatedVertex (Vertex3 350 200 0) 0, + AnnotatedVertex (Vertex3 50 200 0) 0 ] + +quad2 :: ComplexContour DontCare +quad2 = ComplexContour [ + AnnotatedVertex (Vertex3 100 100 0) 0, + AnnotatedVertex (Vertex3 300 100 0) 0, + AnnotatedVertex (Vertex3 300 350 0) 0, + AnnotatedVertex (Vertex3 100 350 0) 0 ] + +tri :: ComplexContour DontCare +tri = ComplexContour [ + AnnotatedVertex (Vertex3 200 50 0) 0, + AnnotatedVertex (Vertex3 250 300 0) 0, + AnnotatedVertex (Vertex3 150 300 0) 0 ] + +quadsAndTri :: ComplexPolygon DontCare +quadsAndTri = ComplexPolygon [ quad1, quad2, tri ] + +reverseComplexContour :: ComplexContour DontCare -> ComplexContour DontCare +reverseComplexContour (ComplexContour avs) = ComplexContour (reverse avs) + +makeNewLists :: State -> DisplayLists -> IO () +makeNewLists state (dl1, dl2, dl3, dl4) = do + windingRule <- get (currentWindingRule state) + print windingRule -- not in original program, but useful + compileList windingRule dl1 rects1 + compileList windingRule dl2 rects2 + compileList windingRule dl3 spiral + compileList windingRule dl4 quadsAndTri + +compileList :: TessWinding -> DisplayList -> ComplexPolygon DontCare -> IO () +compileList windingRule displayList complexPolygon = + defineList displayList Compile $ + drawSimplePolygon =<< + tessellate windingRule 0 (Normal3 0 0 0) noOpCombiner complexPolygon + +noOpCombiner :: Combiner DontCare +noOpCombiner _newVertex _weightedProperties = 0 + +drawSimplePolygon :: SimplePolygon DontCare -> IO () +drawSimplePolygon (SimplePolygon primitives) = + flip mapM_ primitives $ \(Primitive primitiveMode vertices) -> + renderPrimitive primitiveMode $ + flip mapM_ vertices $ \(AnnotatedVertex plainVertex _) -> + vertex plainVertex + +display :: DisplayLists -> DisplayCallback +display (dl1, dl2, dl3, dl4) = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + color3f (Color3 1 1 1) + preservingMatrix $ do + callList dl1 + translatef (Vector3 0 500 0) + callList dl2 + translatef (Vector3 500 (-500) 0) + callList dl3 + translatef (Vector3 0 500 0) + callList dl4 + flush + +myInit :: State -> IO DisplayLists +myInit state = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + [dl1, dl2, dl3, dl4] <- genObjectNames 4 + let displayLists = (dl1, dl2, dl3, dl4) + makeNewLists state displayLists + return displayLists + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D 0 1000 0 (1000 * hf/wf) + else ortho2D 0 (1000 * wf/hf) 0 1000 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: State -> DisplayLists -> KeyboardMouseCallback +keyboard state displayLists (Char c) Down _ _ = case toLower c of + 'w' -> do currentWindingRule state $~ nextWindingRule + makeNewLists state displayLists + postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ _ = return () + +nextWindingRule :: TessWinding -> TessWinding +nextWindingRule r = case r of + TessWindingOdd -> TessWindingNonzero + TessWindingNonzero -> TessWindingPositive + TessWindingPositive -> TessWindingNegative + TessWindingNegative -> TessWindingAbsGeqTwo + TessWindingAbsGeqTwo -> TessWindingOdd + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + _ <- createWindow progName + state <- makeState + displayLists <- myInit state + displayCallback $= display displayLists + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state displayLists) + mainLoop diff --git a/examples/RedBook4/TexBind.hs b/examples/RedBook4/TexBind.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/TexBind.hs @@ -0,0 +1,108 @@ +{- + TexBind.hs (adapted from texbind.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates using textureBinding by creating and managing + two textures. +-} + +import Control.Monad ( when ) +import Data.Bits ( (.&.) ) +import Foreign ( withArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Create checkerboard image +checkImageSize :: TextureSize2D +checkImageSize = TextureSize2D 64 64 + +withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) + -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () +withCheckImage (TextureSize2D w h) n f act = + withArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] $ + act . PixelData RGBA UnsignedByte + +myInit :: IO (TextureObject, TextureObject) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + rowAlignment Unpack $= 1 + + [texName0, texName1] <- genObjectNames 2 + textureBinding Texture2D $= Just texName0 + textureWrapMode Texture2D S $= (Repeated, Clamp) + textureWrapMode Texture2D T $= (Repeated, Clamp) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + withCheckImage checkImageSize 0x08 (\c -> Color4 c c c 255) $ + texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 + + textureBinding Texture2D $= Just texName1 + textureWrapMode Texture2D S $= (Repeated, Clamp) + textureWrapMode Texture2D T $= (Repeated, Clamp) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + textureFunction $= Decal + withCheckImage checkImageSize 0x10 (\c -> Color4 c 0 0 255) $ + texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 + texture Texture2D $= Enabled + return (texName0, texName1) + +display :: (TextureObject, TextureObject) -> DisplayCallback +display (texName0, texName1) = do + clear [ ColorBuffer, DepthBuffer ] + -- resolve overloading, not needed in "real" programs + let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + textureBinding Texture2D $= Just texName0 + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) + textureBinding Texture2D $= Just texName1 + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-3.6 :: GLfloat)) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + version <- get (majorMinor glVersion) + when (version == (1,0)) $ do + putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." + putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," + putStrLn "you may be able to modify this program to make it run." + exitFailure + texNames <- myInit + reshapeCallback $= Just reshape + displayCallback $= display texNames + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/TexGen.hs b/examples/RedBook4/TexGen.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/TexGen.hs @@ -0,0 +1,132 @@ +{- + TexGen.hs (adapted from texgen.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws a texture mapped teapot with automatically generated + texture coordinates. The texture is rendered as stripes on the teapot. + Initially, the object is drawn with texture coordinates based upon the + object coordinates of the vertex and distance from the plane x = 0. + Pressing the 'e' key changes the coordinate generation to eye coordinates + of the vertex. Pressing the 'o' key switches it back to the object + coordinates. Pressing the 's' key changes the plane to a slanted one + (x + y + z = 0). Pressing the 'x' key switches it back to x = 0. +-} + +import Control.Monad ( when ) +import Data.Char ( toLower ) +import Data.Maybe ( isJust ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +stripeImageWidth :: TextureSize1D +stripeImageWidth = TextureSize1D 32 + +xEqualZero, slanted :: Plane GLdouble +xEqualZero = Plane 1 0 0 0 +slanted = Plane 1 1 1 0 + +withStripeImage :: (PixelData (Color4 GLubyte) -> IO a) -> IO a +withStripeImage act = + withArray [ Color4 (if j <= 4 then 255 else 0) + (if j > 4 then 255 else 0) + 0 + 255 + | j <- [ 0 .. w - 1 ] ] $ + act . PixelData RGBA UnsignedByte + where TextureSize1D w = stripeImageWidth + +myInit :: IO (Maybe TextureObject) +myInit = do + clearColor $= Color4 0 0 0 0 + depthFunc $= Just Less + shadeModel $= Smooth + rowAlignment Unpack $= 1 + + exts <- get glExtensions + mbTexName <- if "GL_EXT_texture_object" `elem` exts + then fmap Just genObjectName + else return Nothing + when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName + + textureWrapMode Texture1D S $= (Repeated, Repeat) + textureFilter Texture1D $= ((Linear', Nothing), Linear') + withStripeImage $ texImage1D Texture1D NoProxy 0 RGBA' stripeImageWidth 0 + + textureFunction $= Modulate + textureGenMode S $= Just (ObjectLinear xEqualZero) + + texture Texture1D $= Enabled + lighting $= Enabled + light (Light 0) $= Enabled + autoNormal $= Enabled + normalize $= Enabled + frontFace $= CW + cullFace $= Just Back + materialShininess Front $= 64 + return mbTexName + +display :: Maybe TextureObject -> DisplayCallback +display mbTexName = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + rotate (45 :: GLfloat) (Vector3 0 0 1) + when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName + renderObject Solid (Teapot 2) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-3.5) 3.5 (-3.5*hf/wf) (3.5*hf/wf) (-3.5) 3.5 + else ortho (-3.5*wf/hf) (3.5*wf/hf) (-3.5) 3.5 (-3.5) 3.5 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char c) Down _ _ = case toLower c of + 'e' -> setGenMode EyeLinear + 'o' -> setGenMode ObjectLinear + 's' -> setPlane slanted + 'x' -> setPlane xEqualZero + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ = return () + +setGenMode :: (Plane GLdouble -> TextureGenMode) -> IO () +setGenMode mode = do + currentGenMode <- get (textureGenMode S) + case currentGenMode of + Just (EyeLinear plane) -> textureGenMode S $= Just (mode plane) + Just (ObjectLinear plane) -> textureGenMode S $= Just (mode plane) + _ -> error "setGenMode: should never happen..." + postRedisplay Nothing + +setPlane :: Plane GLdouble -> IO () +setPlane plane = do + currentGenMode <- get (textureGenMode S) + case currentGenMode of + Just (EyeLinear _) -> textureGenMode S $= Just (EyeLinear plane) + Just (ObjectLinear _) -> textureGenMode S $= Just (ObjectLinear plane) + _ -> error "setPlane: should never happen..." + postRedisplay Nothing + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 256 256 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + mbTexName <- myInit + displayCallback $= display mbTexName + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/TexProx.hs b/examples/RedBook4/TexProx.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/TexProx.hs @@ -0,0 +1,58 @@ +{- + TexProx.hs (adapted from texprox.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + The brief program illustrates use of texture proxies. This program only + prints out some messages about whether certain size textures are supported + and then exits. +-} + +import Control.Monad ( when ) +import Foreign.Ptr ( nullPtr ) +import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + let check = do + ok <- get (textureProxyOK Texture2D 0) + putStrLn ("proxy allocation " ++ if ok then "succeeded" else "failed") + + texImage2D Texture2D Proxy 0 RGBA8 (TextureSize2D 64 64) 0 (PixelData RGBA UnsignedByte nullPtr) + check + + -- Note: We use a larger texture size here to demonstrate failure, + -- modern graphic cards can handle the original size. + texImage2D Texture2D Proxy 0 RGBA16 (TextureSize2D 8192 8192) 0 (PixelData RGBA UnsignedShort nullPtr) + check + + +display :: DisplayCallback +display = exitWith ExitSuccess + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + version <- get (majorMinor glVersion) + when (version == (1,0)) $ do + putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." + putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," + putStrLn "you may be able to modify this program to make it run." + exitFailure + myInit + displayCallback $= display + reshapeCallback $= Just reshape + mainLoop diff --git a/examples/RedBook4/TexSub.hs b/examples/RedBook4/TexSub.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/TexSub.hs @@ -0,0 +1,120 @@ +{- + TexSub.hs (adapted from texsub.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program texture maps a checkerboard image onto two rectangles. This + program clamps the texture, if the texture coordinates fall outside 0.0 + and 1.0. If the s key is pressed, a texture subimage is used to alter the + original texture. If the r key is pressed, the original texture is restored. +-} + +import Control.Monad ( when ) +import Data.Char ( toLower ) +import Data.Bits ( (.&.) ) +import Foreign ( newArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +checkImageSize, subImageSize :: TextureSize2D +checkImageSize = TextureSize2D 64 64 +subImageSize = TextureSize2D 16 16 + +type Image = PixelData (Color4 GLubyte) + +makeCheckImage :: + TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) -> IO Image +makeCheckImage (TextureSize2D w h) n f = + fmap (PixelData RGBA UnsignedByte) $ + newArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] + +myInit :: IO (TextureObject, Image, Image) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + + checkImage <- makeCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) + subImage <- makeCheckImage subImageSize 0x4 (\c -> Color4 c 0 0 255) + rowAlignment Unpack $= 1 + + texName <- genObjectName + textureBinding Texture2D $= Just texName + + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 checkImage + return (texName, checkImage, subImage) + +display :: TextureObject -> DisplayCallback +display texName = do + clear [ ColorBuffer, DepthBuffer ] + texture Texture2D $= Enabled + textureFunction $= Decal + textureBinding Texture2D $= Just texName + + -- resolve overloading, not needed in "real" programs + let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) + + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) + flush + texture Texture2D $= Disabled + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-3.6 :: GLfloat)) + +keyboard :: TextureObject -> Image -> Image -> KeyboardMouseCallback +keyboard texName checkImage subImage (Char c) Down _ _ = case toLower c of + 's' -> do + textureBinding Texture2D $= Just texName + texSubImage2D Texture2D 0 (TexturePosition2D 12 44) subImageSize subImage + postRedisplay Nothing + 'r' -> do + textureBinding Texture2D $= Just texName + texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 checkImage + postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + version <- get (majorMinor glVersion) + when (version == (1,0)) $ do + putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." + putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," + putStrLn "you may be able to modify this program to make it run." + exitFailure + (texName, checkImage, subImage) <- myInit + displayCallback $= display texName + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard texName checkImage subImage) + mainLoop diff --git a/examples/RedBook4/Texture3D.hs b/examples/RedBook4/Texture3D.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Texture3D.hs @@ -0,0 +1,94 @@ +{- + Texture3D.hs (adapted from texture3d.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates using a three-dimensional texture. It creates + a 3D texture and then renders two rectangles with different texture + coordinates to obtain different "slices" of the 3D texture. +-} + +import Control.Monad ( unless ) +import Foreign ( withArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Create checkerboard image +imageSize :: TextureSize3D +imageSize = TextureSize3D 16 16 16 + +withImage :: (PixelData (Color3 GLubyte) -> IO ()) -> IO () +withImage act = + withArray [ Color3 (s * 17) (t * 17) (r * 17) | + r <- [ 0 .. fromIntegral d - 1 ], + t <- [ 0 .. fromIntegral h - 1 ], + s <- [ 0 .. fromIntegral w - 1 ] ] $ + act . PixelData RGB UnsignedByte + where (TextureSize3D w h d) = imageSize + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + rowAlignment Unpack $= 1 + + texName <- genObjectName + textureBinding Texture3D $= Just texName + textureWrapMode Texture3D S $= (Repeated, Clamp) + textureWrapMode Texture3D T $= (Repeated, Clamp) + textureWrapMode Texture3D R $= (Repeated, Clamp) + textureFilter Texture3D $= ((Nearest, Nothing), Nearest) + withImage $ texImage3D Texture3D NoProxy 0 RGB' imageSize 0 + texture Texture3D $= Enabled + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + -- resolve overloading, not needed in "real" programs + let texCoord3f = texCoord :: TexCoord3 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Quads $ do + texCoord3f (TexCoord3 0 0 0); vertex3f (Vertex3 (-2.25) (-1) 0) + texCoord3f (TexCoord3 0 1 0); vertex3f (Vertex3 (-2.25) 1 0) + texCoord3f (TexCoord3 1 1 1); vertex3f (Vertex3 (-0.25) 1 0) + texCoord3f (TexCoord3 1 0 1); vertex3f (Vertex3 (-0.25) (-1) 0) + + texCoord3f (TexCoord3 0 0 1); vertex3f (Vertex3 0.25 (-1) 0) + texCoord3f (TexCoord3 0 1 1); vertex3f (Vertex3 0.25 1 0) + texCoord3f (TexCoord3 1 1 0); vertex3f (Vertex3 2.25 1 0) + texCoord3f (TexCoord3 1 0 0); vertex3f (Vertex3 2.25 (-1) 0) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-4 :: GLfloat)) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + exts <- get glExtensions + unless ("GL_EXT_texture3D" `elem` exts) $ do + putStrLn "Sorry, this demo requires the GL_EXT_texture3D extension." + exitFailure + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/TextureSurf.hs b/examples/RedBook4/TextureSurf.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/TextureSurf.hs @@ -0,0 +1,99 @@ +{- + TextureSurf.hs (adapted from texturesurf.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program uses evaluators to generate a curved surface and automatically + generated texture coordinates. +-} + +import Data.List ( transpose ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +ctrlPoints :: [[Vertex3 GLfloat]] +ctrlPoints = [ + [ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0, + Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ], + [ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0, + Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ], + [ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0, + Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ], + [ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0), + Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]] + +texPts :: [[TexCoord2 GLfloat]] +texPts = [ + [ TexCoord2 0 0, TexCoord2 0 1 ], + [ TexCoord2 1 0, TexCoord2 1 1 ]] + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + color (Color3 1 1 1 :: Color3 GLfloat) + evalMesh2 Fill (0, 20) (0, 20) + flush + +imageSize :: TextureSize2D +imageSize = TextureSize2D 64 64 + +withImage :: (PixelData (Color3 GLubyte) -> IO ()) -> IO () +withImage act = + withArray [ Color3 (s (sin ti)) (s (cos (2 * tj))) (s (cos (ti + tj))) | + i <- [ 0 .. fromIntegral w - 1 ], + let ti = 2 * pi * i / fromIntegral w, + j <- [ 0 .. fromIntegral h - 1 ], + let tj = 2 * pi * j / fromIntegral h ] $ + act . PixelData RGB UnsignedByte + where (TextureSize2D w h) = imageSize + s :: Double -> GLubyte + s x = truncate (127 * (1 + x)) + +myInit :: IO () +myInit = do + m <- newMap2 (0, 1) (0, 1) (transpose ctrlPoints) + map2 $= Just (m :: GLmap2 Vertex3 GLfloat) + t <- newMap2 (0, 1) (0, 1) (transpose texPts) + map2 $= Just (t :: GLmap2 TexCoord2 GLfloat) + mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat))) + textureFunction $= Decal + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + withImage $ texImage2D Texture2D NoProxy 0 RGB' imageSize 0 + texture Texture2D $= Enabled + depthFunc $= Just Less + shadeModel $= Flat + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0 + else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0 + matrixMode $= Modelview 0 + loadIdentity + rotate (85 :: GLfloat) (Vector3 1 1 1) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/Torus.hs b/examples/RedBook4/Torus.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Torus.hs @@ -0,0 +1,93 @@ +{- + Torus.hs (adapted from torus.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the creation of a display list. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { spinX, spinY :: IORef GLfloat } + +makeState :: IO State +makeState = do + x <- newIORef 0 + y <- newIORef 0 + return $ State { spinX = x, spinY = y } + +torus :: Int -> Int -> IO () +torus numC numT = do + let stepC = 2 * pi / fromIntegral numC :: GLfloat + stepT = 2 * pi / fromIntegral numT + flip mapM_ [ 0 .. numC - 1 ] $ \i -> + renderPrimitive QuadStrip $ + flip mapM_ [ 0 .. numT ] $ \j -> + flip mapM_ [ 1, 0 ] $ \k -> do + let s = (fromIntegral ((i + k) `mod` numC) + 0.5) * stepC + t = (fromIntegral ( j `mod` numT) ) * stepT + x = (1 + 0.1 * cos s) * cos t + y = (1 + 0.1 * cos s) * sin t + z = 0.1 * sin s + vertex (Vertex3 x y z) + +myInit :: IO DisplayList +myInit = do + theTorus <- defineNewList Compile $ + torus 8 25 + shadeModel $= Flat + clearColor $= Color4 0 0 0 0 + return theTorus + +display :: State -> DisplayList -> DisplayCallback +display state theTorus = do + clear [ ColorBuffer ] + loadIdentity + lookAt (Vertex3 0 0 10) (Vertex3 0 0 0) (Vector3 0 1 0) + x <- get (spinX state) + rotate x (Vector3 1 0 0) + y <- get (spinY state) + rotate y (Vector3 0 1 0) + color (Color3 1 1 (1 :: GLfloat)) + callList theTorus + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 30 (fromIntegral w / fromIntegral h) 1 100 + matrixMode $= Modelview 0 + +incSpin :: IORef GLfloat -> IO () +incSpin spinRef = do + let wrap n s = if s > n then s - n else s + spinRef $~ (wrap 360 . (+ 30)) + postRedisplay Nothing + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'x' -> incSpin (spinX state) + 'y' -> incSpin (spinY state) + 'i' -> do spinX state $= 0; spinY state $= 0; postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 200 200 + _ <- createWindow progName + state <- makeState + theTorus <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state theTorus + mainLoop diff --git a/examples/RedBook4/Trim.hs b/examples/RedBook4/Trim.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Trim.hs @@ -0,0 +1,107 @@ +{- + Trim.hs (adapted from trim.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws a NURBS surface in the shape of a symmetrical hill, + using both a NURBS curve and pwl (piecewise linear) curve to trim part + of the surface. + + NOTE: This example does NOT demonstrate the final NURBS API, it's currently + just a test for the internals... +-} + +import Foreign.Marshal ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- The control points of the surface form a small hill and +-- range from -3 to +3 in x, y, and z. +ctlPoints :: [[Vertex3 GLfloat]] +ctlPoints = + [ [ Vertex3 (2 * u - 3) + (2 * v - 3) + (if (u == 1 || u ==2) && (v == 1 || v == 2) then 3 else -3) + | v <- [ 0 .. 3 ] ] + | u <- [ 0 .. 3 ]] + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + materialDiffuse Front $= Color4 0.7 0.7 0.7 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 100 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + autoNormal $= Enabled + normalize $= Enabled + +-------------------------------------------------------------------------------- + +display :: DisplayCallback +display = do + let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] + edgePt = -- counter clockwise + [ Vertex2 0 0, Vertex2 1 0, Vertex2 1 1, Vertex2 0 1, Vertex2 0 0 ] :: [Vertex2 GLfloat] + curvePt = -- clockwise + [ Vertex2 0.25 0.5, Vertex2 0.25 0.75, Vertex2 0.75 0.75, Vertex2 0.75 0.5 ] :: [Vertex2 GLfloat] + curveKnots = + [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] + pwlPt = -- clockwise + [Vertex2 0.75 0.5, Vertex2 0.5 0.25, Vertex2 0.25 0.5 ] :: [Vertex2 GLfloat] + + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + rotate (330 :: GLfloat) (Vector3 1 0 0) + scale 0.5 0.5 (0.5 :: GLfloat) + + withNURBSObj () $ \nurbsObj -> do + setSamplingMethod nurbsObj (PathLength 25) + setDisplayMode' nurbsObj Fill' + checkForNURBSError nurbsObj $ + nurbsBeginEndSurface nurbsObj $ + withArray (concat ctlPoints) $ \cBuf -> + withArray knots $ \kBuf -> do + nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4 + nurbsBeginEndTrim nurbsObj $ + withArray edgePt $ \edgePtBuf -> + pwlCurve nurbsObj 5 edgePtBuf 2 + nurbsBeginEndTrim nurbsObj $ do + withArray curveKnots $ \curveKnotsBuf -> + withArray curvePt $ \curvePtBuf -> + trimmingCurve nurbsObj 8 curveKnotsBuf 2 curvePtBuf 4 + withArray pwlPt $ \pwlPtBuf -> + pwlCurve nurbsObj 3 pwlPtBuf 2 + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 45 (fromIntegral w / fromIntegral h) 3 8 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-5 :: GLfloat)) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook4/UnProject.hs b/examples/RedBook4/UnProject.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/UnProject.hs @@ -0,0 +1,54 @@ +{- + UnProject.hs (adapted from unproject.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + When the left mouse button is pressed, this program reads the mouse + position and determines two 3D points from which it was transformed. + Very little is displayed. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 45 (fromIntegral w / fromIntegral h) 1 100 + matrixMode $= Modelview 0 + loadIdentity + +keyboardMouse :: KeyboardMouseCallback +keyboardMouse (MouseButton LeftButton) Down _ (Position x y) = do + v@(_, Size _ h) <- get viewport + mvMatrix <- get (matrix (Just (Modelview 0))) :: IO (GLmatrix GLdouble) + projMatrix <- get (matrix (Just Projection)) :: IO (GLmatrix GLdouble) + let realY = fromIntegral h - y -1 + putStrLn ("Coordinates at cursor are (" ++ show x ++", " ++ show realY ++ ")") + w0 <- unProject (Vertex3 (fromIntegral x) (fromIntegral realY) 0) mvMatrix projMatrix v + putStrLn ("World coords at z=0.0 are " ++ show w0) + w1 <- unProject (Vertex3 (fromIntegral x) (fromIntegral realY) 1) mvMatrix projMatrix v + putStrLn ("World coords at z=1.0 are " ++ show w1) +keyboardMouse (MouseButton RightButton) Down _ _ = exitWith ExitSuccess +keyboardMouse (Char '\27') Down _ _ = exitWith ExitSuccess +keyboardMouse _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboardMouse + mainLoop diff --git a/examples/RedBook4/VArray.hs b/examples/RedBook4/VArray.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/VArray.hs @@ -0,0 +1,141 @@ +{- + VArray.hs (adapted from varray.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates vertex arrays. +-} + +import Control.Monad ( when ) +import Data.IORef ( IORef, newIORef ) +import Foreign ( Ptr, newArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(..) ) +import Graphics.UI.GLUT + +data SetupMethod = Pointer | Interleaved + deriving ( Eq, Bounded, Enum ) + +data DerefMethod = DrawArray | ArrayElement | DrawElements + deriving ( Eq, Bounded, Enum ) + +makeVertices :: IO (Ptr (Vertex2 GLint)) +makeVertices = newArray [ + Vertex2 25 25, + Vertex2 100 325, + Vertex2 175 25, + Vertex2 175 325, + Vertex2 250 25, + Vertex2 325 325 ] + +makeColors :: IO (Ptr (Color3 GLfloat)) +makeColors = newArray [ + Color3 1.0 0.2 0.2, + Color3 0.2 0.2 1.0, + Color3 0.8 1.0 0.2, + Color3 0.75 0.75 0.75, + Color3 0.35 0.35 0.35, + Color3 0.5 0.5 0.5 ] + +makeIntertwined :: IO (Ptr GLfloat) +makeIntertwined = newArray [ + 1.0, 0.2, 1.0, 100.0, 100.0, 0.0, + 1.0, 0.2, 0.2, 0.0, 200.0, 0.0, + 1.0, 1.0, 0.2, 100.0, 300.0, 0.0, + 0.2, 1.0, 0.2, 200.0, 300.0, 0.0, + 0.2, 1.0, 1.0, 300.0, 200.0, 0.0, + 0.2, 0.2, 1.0, 200.0, 100.0, 0.0 ] + +makeIndices :: IO (Ptr GLuint) +makeIndices = newArray [ 0, 1, 3, 4 ] + +data State = State { + vertices :: Ptr (Vertex2 GLint), + colors :: Ptr (Color3 GLfloat), + intertwined :: Ptr GLfloat, + indices :: Ptr GLuint, + setupMethod :: IORef SetupMethod, + derefMethod :: IORef DerefMethod } + +makeState :: IO State +makeState = do + v <- makeVertices + c <- makeColors + i <- makeIntertwined + n <- makeIndices + s <- newIORef Pointer + d <- newIORef DrawArray + return $ State { vertices = v, colors = c, intertwined = i, + indices = n, setupMethod = s, derefMethod = d } + +setup :: State -> IO () +setup state = do + s <- get (setupMethod state) + case s of + Pointer -> do + clientState VertexArray $= Enabled + clientState ColorArray $= Enabled + arrayPointer VertexArray $= VertexArrayDescriptor 2 Int 0 (vertices state) + arrayPointer ColorArray $= VertexArrayDescriptor 3 Float 0 (colors state) + Interleaved -> + interleavedArrays C3fV3f 0 (intertwined state) + +myInit :: State -> IO () +myInit state = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + setup state + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + d <- get (derefMethod state) + case d of + DrawArray -> drawArrays Triangles 0 6 + ArrayElement -> renderPrimitive Triangles $ mapM_ arrayElement [ 2, 3, 5 ] + DrawElements -> drawElements Polygon 4 UnsignedInt (indices state) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + -- the following line is not in the original example, but it's good style... + matrixMode $= Modelview 0 + +keyboardMouse :: State -> KeyboardMouseCallback +keyboardMouse state (MouseButton LeftButton) Down _ _ = do + setupMethod state $~ nextValue + setup state + postRedisplay Nothing +keyboardMouse state (MouseButton _) Down _ _ = do + derefMethod state $~ nextValue + postRedisplay Nothing +keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboardMouse _ _ _ _ _ = return () + +nextValue :: (Eq a, Bounded a, Enum a) => a -> a +nextValue x = if x == maxBound then minBound else succ x + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 350 350 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + version <- get (majorMinor glVersion) + when (version == (1,0)) $ do + putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." + putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," + putStrLn "you may be able to modify this program to make it run." + exitFailure + state <- makeState + myInit state + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboardMouse state) + mainLoop diff --git a/examples/RedBook4/Wrap.hs b/examples/RedBook4/Wrap.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook4/Wrap.hs @@ -0,0 +1,114 @@ +{- + Wrap.hs (adapted from wrap.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program texture maps a checkerboard image onto two rectangles. This + program demonstrates the wrapping modes, if the texture coordinates fall + outside 0.0 and 1.0. Interaction: Pressing the 's' and 'S' keys switch the + wrapping between clamping and repeating for the s parameter. The 't' and 'T' + keys control the wrapping for the t parameter. + + Texture objects are only used when GL_EXT_texture_object is supported. +-} + +import Control.Monad ( when ) +import Data.Maybe ( isJust ) +import Data.Bits ( (.&.) ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Create checkerboard image +checkImageSize :: TextureSize2D +checkImageSize = TextureSize2D 64 64 + +withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) + -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () +withCheckImage (TextureSize2D w h) n f act = + withArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] $ + act. PixelData RGBA UnsignedByte + +myInit :: IO (Maybe TextureObject) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + rowAlignment Unpack $= 1 + + exts <- get glExtensions + mbTexName <- if "GL_EXT_texture_object" `elem` exts + then fmap Just genObjectName + else return Nothing + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + withCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) $ + texImage2D Texture2D NoProxy 0 RGBA' checkImageSize 0 + return mbTexName + +display :: Maybe TextureObject -> DisplayCallback +display mbTexName = do + clear [ ColorBuffer, DepthBuffer ] + texture Texture2D $= Enabled + textureFunction $= Decal + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + + -- resolve overloading, not needed in "real" programs + let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 3); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) + texCoord2f (TexCoord2 3 3); vertex3f (Vertex3 0.0 1.0 0.0 ) + texCoord2f (TexCoord2 3 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) + + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 3); vertex3f (Vertex3 1.0 1.0 0.0 ) + texCoord2f (TexCoord2 3 3); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) + texCoord2f (TexCoord2 3 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) + flush + texture Texture2D $= Disabled + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-3.6 :: GLfloat)) + +keyboard :: KeyboardMouseCallback +keyboard (Char 's' ) Down _ _ = setClamping S Clamp +keyboard (Char 'S' ) Down _ _ = setClamping S Repeat +keyboard (Char 't' ) Down _ _ = setClamping T Clamp +keyboard (Char 'T' ) Down _ _ = setClamping T Repeat +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +setClamping :: TextureCoordName -> Clamping -> IO () +setClamping coord clamp = do + textureWrapMode Texture2D coord $= (Repeated, clamp); + postRedisplay Nothing + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + _ <- createWindow progName + mbTexName <- myInit + displayCallback $= display mbTexName + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook8/00-README b/examples/RedBook8/00-README new file mode 100644 --- /dev/null +++ b/examples/RedBook8/00-README @@ -0,0 +1,3 @@ +This directory contains various examples from the book "OpenGL Programming +Guide: The Official Guide to Learning OpenGL, Version 4.3", 8th ed., by +Shreiner/Sellers/Kessenich/Licea-Kane. diff --git a/examples/RedBook8/Chapter01/Triangles.hs b/examples/RedBook8/Chapter01/Triangles.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook8/Chapter01/Triangles.hs @@ -0,0 +1,76 @@ +{- + Triangles.hs (adapted from triangles.cpp which is (c) The Red Book Authors.) + Copyright (c) Sven Panne 2018 + This file is part of HOpenGL and distributed under a BSD-style license + See the file GLUT/LICENSE + + Our first OpenGL program. +-} + +import Control.Monad +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable +import Graphics.UI.GLUT +import Prelude hiding ( init ) +import LoadShaders + +bufferOffset :: Integral a => a -> Ptr b +bufferOffset = plusPtr nullPtr . fromIntegral + +data Descriptor = Descriptor VertexArrayObject ArrayIndex NumArrayIndices + +init :: IO Descriptor +init = do + triangles <- genObjectName + bindVertexArrayObject $= Just triangles + + let vertices = [ + Vertex2 (-0.90) (-0.90), -- Triangle 1 + Vertex2 0.85 (-0.90), + Vertex2 (-0.90) 0.85 , + Vertex2 0.90 (-0.85), -- Triangle 2 + Vertex2 0.90 0.90 , + Vertex2 (-0.85) 0.90 ] :: [Vertex2 GLfloat] + numVertices = length vertices + vertexSize = sizeOf (head vertices) + + arrayBuffer <- genObjectName + bindBuffer ArrayBuffer $= Just arrayBuffer + withArray vertices $ \ptr -> do + let size = fromIntegral (numVertices * vertexSize) + bufferData ArrayBuffer $= (size, ptr, StaticDraw) + + program <- loadShaders [ + ShaderInfo VertexShader (FileSource "triangles.vert"), + ShaderInfo FragmentShader (FileSource "triangles.frag")] + currentProgram $= Just program + + let firstIndex = 0 + vPosition = AttribLocation 0 + vertexAttribPointer vPosition $= + (ToFloat, + VertexArrayDescriptor 2 Float 0 (bufferOffset (firstIndex * vertexSize))) + vertexAttribArray vPosition $= Enabled + + return $ + Descriptor triangles (fromIntegral firstIndex) (fromIntegral numVertices) + +display :: Descriptor -> DisplayCallback +display (Descriptor triangles firstIndex numVertices) = do + clear [ ColorBuffer ] + bindVertexArrayObject $= Just triangles + drawArrays Triangles firstIndex numVertices + flush + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ RGBAMode ] + initialWindowSize $= Size 512 512 + initialContextVersion $= (4, 3) + initialContextProfile $= [ CoreProfile ] + _ <- createWindow progName + descriptor <- init + displayCallback $= display descriptor + mainLoop diff --git a/examples/RedBook8/Chapter01/triangles.frag b/examples/RedBook8/Chapter01/triangles.frag new file mode 100644 --- /dev/null +++ b/examples/RedBook8/Chapter01/triangles.frag @@ -0,0 +1,8 @@ +#version 430 core + +out vec4 fColor; +void +main() +{ + fColor = vec4(0.0, 0.0, 1.0, 1.0); +} diff --git a/examples/RedBook8/Chapter01/triangles.vert b/examples/RedBook8/Chapter01/triangles.vert new file mode 100644 --- /dev/null +++ b/examples/RedBook8/Chapter01/triangles.vert @@ -0,0 +1,9 @@ +#version 430 core + +layout(location = 0) in vec4 vPosition; + +void +main() +{ + gl_Position = vPosition; +} diff --git a/examples/RedBook8/common/LoadShaders.hs b/examples/RedBook8/common/LoadShaders.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook8/common/LoadShaders.hs @@ -0,0 +1,89 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : LoadShaders +-- Copyright : (c) Sven Panne 2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- Utilities for shader handling, adapted from LoadShaders.cpp which is (c) The +-- Red Book Authors. +-- +-------------------------------------------------------------------------------- + +module LoadShaders ( + ShaderSource(..), ShaderInfo(..), loadShaders +) where + +import Control.Exception +import Control.Monad +import qualified Data.ByteString as B +import Graphics.UI.GLUT + +-------------------------------------------------------------------------------- + +-- | The source of the shader source code. + +data ShaderSource = + ByteStringSource B.ByteString + -- ^ The shader source code is directly given as a 'B.ByteString'. + | StringSource String + -- ^ The shader source code is directly given as a 'String'. + | FileSource FilePath + -- ^ The shader source code is located in the file at the given 'FilePath'. + deriving ( Eq, Ord, Show ) + +getSource :: ShaderSource -> IO B.ByteString +getSource (ByteStringSource bs) = return bs +getSource (StringSource str) = return $ packUtf8 str +getSource (FileSource path) = B.readFile path + +-------------------------------------------------------------------------------- + +-- | A description of a shader: The type of the shader plus its source code. + +data ShaderInfo = ShaderInfo ShaderType ShaderSource + deriving ( Eq, Ord, Show ) + +-------------------------------------------------------------------------------- + +-- | Create a new program object from the given shaders, throwing an +-- 'IOException' if something goes wrong. + +loadShaders :: [ShaderInfo] -> IO Program +loadShaders infos = + createProgram `bracketOnError` deleteObjectName $ \program -> do + loadCompileAttach program infos + linkAndCheck program + return program + +linkAndCheck :: Program -> IO () +linkAndCheck = checked linkProgram linkStatus programInfoLog "link" + +loadCompileAttach :: Program -> [ShaderInfo] -> IO () +loadCompileAttach _ [] = return () +loadCompileAttach program (ShaderInfo shType source : infos) = + createShader shType `bracketOnError` deleteObjectName $ \shader -> do + src <- getSource source + shaderSourceBS shader $= src + compileAndCheck shader + attachShader program shader + loadCompileAttach program infos + +compileAndCheck :: Shader -> IO () +compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile" + +checked :: (t -> IO ()) + -> (t -> GettableStateVar Bool) + -> (t -> GettableStateVar String) + -> String + -> t + -> IO () +checked action getStatus getInfoLog message object = do + action object + ok <- get (getStatus object) + unless ok $ do + infoLog <- get (getInfoLog object) + fail (message ++ " log: " ++ infoLog) diff --git a/include/HsGLUTExt.h b/include/HsGLUTExt.h deleted file mode 100644 --- a/include/HsGLUTExt.h +++ /dev/null @@ -1,33 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * Module : GLUT extension support for Graphics.UI.GLUT - * Copyright : (c) Sven Panne 2002-2005 - * License : BSD-style (see the file libraries/OpenGL/LICENSE) - * - * Maintainer : sven.panne@aedion.de - * Stability : provisional - * Portability : portable - * - * This header should only define preprocessor macros! - * - * -------------------------------------------------------------------------- */ - -#ifndef HSGLUTEXT_H -#define HSGLUTEXT_H - -/* NOTE: The macro must immediately start with the foreign declaration, - otherwise the magic mangler (hack_foreign) in the Hugs build system - doesn't recognize it. */ -#define API_ENTRY_INTERNAL(_entry,_ty,_safety) \ -foreign import CALLCONV _safety "dynamic" dyn_/**/_entry :: Graphics.UI.GLUT.Raw.APIEntry.Invoker (_ty) ; \ -_entry :: (_ty) ; \ -_entry = dyn_/**/_entry ptr_/**/_entry ; \ -ptr_/**/_entry :: FunPtr a ; \ -ptr_/**/_entry = unsafePerformIO (Graphics.UI.GLUT.Raw.APIEntry.getAPIEntry "_entry") ; \ -{-# NOINLINE ptr_/**/_entry #-} - -#define API_ENTRY(_entry,_ty) API_ENTRY_INTERNAL(_entry,_ty,unsafe) - -#define API_ENTRY_SAFE(_entry,_ty) API_ENTRY_INTERNAL(_entry,_ty,safe) - -#endif diff --git a/src/Graphics/UI/GLUT.hs b/src/Graphics/UI/GLUT.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT.hs @@ -0,0 +1,386 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- A Haskell binding for GLUT, the OpenGL Utility Toolkit, a window system +-- independent toolkit for writing OpenGL programs. It includes support for +-- the extended functionality available in freeglut (see +-- ) and OpenGLUT (see +-- ), too. +-- +----------------------------------------------------------------------------- + +module Graphics.UI.GLUT ( + -- * Legal stuff + + -- $LegalStuff + + -- * Introduction + + -- $Introduction + + -- ** Background + + -- $Background + + -- ** Design Philosophy + + -- $DesignPhilosophy + + -- ** API Versions + + -- $APIVersions + + -- ** Conventions + + -- $Conventions + + -- ** Terminology + + -- $Terminology + + module Graphics.Rendering.OpenGL, + + module Graphics.UI.GLUT.Initialization, + module Graphics.UI.GLUT.Begin, + module Graphics.UI.GLUT.Window, + module Graphics.UI.GLUT.Overlay, + module Graphics.UI.GLUT.Menu, + module Graphics.UI.GLUT.Callbacks, + module Graphics.UI.GLUT.Colormap, + module Graphics.UI.GLUT.State, + module Graphics.UI.GLUT.Fonts, + module Graphics.UI.GLUT.Objects, + module Graphics.UI.GLUT.Debugging, + module Graphics.UI.GLUT.DeviceControl, + module Graphics.UI.GLUT.GameMode +) where + +import Graphics.Rendering.OpenGL + +import Graphics.UI.GLUT.Initialization +import Graphics.UI.GLUT.Begin +import Graphics.UI.GLUT.Window +import Graphics.UI.GLUT.Overlay +import Graphics.UI.GLUT.Menu +import Graphics.UI.GLUT.Callbacks +import Graphics.UI.GLUT.Colormap +import Graphics.UI.GLUT.State +import Graphics.UI.GLUT.Fonts +import Graphics.UI.GLUT.Objects +import Graphics.UI.GLUT.Debugging +import Graphics.UI.GLUT.DeviceControl +import Graphics.UI.GLUT.GameMode + +----------------------------------------------------------------------------- +-- $LegalStuff +-- This documentation is heavily based on the man pages of Mark J. Kilgard\'s +-- GLUT library. +-- +-- OpenGL is a trademark of Silicon Graphics, Inc. +-- X Window System is a trademark of X Consortium, Inc. +-- Spaceball is a registered trademark of Spatial Systems, Inc. +-- +-- The author has taken care in preparation of this documentation but makes +-- no expressed or implied warranty of any kind and assumes no responsibility +-- for errors or omissions. No liability is assumed for incidental or +-- consequential damages in connection with or arising from the use of +-- information or programs contained herein. + +----------------------------------------------------------------------------- +-- $Introduction +-- The OpenGL Utility Toolkit (GLUT) is a programming interface for writing +-- window system independent OpenGL programs. Currently there are +-- implementations for the X Window System, the Windows family, OS\/2, and Mac. +-- The toolkit supports the following functionality: +-- +-- * Multiple windows for OpenGL rendering. +-- +-- * Callback driven event processing. +-- +-- * Sophisticated input devices. +-- +-- * An /idle/ routine and timers. +-- +-- * A simple, cascading pop-up menu facility. +-- +-- * Utility routines to generate various solid and wire frame objects. +-- +-- * Support for bitmap and stroke fonts. +-- +-- * Miscellaneous window management functions, including managing overlays. +-- +-- This documentation serves as both a specification and a programming guide. +-- If you are interested in a brief introduction to programming with GLUT, +-- have a look at the relevant parts of and the vast +-- amount of books on OpenGL, most of them use GLUT. +-- +-- The remainder of this section describes GLUT\'s design philosophy and +-- usage model. The following sections specify the GLUT routines, grouped by +-- functionality. The final sections discuss usage advice and the logical +-- programmer visible state maintained by GLUT. + +----------------------------------------------------------------------------- +-- $Background +-- One of the major accomplishments in the specification of OpenGL was +-- the isolation of window system dependencies from OpenGL\'s rendering +-- model. The result is that OpenGL is window system independent. +-- +-- Window system operations such as the creation of a rendering window and the +-- handling of window system events are left to the native window system to +-- define. Necessary interactions between OpenGL and the window system such as +-- creating and binding an OpenGL context to a window are described separately +-- from the OpenGL specification in a window system dependent specification. For +-- example, the GLX specification describes the standard by which OpenGL +-- interacts with the X Window System. +-- +-- The predecessor to OpenGL is IRIS GL. Unlike OpenGL, IRIS GL /does/ +-- specify how rendering windows are created and manipulated. IRIS GL\'s +-- windowing interface is reasonably popular largely because it is simple to +-- use. IRIS GL programmers can worry about graphics programming without needing +-- to be an expert in programming the native window system. Experience also +-- demonstrated that IRIS GL\'s windowing interface was high-level enough that +-- it could be retargeted to different window systems. Silicon Graphics migrated +-- from NeWS to the X Window System without any major changes to IRIS GL\'s +-- basic windowing interface. +-- +-- Removing window system operations from OpenGL is a sound decision because it +-- allows the OpenGL graphics system to be retargeted to various systems +-- including powerful but expensive graphics workstations as well as +-- mass-production graphics systems like video games, set-top boxes for +-- interactive television, and PCs. +-- +-- Unfortunately, the lack of a window system interface for OpenGL is a gap in +-- OpenGL\'s utility. Learning native window system APIs such as the X Window +-- System\'s Xlib or Motif can be daunting. Even those familiar with +-- native window system APIs need to understand the interface that binds OpenGL +-- to the native window system. And when an OpenGL program is written using the +-- native window system interface, despite the portability of the program\'s +-- OpenGL rendering code, the program itself will be window system dependent. +-- +-- Testing and documenting OpenGL\'s functionality lead to the development of +-- the @tk@ and @aux@ toolkits. The @aux@ toolkit is used in the examples found +-- in the /OpenGL Programming Guide/. Unfortunately, @aux@ has numerous +-- limitations and its utility is largely limited to toy programs. The @tk@ +-- library has more functionality than @aux@ but was developed in an /ad hoc/ +-- fashion and still lacks much important functionality that IRIS GL programmers +-- expect, like pop-up menus and overlays. +-- +-- GLUT is designed to fill the need for a window system independent programming +-- interface for OpenGL programs. The interface is designed to be simple yet +-- still meet the needs of useful OpenGL programs. Features from the IRIS GL, +-- @aux@, and @tk@ interfaces are included to make it easy for programmers used +-- to these interfaces to develop programs for GLUT. + +----------------------------------------------------------------------------- +-- $DesignPhilosophy +-- GLUT simplifies the implementation of programs using OpenGL rendering. The +-- GLUT application programming interface (API) requires very few routines to +-- display a graphics scene rendered using OpenGL. The GLUT API (like the OpenGL +-- API) is stateful. Most initial GLUT state is defined and the initial state is +-- reasonable for simple programs. The GLUT routines also take relatively few +-- parameters. +-- +-- The GLUT API is (as much as reasonable) window system independent. For this +-- reason, GLUT does not return /any/ native window system handles, pointers, or +-- other data structures. More subtle window system dependencies such as +-- reliance on window system dependent fonts are avoided by GLUT; instead, GLUT +-- supplies its own (limited) set of fonts. +-- +-- For programming ease, GLUT provides a simple menu sub-API. While the menuing +-- support is designed to be implemented as pop-up menus, GLUT gives window +-- system leeway to support the menu functionality in another manner (pull-down +-- menus for example). +-- +-- Two of the most important pieces of GLUT state are the /current window/ and +-- /current menu/. Most window and menu routines affect the /current window/ or +-- /menu/ respectively. Most callbacks implicitly set the /current window/ and +-- /menu/ to the appropriate window or menu responsible for the callback. GLUT +-- is designed so that a program with only a single window and\/or menu will not +-- need to keep track of any window or menu identifiers. This greatly simplifies +-- very simple GLUT programs. +-- +-- GLUT is designed for simple to moderately complex programs focused on OpenGL +-- rendering. GLUT implements its own event loop. For this reason, mixing GLUT +-- with other APIs that demand their own event handling structure may be +-- difficult. The advantage of a builtin event dispatch loop is simplicity. +-- +-- GLUT contains routines for rendering fonts and geometric objects, however +-- GLUT makes no claims on the OpenGL display list name space. For this reason, +-- none of the GLUT rendering routines use OpenGL display lists. It is up to the +-- GLUT programmer to compile the output from GLUT rendering routines into +-- display lists if this is desired. +-- +-- GLUT routines are logically organized into several sub-APIs according to +-- their functionality. The sub-APIs are: +-- +-- * /Initialization:/ Command line processing, window system initialization, +-- and initial window creation state are controlled by these routines. +-- +-- * /Beginning Event Processing:/ This routine enters GLUT\'s event processing +-- loop. This routine never returns, and it continuously calls GLUT callbacks +-- as necessary. +-- +-- * /Window Management:/ These routines create and control windows. +-- +-- * /Overlay Management:/ These routines establish and manage overlays for +-- windows. +-- +-- * /Menu Management:/ These routines create and control pop-up menus. +-- +-- * /Callback Registration:/ These routines register callbacks to be called by +-- the GLUT event processing loop. +-- +-- * /Color Index Colormap Management:/ These routines allow the manipulation +-- of color index colormaps for windows. +-- +-- * /State Retrieval:/ These routines allows programs to retrieve state from +-- GLUT. +-- +-- * /Font Rendering:/ These routines allow rendering of stroke and bitmap +-- fonts. +-- +-- * /Geometric Shape Rendering:/ These routines allow the rendering of 3D +-- geometric objects including spheres, cones, icosahedrons, and teapots. +-- +-- * /Debugging:/ This routine reports any pending GL errors. +-- +-- * /Device Control:/ These routines allow setting the key repeat and polling +-- the joystick. +-- +-- * /Game Mode:/ These routines allow programs to enter\/leave a full-screen +-- mode with specified properties. + +-- Note that the following item has been left out intentionally, its +-- implementation is too SGI-specific: +-- * /Video Resizing:/ These routines provide a means for doing swap or frame +-- synchronous resizing\/panning of the area that is to be magnified (or +-- passed through) to the output video resolution. + +----------------------------------------------------------------------------- +-- $APIVersions +-- The GLUT API has undergone several revisions with increasing functionality. +-- This Haskell binding provides access to everything in API version 4, +-- although it is not yet officially finalized. Nevertheless, it provides very +-- useful things like handling full-screen modes and special keys. + +----------------------------------------------------------------------------- +-- $Conventions +-- GLUT window and screen coordinates are expressed in pixels. The upper +-- left hand corner of the screen or a window is (0,0). X coordinates +-- increase in a rightward direction; Y coordinates increase in a +-- downward direction. Note: This is inconsistent with OpenGL\'s +-- coordinate scheme that generally considers the lower left hand +-- coordinate of a window to be at (0,0) but is consistent with most +-- popular window systems. + +----------------------------------------------------------------------------- +-- $Terminology +-- A number of terms are used in a GLUT-specific manner throughout this +-- document. The GLUT meaning of these terms is independent of the window +-- system GLUT is used with. Here are GLUT-specific meanings for the +-- following GLUT-specific terms: +-- +-- * /Callback:/ A programmer specified routine that can be registered with +-- GLUT to be called in response to a specific type of event. Also used to +-- refer to a specific callback routine being called. +-- +-- * /Colormap:/ A mapping of pixel values to RGB color values. Used by color +-- index windows. +-- +-- * /Dials and button box:/ A sophisticated input device consisting of a pad +-- of buttons and an array of rotating dials, often used by computer-aided +-- design programs. +-- +-- * /Display mode:/ A set of OpenGL frame buffer capabilities that can be +-- attributed to a window. +-- +-- * /Idle:/ A state when no window system events are received for processing +-- as callbacks and the idle callback, if one is registered, is called. +-- +-- * /Layer in use:/ Either the normal plane or overlay. This per-window state +-- determines what frame buffer layer OpenGL commands affect. +-- +-- * /Menu entry:/ A menu item that the user can select to trigger the menu +-- callback for the menu entry\'s value. +-- +-- * /Menu item:/ Either a menu entry or a sub-menu trigger. +-- +-- * /Modifiers:/ The Shift, Ctrl, and Alt keys that can be held down +-- simultaneously with a key or mouse button being pressed or released. +-- +-- * /Multisampling:/ A technique for hardware antialiasing generally available +-- only on expensive 3D graphics hardware. Each pixel is composed of a number +-- of samples (each containing color and depth information). The samples are +-- averaged to determine the displayed pixel color value. Multisampling is +-- supported as an extension to OpenGL. +-- +-- * /Normal plane:/ The default frame buffer layer where GLUT window state +-- resides; as opposed to the /overlay/. +-- +-- * /Overlay:/ A frame buffer layer that can be displayed preferentially to +-- the /normal plane/ and supports transparency to display through to the +-- /normal plane/. Overlays are useful for rubber-banding effects, text +-- annotation, and other operations, to avoid damaging the normal plane frame +-- buffer state. Overlays require hardware support not present on all systems. +-- +-- * /Pop:/ The act of forcing a window to the top of the stacking order for +-- sibling windows. +-- +-- * /Pop-up menu:/ A menu that can be set to appear when a specified mouse +-- button is pressed in a window. A pop-menu consists of multiple menu items. +-- +-- * /Push:/ The act of forcing a window to the bottom of the stacking order +-- for sibling windows. +-- +-- * /Reshape:/ The act of changing the size or shape of the window. +-- +-- * /Spaceball:/ A sophisticated 3D input device that provides six degrees of +-- freedom, three axes of rotation and three axes of translation. It also +-- supports a number of buttons. The device is a hand-sized ball attached to +-- a base. By cupping the ball with one\'s hand and applying torsional or +-- directional force on the ball, rotations and translationsare generated. +-- +-- * /Stereo:/ A frame buffer capability providing left and right color buffers +-- for creating stereoscopic renderings. Typically, the user wears LCD +-- shuttered goggles synchronized with the alternating display on the screen +-- of the left and right color buffers. +-- +-- * /Sub-menu:/ A menu cascaded from some sub-menu trigger. +-- +-- * /Sub-menu trigger:/ A menu item that the user can enter to cascade another +-- pop-up menu. +-- +-- * /Subwindow:/ A type of window that is the child window of a top-level +-- window or other subwindow. The drawing and visible region of a subwindow +-- is limited by its parent window. +-- +-- * /Tablet:/ A precise 2D input device. Like a mouse, 2D coordinates are +-- returned. The absolute position of the tablet \"puck\" on the tablet is +-- returned. Tablets also support a number of buttons. +-- +-- * /Timer:/ A callback that can be scheduled to be called in a specified +-- interval of time. +-- +-- * /Top-level window:/ A window that can be placed, moved, resized, etc. +-- independently from other top-level windows by the user. Subwindows may +-- reside within a top-level window. +-- +-- * /Window:/ A rectangular area for OpenGL rendering. +-- +-- * /Window display state:/ One of shown, hidden, or iconified. A shown window +-- is potentially visible on the screen (it may be obscured by other windows +-- and not actually visible). A hidden window will never be visible. An +-- iconified window is not visible but could be made visible in response to +-- some user action like clicking on the window\'s corresponding icon. +-- +-- * /Window system:/ A broad notion that refers to both the mechanism and +-- policy of the window system. For example, in the X Window System both the +-- window manager and the X server are integral to what GLUT considers the +-- window system. diff --git a/src/Graphics/UI/GLUT/Begin.hs b/src/Graphics/UI/GLUT/Begin.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Begin.hs @@ -0,0 +1,100 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Begin +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- After a GLUT program has done initial setup such as creating windows and +-- menus, GLUT programs enter the GLUT event processing loop by calling +-- 'mainLoop' or handle events iteratively with 'mainLoopEvent'. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Begin ( + -- * Handling events + mainLoop, mainLoopEvent, leaveMainLoop, + + -- * Controlling the behaviour when windows are closed + ActionOnWindowClose(..), actionOnWindowClose +) where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.StateVar ( StateVar, makeStateVar ) +import Foreign.C.Types ( CInt ) + +import Graphics.UI.GLUT.QueryUtils +import Graphics.UI.GLUT.Raw + +-------------------------------------------------------------------------------- + +-- | Enter the GLUT event processing loop; it will call as necessary any +-- callbacks that have been registered. This routine should be called at most +-- once in a GLUT program. + +mainLoop :: MonadIO m => m () +mainLoop = glutMainLoop + +-------------------------------------------------------------------------------- + +-- | (/freeglut only/) Process one iteration's worth of events in its event loop. +-- This allows the application to control its own event loop and still use the +-- GLUT package. + +mainLoopEvent :: MonadIO m => m () +mainLoopEvent = glutMainLoopEvent + +-------------------------------------------------------------------------------- + +-- | (/freeglut only/) Stop the event loop. If 'actionOnWindowClose' contains +-- 'Exit', the application will exit; otherwise control will return to the +-- function which called 'mainLoop'. +-- +-- If the application has two nested calls to 'mainLoop' and calls +-- 'leaveMainLoop', the behaviour is undefined. It may leave only the inner +-- nested loop or it may leave both loops. If the reader has a strong preference +-- for one behaviour over the other he should contact the freeglut Programming +-- Consortium and ask for the code to be fixed. + +leaveMainLoop :: MonadIO m => m () +leaveMainLoop = glutLeaveMainLoop + +-------------------------------------------------------------------------------- + +-- | The behaviour when the user closes a window. + +data ActionOnWindowClose + = -- | Exit the whole program when any window is closed or 'leaveMainLoop' + -- is called (default). + Exit + | -- | Return from mainLoop when any window is closed. + MainLoopReturns + | -- | Return from mainLoop after the last window is closed. + ContinueExecution + deriving ( Eq, Ord, Show ) + +marshalActionOnWindowClose :: ActionOnWindowClose -> CInt +marshalActionOnWindowClose x = case x of + Exit -> glut_ACTION_EXIT + MainLoopReturns -> glut_ACTION_GLUTMAINLOOP_RETURNS + ContinueExecution -> glut_ACTION_CONTINUE_EXECUTION + +unmarshalActionOnWindowClose :: CInt -> ActionOnWindowClose +unmarshalActionOnWindowClose x + | x == glut_ACTION_EXIT = Exit + | x == glut_ACTION_GLUTMAINLOOP_RETURNS = MainLoopReturns + | x == glut_ACTION_CONTINUE_EXECUTION = ContinueExecution + | otherwise = error ("unmarshalActionOnWindowClose: illegal value " ++ show x) + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Controls the behaviour when the user closes a window. + +actionOnWindowClose :: StateVar ActionOnWindowClose +actionOnWindowClose = + makeStateVar + (simpleGet unmarshalActionOnWindowClose glut_ACTION_ON_WINDOW_CLOSE) + (glutSetOption glut_ACTION_ON_WINDOW_CLOSE . marshalActionOnWindowClose) diff --git a/src/Graphics/UI/GLUT/Callbacks.hs b/src/Graphics/UI/GLUT/Callbacks.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Callbacks.hs @@ -0,0 +1,47 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Callbacks +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- +-- GLUT supports a number of callbacks to respond to events. There are three +-- types of callbacks: window, menu, and global. Window callbacks indicate when +-- to redisplay or reshape a window, when the visibility of the window changes, +-- and when input is available for the window. Menu callbacks are described in +-- "Graphics.UI.GLUT.Menu". The global callbacks manage the passing of time and +-- menu usage. The calling order of callbacks between different windows is +-- undefined. +-- +-- Callbacks for input events should be delivered to the window the event occurs +-- in. Events should not propagate to parent windows. +-- +-- A callback of type @Foo@ can registered by setting @fooCallback@ to 'Just' +-- the callback. Almost all callbacks can be de-registered by setting +-- the corresponding @fooCallback@ to 'Nothing', the only exceptions being +-- 'Graphics.UI.GLUT.Callbacks.Window.DisplayCallback' (can only be +-- re-registered) and 'Graphics.UI.GLUT.Callbacks.Global.TimerCallback' (can\'t +-- be unregistered). +-- +-- /X Implementation Notes:/ The X GLUT implementation uses the X Input +-- extension to support sophisticated input devices: Spaceball, dial & button +-- box, and digitizing tablet. Because the X Input extension does not mandate +-- how particular types of devices are advertised through the extension, it is +-- possible GLUT for X may not correctly support input devices that would +-- otherwise be of the correct type. The X GLUT implementation will support the +-- Silicon Graphics Spaceball, dial & button box, and digitizing tablet as +-- advertised through the X Input extension. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Callbacks ( + module Graphics.UI.GLUT.Callbacks.Window, + module Graphics.UI.GLUT.Callbacks.Global +) where + +import Graphics.UI.GLUT.Callbacks.Window +import Graphics.UI.GLUT.Callbacks.Global diff --git a/src/Graphics/UI/GLUT/Callbacks/Global.hs b/src/Graphics/UI/GLUT/Callbacks/Global.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Callbacks/Global.hs @@ -0,0 +1,114 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Callbacks.Global +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Callbacks.Global ( + -- * Menu status callback + MenuUsage(..), MenuStatusCallback, menuStatusCallback, + + -- * Idle callback + IdleCallback, idleCallback, + + -- * Timer callbacks + Timeout, TimerCallback, addTimerCallback +) where + +import Control.Monad.Fix ( mfix ) +import Data.StateVar ( SettableStateVar, makeSettableStateVar ) +import Foreign.C.Types ( CInt ) +import Graphics.Rendering.OpenGL ( Position(..) ) + +import Graphics.UI.GLUT.Callbacks.Registration +import Graphics.UI.GLUT.Raw + +-------------------------------------------------------------------------------- + +data MenuUsage + = NotInUse + | InUse + deriving ( Eq, Ord, Show ) + +unmarshalMenuUsage :: CInt -> MenuUsage +unmarshalMenuUsage x + | x == glut_MENU_NOT_IN_USE = NotInUse + | x == glut_MENU_IN_USE = InUse + | otherwise = error ("unmarshalMenuUsage: illegal value " ++ show x) + +type MenuStatusCallback = MenuUsage -> Position -> IO () + +-- | Controls the global menu status callback so a GLUT program can determine +-- when a menu is in use or not. When a menu status callback is registered, it +-- will be called with the value 'InUse' when pop-up menus are in use by the +-- user; and the callback will be called with the value 'NotInUse' when pop-up +-- menus are no longer in use. Additionally, the location in window coordinates +-- of the button press that caused the menu to go into use, or the location where +-- the menu was released (maybe outside the window). Other callbacks continue to +-- operate (except mouse motion callbacks) when pop-up menus are in use so the +-- menu status callback allows a program to suspend animation or other tasks +-- when menus are in use. The cascading and unmapping of sub-menus from an +-- initial pop-up menu does not generate menu status callbacks. There is a +-- single menu status callback for GLUT. +-- +-- When the menu status callback is called, the /current menu/ will be set to +-- the initial pop-up menu in both the 'InUse' and 'NotInUse' cases. The +-- /current window/ will be set to the window from which the initial menu was +-- popped up from, also in both cases. + +menuStatusCallback :: SettableStateVar (Maybe MenuStatusCallback) +menuStatusCallback = + makeSettableStateVar $ + setCallback MenuStatusCB glutMenuStatusFunc + (makeMenuStatusFunc . unmarshal) + where unmarshal cb s x y = + cb (unmarshalMenuUsage s) + (Position (fromIntegral x) (fromIntegral y)) + +-------------------------------------------------------------------------------- + +type IdleCallback = IO () + +-- | Controls the global idle callback so a GLUT program can perform background +-- processing tasks or continuous animation when window system events are not +-- being received. If enabled, the idle callback is continuously called when +-- events are not being received. The /current window/ and /current menu/ will +-- not be changed before the idle callback. Programs with multiple windows +-- and\/or menus should explicitly set the /current window/ and\/or /current +-- menu/ and not rely on its current setting. +-- +-- The amount of computation and rendering done in an idle callback should be +-- minimized to avoid affecting the program\'s interactive response. In general, +-- not more than a single frame of rendering should be done in an idle callback. + +idleCallback :: SettableStateVar (Maybe IdleCallback) +idleCallback = + makeSettableStateVar $ setCallback IdleCB glutIdleFunc makeIdleFunc + +-------------------------------------------------------------------------------- + +-- | Timeout for the timer callback in milliseconds +type Timeout = Int + +type TimerCallback = IO () + +-- | Register a one-shot timer callback to be triggered after at least the given +-- amount of time. Multiple timer callbacks at same or differing times may be +-- registered simultaneously. There is no support for canceling a registered +-- callback. +-- +-- The number of milliseconds is a lower bound on the time before the callback +-- is generated. GLUT attempts to deliver the timer callback as soon as possible +-- after the expiration of the callback\'s time interval. + +addTimerCallback :: Timeout -> TimerCallback -> IO () +addTimerCallback msecs timerCallback = do + funPtr <- mfix (\self -> makeTimerFunc (\_ -> do registerForCleanup self + timerCallback)) + glutTimerFunc (fromIntegral msecs) funPtr 0 diff --git a/src/Graphics/UI/GLUT/Callbacks/Registration.hs b/src/Graphics/UI/GLUT/Callbacks/Registration.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Callbacks/Registration.hs @@ -0,0 +1,163 @@ +{-# OPTIONS_GHC -fno-cse #-} + +{-# OPTIONS_HADDOCK hide #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Callbacks.Registration +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Callbacks.Registration ( + CallbackType(..), registerForCleanup, setCallback, getCurrentWindow +) where + +-------------------------------------------------------------------------------- + +import Control.Monad ( when ) +import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef ) +import qualified Data.Map as M +import Data.StateVar ( get ) +import Foreign.Ptr ( FunPtr, nullFunPtr, freeHaskellFunPtr ) +import System.IO.Unsafe ( unsafePerformIO ) + +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.Window + +-------------------------------------------------------------------------------- +-- No timer callback here, because they are one-shot and "self destroy" + +data CallbackType + = DisplayCB | OverlayDisplayCB | ReshapeCB + | KeyboardCB | KeyboardUpCB | MouseCB + | MotionCB | PassiveMotionCB | CrossingCB + | VisibilityCB | WindowStatusCB | SpecialCB + | SpecialUpCB | SpaceballMotionCB | SpaceballRotateCB + | SpaceballButtonCB | ButtonBoxCB | DialsCB + | TabletMotionCB | TabletButtonCB | JoystickCB + | MenuStatusCB | IdleCB + -- freeglut-only callback types + | CloseCB | MouseWheelCB | PositionCB + | MultiEntryCB | MultiMotionCB | MultiButtonCB + | MultiPassiveCB | InitContextCB | AppStatusCB + deriving ( Eq, Ord ) + +isGlobal :: CallbackType -> Bool +isGlobal MenuStatusCB = True +isGlobal IdleCB = True +isGlobal _ = False + +-------------------------------------------------------------------------------- +-- To uniquely identify a particular callback, the associated window is needed +-- for window callbacks. + +data CallbackID = CallbackID (Maybe Window) CallbackType + deriving ( Eq, Ord ) + +getCallbackID :: CallbackType -> IO CallbackID +getCallbackID callbackType = do + maybeWindow <- if isGlobal callbackType + then return Nothing + else fmap Just $ getCurrentWindow "getCallbackID" + return $ CallbackID maybeWindow callbackType + +getCurrentWindow :: String -> IO Window +getCurrentWindow func = do + win <- get currentWindow + maybe (error (func ++ ": no current window")) return win + +-------------------------------------------------------------------------------- +-- This seems to be a common Haskell hack nowadays: A plain old global variable +-- with an associated mutator. Perhaps some language/library support is needed? + +{-# NOINLINE theCallbackTable #-} +theCallbackTable :: IORef (CallbackTable a) +theCallbackTable = unsafePerformIO (newIORef emptyCallbackTable) + +getCallbackTable :: IO (CallbackTable a) +getCallbackTable = readIORef theCallbackTable + +modifyCallbackTable :: (CallbackTable a -> CallbackTable a) -> IO () +modifyCallbackTable = modifyIORef theCallbackTable + +-------------------------------------------------------------------------------- + +type CallbackTable a = M.Map CallbackID (FunPtr a) + +emptyCallbackTable :: CallbackTable a +emptyCallbackTable = M.empty + +lookupInCallbackTable :: CallbackID -> IO (Maybe (FunPtr a)) +lookupInCallbackTable callbackID = + fmap (M.lookup callbackID) getCallbackTable + +deleteFromCallbackTable :: CallbackID -> IO () +deleteFromCallbackTable callbackID = + modifyCallbackTable (M.delete callbackID) + +addToCallbackTable :: CallbackID -> FunPtr a -> IO () +addToCallbackTable callbackID funPtr = + modifyCallbackTable (M.insert callbackID funPtr) + +-------------------------------------------------------------------------------- +-- Another global mutable variable: The list of function pointers ready to be +-- freed by freeHaskellFunPtr + +{-# NOINLINE theCleanupList #-} +theCleanupList :: IORef [FunPtr a] +theCleanupList = unsafePerformIO (newIORef []) + +getCleanupList :: IO [FunPtr a] +getCleanupList = readIORef theCleanupList + +setCleanupList :: [FunPtr a] -> IO () +setCleanupList = writeIORef theCleanupList + +-------------------------------------------------------------------------------- +-- And yet another mutable (write-once) variable: A function pointer to a +-- callback which frees all function pointers on the cleanup list. + +{-# NOINLINE theScavenger #-} +theScavenger :: IORef (FunPtr TimerFunc) +theScavenger = unsafePerformIO (newIORef =<< makeTimerFunc (\_ -> do + cleanupList <- getCleanupList + mapM_ freeHaskellFunPtr cleanupList + setCleanupList [])) + +getScavenger :: IO (FunPtr TimerFunc) +getScavenger = readIORef theScavenger + +-------------------------------------------------------------------------------- +-- Here is the really cunning stuff: If an element is added to the cleanup list +-- when it is empty, register an immediate callback at GLUT to free the list as +-- soon as possible. + +registerForCleanup :: FunPtr a -> IO () +registerForCleanup funPtr = do + oldCleanupList <- getCleanupList + setCleanupList (funPtr : oldCleanupList) + when (null oldCleanupList) $ do + scavenger <- getScavenger + glutTimerFunc 0 scavenger 0 + +-------------------------------------------------------------------------------- + +setCallback :: CallbackType -> (FunPtr a -> IO ()) -> (b -> IO (FunPtr a)) + -> Maybe b -> IO () +setCallback callbackType registerAtGLUT makeCallback maybeCallback = do + callbackID <- getCallbackID callbackType + maybeOldFunPtr <- lookupInCallbackTable callbackID + case maybeOldFunPtr of + Nothing -> return () + Just oldFunPtr -> do registerForCleanup oldFunPtr + deleteFromCallbackTable callbackID + case maybeCallback of + Nothing -> registerAtGLUT nullFunPtr + Just callback -> do newFunPtr <- makeCallback callback + addToCallbackTable callbackID newFunPtr + registerAtGLUT newFunPtr diff --git a/src/Graphics/UI/GLUT/Callbacks/Window.hs b/src/Graphics/UI/GLUT/Callbacks/Window.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Callbacks/Window.hs @@ -0,0 +1,993 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Callbacks.Window +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Callbacks.Window ( + -- * Redisplay callbacks + DisplayCallback, displayCallback, overlayDisplayCallback, + + -- * Reshape callback + ReshapeCallback, reshapeCallback, + + -- * Position callback + PositionCallback, positionCallback, + + -- * Callbacks for visibility changes + Visibility(..), VisibilityCallback, visibilityCallback, + WindowState(..), WindowStateCallback, windowStateCallback, + + -- * Window close callback + CloseCallback, closeCallback, + + -- * Life cycle callbacks for mobile platforms + InitContextCallback, initContextCallback, + AppStatus(..), AppStatusCallback, appStatusCallback, + + -- * Keyboard callback + KeyboardCallback, keyboardCallback, keyboardUpCallback, + + -- * Special callback + SpecialCallback, specialCallback, specialUpCallback, + + -- * Mouse callback + MouseCallback, mouseCallback, + + -- * Keyboard and mouse input callback + Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..), + KeyboardMouseCallback, keyboardMouseCallback, + + -- * Mouse wheel callback + WheelNumber, WheelDirection, MouseWheelCallback, mouseWheelCallback, + + -- * Mouse movement callbacks + MotionCallback, motionCallback, passiveMotionCallback, + Crossing(..), CrossingCallback, crossingCallback, + + -- * Spaceball callback + SpaceballMotion, SpaceballRotation, ButtonIndex, SpaceballInput(..), + SpaceballCallback, spaceballCallback, + + -- * Dial & button box callback + DialAndButtonBoxInput(..), DialIndex, + DialAndButtonBoxCallback, dialAndButtonBoxCallback, + + -- * Tablet callback + TabletPosition(..), TabletInput(..), TabletCallback, tabletCallback, + + -- * Joystick callback + JoystickButtons(..), JoystickPosition(..), + JoystickCallback, joystickCallback, + + -- * Multi-touch support + TouchID, + MultiMouseCallback, multiMouseCallback, + MultiCrossingCallback, multiCrossingCallback, + MultiMotionCallback, multiMotionCallback, multiPassiveMotionCallback + +) where + +import Data.Bits ( (.&.) ) +import Data.Char ( chr ) +import Data.Maybe ( fromJust ) +import Data.StateVar ( SettableStateVar, makeSettableStateVar ) +import Foreign.C.Types ( CInt, CUInt ) +import Graphics.Rendering.OpenGL ( Position(..), Size(..) ) + +import Graphics.UI.GLUT.Callbacks.Registration +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.State +import Graphics.UI.GLUT.Types + +-------------------------------------------------------------------------------- + +-- | A display callback + +type DisplayCallback = IO () + +-- | Controls the display callback for the /current window./ When GLUT determines +-- that the normal plane for the window needs to be redisplayed, the display +-- callback for the window is called. Before the callback, the /current window/ +-- is set to the window needing to be redisplayed and (if no overlay display +-- callback is registered) the /layer in use/ is set to the normal plane. The +-- entire normal plane region should be redisplayed in response to the callback +-- (this includes ancillary buffers if your program depends on their state). +-- +-- GLUT determines when the display callback should be triggered based on the +-- window\'s redisplay state. The redisplay state for a window can be either set +-- explicitly by calling 'Graphics.UI.GLUT.Window.postRedisplay' or implicitly +-- as the result of window damage reported by the window system. Multiple posted +-- redisplays for a window are coalesced by GLUT to minimize the number of +-- display callbacks called. +-- +-- When an overlay is established for a window, but there is no overlay display +-- callback registered, the display callback is used for redisplaying both the +-- overlay and normal plane (that is, it will be called if either the redisplay +-- state or overlay redisplay state is set). In this case, the /layer in use/ is +-- not implicitly changed on entry to the display callback. +-- +-- See 'overlayDisplayCallback' to understand how distinct callbacks for the +-- overlay and normal plane of a window may be established. +-- +-- When a window is created, no display callback exists for the window. It is +-- the responsibility of the programmer to install a display callback for the +-- window before the window is shown. A display callback must be registered for +-- any window that is shown. If a window becomes displayed without a display +-- callback being registered, a fatal error occurs. There is no way to +-- \"deregister\" a display callback (though another callback routine can always +-- be registered). +-- +-- Upon return from the display callback, the normal damaged state of the window +-- (see 'Graphics.UI.GLUT.State.damaged') is cleared. If there is no overlay +-- display callback registered the overlay damaged state of the window (see +-- 'Graphics.UI.GLUT.State.damaged') is also cleared. + +displayCallback :: SettableStateVar DisplayCallback +displayCallback = makeSettableStateVar $ + setCallback DisplayCB glutDisplayFunc makeDisplayFunc . Just + +-------------------------------------------------------------------------------- + +-- | Controls the overlay display callback for the /current window./ The overlay +-- display callback is functionally the same as the window\'s display callback +-- except that the overlay display callback is used to redisplay the window\'s +-- overlay. +-- +-- When GLUT determines that the overlay plane for the window needs to be +-- redisplayed, the overlay display callback for the window is called. Before +-- the callback, the /current window/ is set to the window needing to be +-- redisplayed and the /layer in use/ is set to the overlay. The entire overlay +-- region should be redisplayed in response to the callback (this includes +-- ancillary buffers if your program depends on their state). +-- +-- GLUT determines when the overlay display callback should be triggered based +-- on the window\'s overlay redisplay state. The overlay redisplay state for a +-- window can be either set explicitly by calling +-- 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay' or implicitly as the result +-- of window damage reported by the window system. Multiple posted overlay +-- redisplays for a window are coalesced by GLUT to minimize the number of +-- overlay display callbacks called. +-- +-- Upon return from the overlay display callback, the overlay damaged state of +-- the window (see 'Graphics.UI.GLUT.State.damaged') is cleared. +-- +-- Initially there is no overlay display callback registered when an overlay is +-- established. See 'displayCallback' to understand how the display callback +-- alone is used if an overlay display callback is not registered. + +overlayDisplayCallback :: SettableStateVar (Maybe DisplayCallback) +overlayDisplayCallback = makeSettableStateVar $ + setCallback OverlayDisplayCB glutOverlayDisplayFunc makeOverlayDisplayFunc + +-------------------------------------------------------------------------------- + +-- | A reshape callback + +type ReshapeCallback = Size -> IO () + +-- | Controls the reshape callback for the /current window./ The reshape callback +-- is triggered when a window is reshaped. A reshape callback is also triggered +-- immediately before a window\'s first display callback after a window is +-- created or whenever an overlay for the window is established. The parameter +-- of the callback specifies the new window size in pixels. Before the callback, +-- the /current window/ is set to the window that has been reshaped. +-- +-- If a reshape callback is not registered for a window or 'reshapeCallback' is +-- set to 'Nothing' (to deregister a previously registered callback), the +-- default reshape callback is used. This default callback will simply call +-- +-- @ +-- 'Graphics.Rendering.OpenGL.GL.CoordTrans.viewport' ('Graphics.Rendering.OpenGL.GL.CoordTrans.Position' 0 0) ('Graphics.Rendering.OpenGL.GL.CoordTrans.Size' /width/ /height/) +-- @ +-- +-- on the normal plane (and on the overlay if one exists). +-- +-- If an overlay is established for the window, a single reshape callback is +-- generated. It is the callback\'s responsibility to update both the normal +-- plane and overlay for the window (changing the layer in use as necessary). +-- +-- When a top-level window is reshaped, subwindows are not reshaped. It is up to +-- the GLUT program to manage the size and positions of subwindows within a +-- top-level window. Still, reshape callbacks will be triggered for subwindows +-- when their size is changed using 'Graphics.UI.GLUT.Window.windowSize'. + +reshapeCallback :: SettableStateVar (Maybe ReshapeCallback) +reshapeCallback = makeSettableStateVar $ + setCallback ReshapeCB glutReshapeFunc (makeReshapeFunc . unmarshal) + where unmarshal cb w h = cb (Size (fromIntegral w) (fromIntegral h)) + +-------------------------------------------------------------------------------- + +-- | A position callback + +type PositionCallback = Position -> IO () + +-- | (/freeglut only/) Controls the position callback for the /current window./ +-- The position callback for a window is called when the position of a window +-- changes. + +positionCallback :: SettableStateVar (Maybe PositionCallback) +positionCallback = makeSettableStateVar $ + setCallback PositionCB glutPositionFunc (makePositionFunc . unmarshal) + where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y)) + +-------------------------------------------------------------------------------- + +-- | The visibility state of the /current window/ + +data Visibility + = NotVisible -- ^ No part of the /current window/ is visible, i.e., until the + -- window\'s visibility changes, all further rendering to the + -- window is discarded. + | Visible -- ^ The /current window/ is totally or partially visible. GLUT + -- considers a window visible if any pixel of the window is + -- visible or any pixel of any descendant window is visible on + -- the screen. + deriving ( Eq, Ord, Show ) + +unmarshalVisibility :: CInt -> Visibility +unmarshalVisibility x + | x == glut_NOT_VISIBLE = NotVisible + | x == glut_VISIBLE = Visible + | otherwise = error ("unmarshalVisibility: illegal value " ++ show x) + +-------------------------------------------------------------------------------- + +-- | A visibility callback + +type VisibilityCallback = Visibility -> IO () + +-- | Controls the visibility callback for the /current window./ The visibility +-- callback for a window is called when the visibility of a window changes. +-- +-- If the visibility callback for a window is disabled and later re-enabled, the +-- visibility status of the window is undefined; any change in window visibility +-- will be reported, that is if you disable a visibility callback and re-enable +-- the callback, you are guaranteed the next visibility change will be reported. +-- +-- Note that you can either use 'visibilityCallback' or 'windowStateCallback', +-- but not both, because the former is implemented via the latter. + +visibilityCallback :: SettableStateVar (Maybe VisibilityCallback) +visibilityCallback = makeSettableStateVar $ + setCallback VisibilityCB glutVisibilityFunc + (makeVisibilityFunc . unmarshal) + where unmarshal cb = cb . unmarshalVisibility + +-------------------------------------------------------------------------------- + +-- | The window state of the /current window/ + +data WindowState + = Unmapped -- ^ The /current window/ is unmapped. + | FullyRetained -- ^ The /current window/ is unobscured. + | PartiallyRetained -- ^ The /current window/ is partially obscured. + | FullyCovered -- ^ The /current window/ is fully obscured. + deriving ( Eq, Ord, Show ) + +unmarshalWindowState :: CInt -> WindowState +unmarshalWindowState x + | x == glut_HIDDEN = Unmapped + | x == glut_FULLY_RETAINED = FullyRetained + | x == glut_PARTIALLY_RETAINED = PartiallyRetained + | x == glut_FULLY_COVERED = FullyCovered + | otherwise = error ("unmarshalWindowState: illegal value " ++ show x) + +-------------------------------------------------------------------------------- + +-- | A window state callback + +type WindowStateCallback = WindowState -> IO () + +-- | Controls the window state callback for the +-- /current window./ The window state callback for a window is called when the +-- window state of a window changes. +-- +-- If the window state callback for a window is disabled and later re-enabled, +-- the window state state of the window is undefined; any change in the window +-- state will be reported, that is if you disable a window state callback and +-- re-enable the callback, you are guaranteed the next window state change will +-- be reported. +-- +-- Note that you can either use 'visibilityCallback' or 'windowStateCallback', +-- but not both, because the former is implemented via the latter. + +windowStateCallback :: SettableStateVar (Maybe WindowStateCallback) +windowStateCallback = makeSettableStateVar $ + setCallback WindowStatusCB glutWindowStatusFunc + (makeWindowStatusFunc . unmarshal) + where unmarshal cb = cb . unmarshalWindowState + +-------------------------------------------------------------------------------- + +-- | A window close callback + +type CloseCallback = IO () + +-- | Controls the window close callback for the /current window/. + +closeCallback :: SettableStateVar (Maybe CloseCallback) +closeCallback = makeSettableStateVar $ + setCallback CloseCB glutCloseFunc makeCloseFunc + +-------------------------------------------------------------------------------- + +-- | An initialize context callback + +type InitContextCallback = IO () + +-- | (/freeglut only/) Controls the initialize context callback for the /current +-- window/. + +initContextCallback :: SettableStateVar (Maybe InitContextCallback) +initContextCallback = makeSettableStateVar $ + setCallback InitContextCB glutInitContextFunc makeInitContextFunc + +-------------------------------------------------------------------------------- + +-- | The application status of the /current window/ + +data AppStatus + = AppStatusPause + | AppStatusResume + deriving ( Eq, Ord, Show ) + +unmarshalAppStatus :: CInt -> AppStatus +unmarshalAppStatus x + | x == glut_APPSTATUS_PAUSE = AppStatusPause + | x == glut_APPSTATUS_RESUME = AppStatusResume + | otherwise = error ("unmarshalAppStatus: illegal value " ++ show x) + +-------------------------------------------------------------------------------- + +-- | An application status callback + +type AppStatusCallback = AppStatus -> IO () + +-- | Controls the application status callback for the /current window./ + +appStatusCallback :: SettableStateVar (Maybe AppStatusCallback) +appStatusCallback = makeSettableStateVar $ + setCallback AppStatusCB glutAppStatusFunc + (makeAppStatusFunc . unmarshal) + where unmarshal cb = cb . unmarshalAppStatus + +-------------------------------------------------------------------------------- + +-- | A keyboard callback + +type KeyboardCallback = Char -> Position -> IO () + +setKeyboardCallback :: Maybe KeyboardCallback -> IO () +setKeyboardCallback = + setCallback KeyboardCB glutKeyboardFunc (makeKeyboardFunc . unmarshal) + where unmarshal cb c x y = cb (chr (fromIntegral c)) + (Position (fromIntegral x) (fromIntegral y)) + +-- | Controls the keyboard callback for the /current window/. This is +-- activated only when a key is pressed. + +keyboardCallback :: SettableStateVar (Maybe KeyboardCallback) +keyboardCallback = makeSettableStateVar setKeyboardCallback + +-------------------------------------------------------------------------------- + +setKeyboardUpCallback :: Maybe KeyboardCallback -> IO () +setKeyboardUpCallback = + setCallback KeyboardUpCB glutKeyboardUpFunc + (makeKeyboardUpFunc . unmarshal) + where unmarshal cb c x y = cb (chr (fromIntegral c)) + (Position (fromIntegral x) (fromIntegral y)) + +-- | Controls the keyboard callback for the /current window/. This is +-- activated only when a key is released. + +keyboardUpCallback :: SettableStateVar (Maybe KeyboardCallback) +keyboardUpCallback = makeSettableStateVar setKeyboardUpCallback + +-------------------------------------------------------------------------------- + +-- | Special keys + +data SpecialKey + = KeyF1 + | KeyF2 + | KeyF3 + | KeyF4 + | KeyF5 + | KeyF6 + | KeyF7 + | KeyF8 + | KeyF9 + | KeyF10 + | KeyF11 + | KeyF12 + | KeyLeft + | KeyUp + | KeyRight + | KeyDown + | KeyPageUp + | KeyPageDown + | KeyHome + | KeyEnd + | KeyInsert + | KeyNumLock + | KeyBegin + | KeyDelete + | KeyShiftL + | KeyShiftR + | KeyCtrlL + | KeyCtrlR + | KeyAltL + | KeyAltR + | KeyUnknown Int -- ^ You should actually never encounter this value, it is + -- just here as a safeguard against future changes in the + -- native GLUT library. + deriving ( Eq, Ord, Show ) + +unmarshalSpecialKey :: CInt -> SpecialKey +unmarshalSpecialKey x + | x == glut_KEY_F1 = KeyF1 + | x == glut_KEY_F2 = KeyF2 + | x == glut_KEY_F3 = KeyF3 + | x == glut_KEY_F4 = KeyF4 + | x == glut_KEY_F5 = KeyF5 + | x == glut_KEY_F6 = KeyF6 + | x == glut_KEY_F7 = KeyF7 + | x == glut_KEY_F8 = KeyF8 + | x == glut_KEY_F9 = KeyF9 + | x == glut_KEY_F10 = KeyF10 + | x == glut_KEY_F11 = KeyF11 + | x == glut_KEY_F12 = KeyF12 + | x == glut_KEY_LEFT = KeyLeft + | x == glut_KEY_UP = KeyUp + | x == glut_KEY_RIGHT = KeyRight + | x == glut_KEY_DOWN = KeyDown + | x == glut_KEY_PAGE_UP = KeyPageUp + | x == glut_KEY_PAGE_DOWN = KeyPageDown + | x == glut_KEY_HOME = KeyHome + | x == glut_KEY_END = KeyEnd + | x == glut_KEY_INSERT = KeyInsert + | x == glut_KEY_NUM_LOCK = KeyNumLock + | x == glut_KEY_BEGIN = KeyBegin + | x == glut_KEY_DELETE = KeyDelete + | x == glut_KEY_SHIFT_L = KeyShiftL + | x == glut_KEY_SHIFT_R = KeyShiftR + | x == glut_KEY_CTRL_L = KeyCtrlL + | x == glut_KEY_CTRL_R = KeyCtrlR + | x == glut_KEY_ALT_L = KeyAltL + | x == glut_KEY_ALT_R = KeyAltR + | otherwise = KeyUnknown (fromIntegral x) + +-------------------------------------------------------------------------------- + +-- | A special key callback + +type SpecialCallback = SpecialKey -> Position -> IO () + +setSpecialCallback :: Maybe SpecialCallback -> IO () +setSpecialCallback = + setCallback SpecialCB glutSpecialFunc (makeSpecialFunc . unmarshal) + where unmarshal cb k x y = cb (unmarshalSpecialKey k) + (Position (fromIntegral x) (fromIntegral y)) + +-- | Controls the special key callback for the /current window/. This is +-- activated only when a special key is pressed. + +specialCallback :: SettableStateVar (Maybe SpecialCallback) +specialCallback = makeSettableStateVar setSpecialCallback + +-------------------------------------------------------------------------------- + +setSpecialUpCallback :: Maybe SpecialCallback -> IO () +setSpecialUpCallback = + setCallback SpecialUpCB glutSpecialUpFunc (makeSpecialUpFunc . unmarshal) + where unmarshal cb k x y = cb (unmarshalSpecialKey k) + (Position (fromIntegral x) (fromIntegral y)) + +-- | Controls the special key callback for the /current window/. This is +-- activated only when a special key is released. + +specialUpCallback :: SettableStateVar (Maybe SpecialCallback) +specialUpCallback = makeSettableStateVar setSpecialUpCallback + +-------------------------------------------------------------------------------- + +-- | The current state of a key or button + +data KeyState + = Down + | Up + deriving ( Eq, Ord, Show ) + +unmarshalKeyState :: CInt -> KeyState +unmarshalKeyState x + | x == glut_DOWN = Down + | x == glut_UP = Up + | otherwise = error ("unmarshalKeyState: illegal value " ++ show x) + +-------------------------------------------------------------------------------- + +-- | A mouse callback + +type MouseCallback = MouseButton -> KeyState -> Position -> IO () + +setMouseCallback :: Maybe MouseCallback -> IO () +setMouseCallback = + setCallback MouseCB glutMouseFunc (makeMouseFunc . unmarshal) + where unmarshal cb b s x y = cb (unmarshalMouseButton b) + (unmarshalKeyState s) + (Position (fromIntegral x) (fromIntegral y)) + +-- | Controls the mouse callback for the /current window/. + +mouseCallback :: SettableStateVar (Maybe MouseCallback) +mouseCallback = makeSettableStateVar setMouseCallback + +-------------------------------------------------------------------------------- + +-- | The state of the keyboard modifiers + +data Modifiers = Modifiers { shift, ctrl, alt :: KeyState } + deriving ( Eq, Ord, Show ) + +-- Could use fromBitfield + Enum/Bounded instances + marshalModifier instead... +unmarshalModifiers :: CInt -> Modifiers +unmarshalModifiers m = Modifiers { + shift = if (m .&. glut_ACTIVE_SHIFT) /= 0 then Down else Up, + ctrl = if (m .&. glut_ACTIVE_CTRL ) /= 0 then Down else Up, + alt = if (m .&. glut_ACTIVE_ALT ) /= 0 then Down else Up } + +getModifiers :: IO Modifiers +getModifiers = fmap unmarshalModifiers glutGetModifiers + +-------------------------------------------------------------------------------- + +-- | A generalized view of keys + +data Key + = Char Char + | SpecialKey SpecialKey + | MouseButton MouseButton + deriving ( Eq, Ord, Show ) + +-- | A keyboard\/mouse callback + +type KeyboardMouseCallback = + Key -> KeyState -> Modifiers -> Position -> IO () + +-- | Controls the keyboard\/mouse callback for the /current window./ The +-- keyboard\/mouse callback for a window is called when the state of a key or +-- mouse button changes. The callback parameters indicate the new state of the +-- key\/button, the state of the keyboard modifiers, and the mouse location in +-- window relative coordinates. +-- +-- Note that this is a convenience function that should not ordinarily be used +-- in conjunction with `keyboardCallback`, `keyboardUpCallback`, +-- `specialCallback`, `specialUpCallback`, or `mouseCallback`. + +keyboardMouseCallback :: SettableStateVar (Maybe KeyboardMouseCallback) +keyboardMouseCallback = makeSettableStateVar setKeyboardMouseCallback + +setKeyboardMouseCallback :: Maybe KeyboardMouseCallback -> IO () +setKeyboardMouseCallback Nothing = do + setKeyboardCallback Nothing + setKeyboardUpCallback Nothing + setSpecialCallback Nothing + setSpecialUpCallback Nothing + setMouseCallback Nothing +setKeyboardMouseCallback (Just cb) = do + setKeyboardCallback (Just (\c p -> do m <- getModifiers + cb (Char c) Down m p)) + setKeyboardUpCallback (Just (\c p -> do m <- getModifiers + cb (Char c) Up m p)) + setSpecialCallback (Just (\s p -> do m <- getModifiers + cb (SpecialKey s) Down m p)) + setSpecialUpCallback (Just (\s p -> do m <- getModifiers + cb (SpecialKey s) Up m p)) + setMouseCallback (Just (\b s p -> do m <- getModifiers + cb (MouseButton b) s m p)) + +-------------------------------------------------------------------------------- + +type WheelNumber = Int + +type WheelDirection = Int + +type MouseWheelCallback = WheelNumber -> WheelDirection -> Position -> IO () + +-- | (/freeglut only/) Controls the mouse wheel callback for the +-- /current window./ The mouse wheel callback for a window is called when a +-- mouse wheel is used and the wheel number is greater than or equal to +-- 'Graphics.UI.GLUT.State.numMouseButtons'. + +mouseWheelCallback :: SettableStateVar (Maybe MouseWheelCallback) +mouseWheelCallback = makeSettableStateVar $ + setCallback MouseWheelCB glutMouseWheelFunc (makeMouseWheelFunc . unmarshal) + where unmarshal cb n d x y = cb (fromIntegral n) (fromIntegral d) + (Position (fromIntegral x) (fromIntegral y)) + +-------------------------------------------------------------------------------- + +-- | A motion callback + +type MotionCallback = Position -> IO () + +-- | Controls the motion callback for the /current window./ The motion callback +-- for a window is called when the mouse moves within the window while one or +-- more mouse buttons are pressed. The callback parameter indicates the mouse +-- location in window relative coordinates. + +motionCallback :: SettableStateVar (Maybe MotionCallback) +motionCallback = makeSettableStateVar $ + setCallback MotionCB glutMotionFunc (makeMotionFunc . unmarshal) + where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y)) + +-------------------------------------------------------------------------------- + +-- | Controls the passive motion callback for the /current window./ The passive +-- motion callback for a window is called when the mouse moves within the window +-- while /no/ mouse buttons are pressed. The callback parameter indicates the +-- mouse location in window relative coordinates. + +passiveMotionCallback :: SettableStateVar (Maybe MotionCallback) +passiveMotionCallback = makeSettableStateVar $ + setCallback PassiveMotionCB glutPassiveMotionFunc + (makePassiveMotionFunc . unmarshal) + where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y)) + +-------------------------------------------------------------------------------- + +-- | The relation between the mouse pointer and the /current window/ has +-- changed. + +data Crossing + = WindowLeft -- ^ The mouse pointer has left the /current window./ + | WindowEntered -- ^ The mouse pointer has entered the /current window./ + deriving ( Eq, Ord, Show ) + +unmarshalCrossing :: CInt -> Crossing +unmarshalCrossing x + | x == glut_LEFT = WindowLeft + | x == glut_ENTERED = WindowEntered + | otherwise = error ("unmarshalCrossing: illegal value " ++ show x) + +-------------------------------------------------------------------------------- + +-- | An enter\/leave callback + +type CrossingCallback = Crossing -> IO () + +-- | Controls the mouse enter\/leave callback for the /current window./ Note +-- that some window systems may not generate accurate enter\/leave callbacks. +-- +-- /X Implementation Notes:/ An X implementation of GLUT should generate +-- accurate enter\/leave callbacks. + +crossingCallback :: SettableStateVar (Maybe CrossingCallback) +crossingCallback = makeSettableStateVar $ + setCallback CrossingCB glutEntryFunc (makeEntryFunc . unmarshal) + where unmarshal cb = cb . unmarshalCrossing + +-------------------------------------------------------------------------------- + +-- | Translation of the Spaceball along one axis, normalized to be in the range +-- of -1000 to +1000 inclusive + +type SpaceballMotion = Int + +-- | Rotation of the Spaceball along one axis, normalized to be in the range +-- of -1800 .. +1800 inclusive + +type SpaceballRotation = Int + +-- | The index of a specific buttons of an input device. + +type ButtonIndex = Int + +-- | The state of the Spaceball has changed. + +data SpaceballInput + = SpaceballMotion SpaceballMotion SpaceballMotion SpaceballMotion + | SpaceballRotation SpaceballRotation SpaceballRotation SpaceballRotation + | SpaceballButton ButtonIndex KeyState + deriving ( Eq, Ord, Show ) + +-- | A SpaceballButton callback + +type SpaceballCallback = SpaceballInput -> IO () + +-- | Controls the Spaceball callback for the /current window./ The Spaceball +-- callback for a window is called when the window has Spaceball input focus +-- (normally, when the mouse is in the window) and the user generates Spaceball +-- translations, rotations, or button presses. The number of available Spaceball +-- buttons can be determined with 'Graphics.UI.GLUT.State.numSpaceballButtons'. +-- +-- Registering a Spaceball callback when a Spaceball device is not available has +-- no effect and is not an error. In this case, no Spaceball callbacks will be +-- generated. + +spaceballCallback :: SettableStateVar (Maybe SpaceballCallback) +spaceballCallback = makeSettableStateVar setSpaceballCallback + +setSpaceballCallback :: Maybe SpaceballCallback -> IO () +setSpaceballCallback Nothing = do + setSpaceballMotionCallback Nothing + setSpaceballRotationCallback Nothing + setSpaceballButtonCallback Nothing +setSpaceballCallback (Just cb) = do + setSpaceballMotionCallback (Just (\x y z -> cb (SpaceballMotion x y z))) + setSpaceballRotationCallback (Just (\x y z -> cb (SpaceballRotation x y z))) + setSpaceballButtonCallback (Just (\b s -> cb (SpaceballButton b s))) + +-------------------------------------------------------------------------------- + +type SpaceballMotionCallback = + SpaceballMotion -> SpaceballMotion -> SpaceballMotion -> IO () + +setSpaceballMotionCallback :: Maybe SpaceballMotionCallback -> IO () +setSpaceballMotionCallback = + setCallback SpaceballMotionCB glutSpaceballMotionFunc + (makeSpaceballMotionFunc . unmarshal) + where unmarshal cb x y z = + cb (fromIntegral x) (fromIntegral y) (fromIntegral z) + +-------------------------------------------------------------------------------- + +type SpaceballRotationCallback = + SpaceballRotation -> SpaceballRotation -> SpaceballRotation -> IO () + +setSpaceballRotationCallback :: Maybe SpaceballRotationCallback -> IO () +setSpaceballRotationCallback = + setCallback SpaceballRotateCB glutSpaceballRotateFunc + (makeSpaceballRotateFunc . unmarshal) + where unmarshal cb x y z = + cb (fromIntegral x) (fromIntegral y) (fromIntegral z) + +-------------------------------------------------------------------------------- + +type SpaceballButtonCallback = ButtonIndex -> KeyState -> IO () + +setSpaceballButtonCallback :: Maybe SpaceballButtonCallback -> IO () +setSpaceballButtonCallback = + setCallback SpaceballButtonCB glutSpaceballButtonFunc + (makeSpaceballButtonFunc . unmarshal) + where unmarshal cb b s = cb (fromIntegral b) (unmarshalKeyState s) + +-------------------------------------------------------------------------------- + +-- | The index of a specific dial of a dial and button box. + +type DialIndex = Int + +-- | The dial & button box state has changed. + +data DialAndButtonBoxInput + = DialAndButtonBoxButton ButtonIndex KeyState + | DialAndButtonBoxDial DialIndex Int + deriving ( Eq, Ord, Show ) + +-- | A dial & button box callback + +type DialAndButtonBoxCallback = DialAndButtonBoxInput -> IO () + +-- | Controls the dial & button box callback for the /current window./ The dial +-- & button box button callback for a window is called when the window has dial +-- & button box input focus (normally, when the mouse is in the window) and the +-- user generates dial & button box button presses or dial changes. The number +-- of available dial & button box buttons and dials can be determined with +-- 'Graphics.UI.GLUT.State.numDialsAndButtons'. +-- +-- Registering a dial & button box callback when a dial & button box device is +-- not available is ineffectual and not an error. In this case, no dial & button +-- box button will be generated. + +dialAndButtonBoxCallback :: SettableStateVar (Maybe DialAndButtonBoxCallback) +dialAndButtonBoxCallback = makeSettableStateVar setDialAndButtonBoxCallback + +setDialAndButtonBoxCallback :: Maybe DialAndButtonBoxCallback -> IO () +setDialAndButtonBoxCallback Nothing = do + setButtonBoxCallback Nothing + setDialsCallback Nothing +setDialAndButtonBoxCallback (Just cb) = do + setButtonBoxCallback (Just (\b s -> cb (DialAndButtonBoxButton b s))) + setDialsCallback (Just (\d x -> cb (DialAndButtonBoxDial d x))) + +-------------------------------------------------------------------------------- + +type ButtonBoxCallback = ButtonIndex -> KeyState -> IO () + +setButtonBoxCallback :: Maybe ButtonBoxCallback -> IO () +setButtonBoxCallback = + setCallback ButtonBoxCB glutButtonBoxFunc (makeButtonBoxFunc . unmarshal) + where unmarshal cb b s = cb (fromIntegral b) (unmarshalKeyState s) + +-------------------------------------------------------------------------------- + +type DialsCallback = DialIndex -> Int -> IO () + +setDialsCallback :: Maybe DialsCallback -> IO () +setDialsCallback = + setCallback DialsCB glutDialsFunc (makeDialsFunc . unmarshal) + where unmarshal cb d x = cb (fromIntegral d) (fromIntegral x) + +-------------------------------------------------------------------------------- + +-- | Absolute tablet position, with coordinates normalized to be in the range of +-- 0 to 2000 inclusive + +data TabletPosition = TabletPosition Int Int + deriving ( Eq, Ord, Show ) + +-- | The table state has changed. + +data TabletInput + = TabletMotion + | TabletButton ButtonIndex KeyState + deriving ( Eq, Ord, Show ) + +-- | A tablet callback + +type TabletCallback = TabletInput -> TabletPosition -> IO () + +-- | Controls the tablet callback for the /current window./ The tablet callback +-- for a window is called when the window has tablet input focus (normally, when +-- the mouse is in the window) and the user generates tablet motion or button +-- presses. The number of available tablet buttons can be determined with +-- 'Graphics.UI.GLUT.State.numTabletButtons'. +-- +-- Registering a tablet callback when a tablet device is not available is +-- ineffectual and not an error. In this case, no tablet callbacks will be +-- generated. + +tabletCallback :: SettableStateVar (Maybe TabletCallback) +tabletCallback = makeSettableStateVar setTabletCallback + +setTabletCallback :: Maybe TabletCallback -> IO () +setTabletCallback Nothing = do + setTabletMotionCallback Nothing + setTabletButtonCallback Nothing +setTabletCallback (Just cb) = do + setTabletMotionCallback (Just (\p -> cb TabletMotion p)) + setTabletButtonCallback (Just (\b s p -> cb (TabletButton b s) p)) + +-------------------------------------------------------------------------------- + +type TabletMotionCallback = TabletPosition -> IO () + +setTabletMotionCallback :: Maybe TabletMotionCallback -> IO () +setTabletMotionCallback = + setCallback TabletMotionCB glutTabletMotionFunc + (makeTabletMotionFunc . unmarshal) + where unmarshal cb x y = + cb (TabletPosition (fromIntegral x) (fromIntegral y)) + +-------------------------------------------------------------------------------- + +type TabletButtonCallback = ButtonIndex -> KeyState -> TabletPosition -> IO () + +setTabletButtonCallback :: Maybe TabletButtonCallback -> IO () +setTabletButtonCallback = + setCallback TabletButtonCB glutTabletButtonFunc + (makeTabletButtonFunc . unmarshal) + where unmarshal cb b s x y = + cb (fromIntegral b) (unmarshalKeyState s) + (TabletPosition (fromIntegral x) (fromIntegral y)) + +-------------------------------------------------------------------------------- + +-- | The state of the joystick buttons + +data JoystickButtons = JoystickButtons { + joystickButtonA, joystickButtonB, + joystickButtonC, joystickButtonD :: KeyState } + deriving ( Eq, Ord, Show ) + +-- Could use fromBitfield + Enum/Bounded instances + unmarshalJoystickButton +-- instead... +unmarshalJoystickButtons :: CUInt -> JoystickButtons +unmarshalJoystickButtons m = JoystickButtons { + joystickButtonA = if (m .&. glut_JOYSTICK_BUTTON_A) /= 0 then Down else Up, + joystickButtonB = if (m .&. glut_JOYSTICK_BUTTON_B) /= 0 then Down else Up, + joystickButtonC = if (m .&. glut_JOYSTICK_BUTTON_C) /= 0 then Down else Up, + joystickButtonD = if (m .&. glut_JOYSTICK_BUTTON_D) /= 0 then Down else Up } + +-------------------------------------------------------------------------------- + +-- | Absolute joystick position, with coordinates normalized to be in the range +-- of -1000 to 1000 inclusive. The signs of the three axes mean the following: +-- +-- * negative = left, positive = right +-- +-- * negative = towards player, positive = away +-- +-- * if available (e.g. rudder): negative = down, positive = up + +data JoystickPosition = JoystickPosition Int Int Int + deriving ( Eq, Ord, Show ) + +-------------------------------------------------------------------------------- + +-- | A joystick callback + +type JoystickCallback = JoystickButtons -> JoystickPosition -> IO () + +-- | Controls the joystick callback for the /current window./ The joystick +-- callback is called either due to polling of the joystick at the uniform timer +-- interval specified (if > 0) or in response to an explicit call of +-- 'Graphics.UI.GLUT.DeviceControl.forceJoystickCallback'. +-- +-- /X Implementation Notes:/ Currently GLUT has no joystick support for X11. + +-- joystickCallback :: SettableStateVar (Maybe JoystickCallback, PollRate) +joystickCallback :: SettableStateVar (Maybe (JoystickCallback, PollRate)) +joystickCallback = + makeSettableStateVar $ \maybeCBAndRate -> + setCallback JoystickCB + (\f -> glutJoystickFunc f (fromIntegral (snd (fromJust maybeCBAndRate)))) + (makeJoystickFunc . unmarshal) + (fmap fst maybeCBAndRate) + where unmarshal cb b x y z = cb (unmarshalJoystickButtons b) + (JoystickPosition (fromIntegral x) + (fromIntegral y) + (fromIntegral z)) + +-------------------------------------------------------------------------------- + +-- | A description where the multi-touch event is coming from, the freeglut +-- specs are very vague about the actual semantics. It contains the device ID +-- and\/or the cursor\/finger ID. + +type TouchID = Int + +-- | A multi-touch variant of 'MouseCallback'. + +type MultiMouseCallback = TouchID -> MouseCallback + +-- | (/freeglut only/) A multi-touch variant of 'mouseCallback'. + +multiMouseCallback :: SettableStateVar (Maybe MultiMouseCallback) +multiMouseCallback = makeSettableStateVar $ + setCallback MultiButtonCB glutMultiButtonFunc (makeMultiButtonFunc . unmarshal) + where unmarshal cb d x y b s = cb (fromIntegral d) + (unmarshalMouseButton b) + (unmarshalKeyState s) + (Position (fromIntegral x) (fromIntegral y)) + +-- | A multi-touch variant of 'CrossingCallback'. + +type MultiCrossingCallback = TouchID -> CrossingCallback + +-- | (/freeglut only/) A multi-touch variant of 'crossingCallback'. + +multiCrossingCallback :: SettableStateVar (Maybe MultiCrossingCallback) +multiCrossingCallback = makeSettableStateVar $ + setCallback MultiEntryCB glutMultiEntryFunc (makeMultiEntryFunc . unmarshal) + where unmarshal cb d c = cb (fromIntegral d) (unmarshalCrossing c) + +-- | A multi-touch variant of 'MotionCallback'. + +type MultiMotionCallback = TouchID -> MotionCallback + +-- | (/freeglut only/) A multi-touch variant of 'motionCallback'. + +multiMotionCallback :: SettableStateVar (Maybe MultiMotionCallback) +multiMotionCallback = makeSettableStateVar $ + setCallback MultiMotionCB glutMultiMotionFunc (makeMultiMotionFunc . unmarshal) + where unmarshal cb d x y = + cb (fromIntegral d) (Position (fromIntegral x) (fromIntegral y)) + +-- | (/freeglut only/) A multi-touch variant of 'passiveMotionCallback'. + +multiPassiveMotionCallback :: SettableStateVar (Maybe MultiMotionCallback) +multiPassiveMotionCallback = makeSettableStateVar $ + setCallback MultiPassiveCB glutMultiPassiveFunc (makeMultiPassiveFunc . unmarshal) + where unmarshal cb d x y = + cb (fromIntegral d) (Position (fromIntegral x) (fromIntegral y)) diff --git a/src/Graphics/UI/GLUT/Colormap.hs b/src/Graphics/UI/GLUT/Colormap.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Colormap.hs @@ -0,0 +1,112 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Colormap +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- OpenGL supports both RGBA and color index rendering. The RGBA mode is +-- generally preferable to color index because more OpenGL rendering +-- capabilities are available and color index mode requires the loading of +-- colormap entries. +-- +-- The GLUT color index state variables are used to read and write entries in a +-- window\'s color index colormap. Every GLUT color index window has its own +-- logical color index colormap. The size of a window\'s colormap can be +-- determined by reading 'numColorMapEntries'. +-- +-- GLUT color index windows within a program can attempt to share colormap +-- resources by copying a single color index colormap to multiple windows using +-- 'copyColormap'. If possible GLUT will attempt to share the actual colormap. +-- While copying colormaps using 'copyColormap' can potentially allow sharing of +-- physical colormap resources, logically each window has its own colormap. So +-- changing a copied colormap of a window will force the duplication of the +-- colormap. For this reason, color index programs should generally load a +-- single color index colormap, copy it to all color index windows within the +-- program, and then not modify any colormap cells. +-- +-- Use of multiple colormaps is likely to result in colormap installation +-- problems where some windows are displayed with an incorrect colormap due to +-- limitations on colormap resources. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Colormap ( + colorMapEntry, + copyColormap, + numColorMapEntries, + transparentIndex +) where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.StateVar ( GettableStateVar, makeGettableStateVar, StateVar, makeStateVar ) +import Foreign.C.Types ( CInt ) +import Graphics.Rendering.OpenGL.GL.VertexSpec ( Index1(..), Color3(..) ) +import Graphics.Rendering.OpenGL ( GLint, GLfloat ) + +import Graphics.UI.GLUT.QueryUtils +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.Types + +-------------------------------------------------------------------------------- + +-- | Controls the color index colormap entry of the /current window/\'s logical +-- colormap for the /layer in use/. The /layer in use/ of the /current window/ +-- should be a color index window. The color index should be zero or greater and +-- less than the total number of colormap entries for the window (see +-- 'numColorMapEntries') and different from an overlay\'s transparent index (see +-- 'transparentIndex'). +-- +-- If the /layer in use/\'s colormap was copied by reference, setting a colormap +-- entry will force the duplication of the colormap. + +colorMapEntry :: Index1 GLint -> StateVar (Color3 GLfloat) +colorMapEntry (Index1 cell) = + makeStateVar (getColorMapEntry (fromIntegral cell)) + (setColorMapEntry (fromIntegral cell)) + +setColorMapEntry :: CInt -> Color3 GLfloat -> IO () +setColorMapEntry cell (Color3 r g b) = glutSetColor cell r g b + +getColorMapEntry :: CInt -> IO (Color3 GLfloat) +getColorMapEntry cell = do + r <- glutGetColor cell glut_RED + g <- glutGetColor cell glut_GREEN + b <- glutGetColor cell glut_BLUE + return $ Color3 r g b + +-------------------------------------------------------------------------------- + +-- | Copy (lazily if possible to promote sharing) the logical colormap from a +-- specified window to the /current window/\'s /layer in use/. The copy will be +-- from the normal plane to the normal plane; or from the overlay to the overlay +-- (never across different layers). Once a colormap has been copied, avoid +-- setting cells in the colormap via 'colorMapEntry' since that will force an +-- actual copy of the colormap if it was previously copied by reference. +-- 'copyColormap' should only be called when both the /current window/ and the +-- specified window are color index windows. + +copyColormap :: MonadIO m => Window -> m () +copyColormap (Window win) = glutCopyColormap win + +-------------------------------------------------------------------------------- + +-- | Contains the number of entries in the colormap of the /current window/\'s +-- current layer (0 in RGBA mode). + +numColorMapEntries :: GettableStateVar GLint +numColorMapEntries = + makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_COLORMAP_SIZE + +-------------------------------------------------------------------------------- + +-- | Contains the transparent color index of the overlay of the /current window/ +-- or -1 if no overlay is in use. + +transparentIndex :: GettableStateVar (Index1 GLint) +transparentIndex = + makeGettableStateVar $ + layerGet (Index1 . fromIntegral) glut_TRANSPARENT_INDEX diff --git a/src/Graphics/UI/GLUT/Debugging.hs b/src/Graphics/UI/GLUT/Debugging.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Debugging.hs @@ -0,0 +1,39 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Debugging +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- This module contains a simple utility routine to report any pending GL +-- errors. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Debugging ( + reportErrors +) where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.StateVar ( get ) +import Graphics.Rendering.OpenGL ( Error(..), errors ) +import System.Environment ( getProgName ) +import System.IO ( hPutStrLn, stderr ) + +-------------------------------------------------------------------------------- + +-- | Report any pending GL errors to stderr (which is typically the console). +-- If there are no pending errors, this routine does nothing. Note that the +-- error flags are reset after this action, i.e. there are no pending errors +-- left afterwards. + +reportErrors :: MonadIO m => m () +reportErrors = get errors >>= mapM_ reportError + +reportError :: MonadIO m => Error -> m () +reportError (Error _ msg) = liftIO $ do + pn <- getProgName + hPutStrLn stderr ("GLUT: Warning in " ++ pn ++ ": GL error: " ++ msg) diff --git a/src/Graphics/UI/GLUT/DeviceControl.hs b/src/Graphics/UI/GLUT/DeviceControl.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/DeviceControl.hs @@ -0,0 +1,124 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.DeviceControl +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- GLUT offers some routines for controlling the key repeat and polling the +-- joystick. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.DeviceControl ( + GlobalKeyRepeat(..), globalKeyRepeat, + PerWindowKeyRepeat(..), perWindowKeyRepeat, + forceJoystickCallback +) where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.StateVar ( StateVar, makeStateVar ) +import Foreign.C.Types ( CInt ) + +import Graphics.UI.GLUT.QueryUtils +import Graphics.UI.GLUT.Raw + +-------------------------------------------------------------------------------- + +-- | The state of the global key repeat + +data GlobalKeyRepeat + = GlobalKeyRepeatOff + | GlobalKeyRepeatOn + | GlobalKeyRepeatDefault + deriving ( Eq, Ord, Show ) + +marshalGlobalKeyRepeat :: GlobalKeyRepeat -> CInt +marshalGlobalKeyRepeat x = case x of + GlobalKeyRepeatOff -> glut_KEY_REPEAT_OFF + GlobalKeyRepeatOn -> glut_KEY_REPEAT_ON + GlobalKeyRepeatDefault -> glut_KEY_REPEAT_DEFAULT + +unmarshalGlobalKeyRepeat :: CInt -> GlobalKeyRepeat +unmarshalGlobalKeyRepeat x + | x == glut_KEY_REPEAT_OFF = GlobalKeyRepeatOff + | x == glut_KEY_REPEAT_ON = GlobalKeyRepeatOn + | x == glut_KEY_REPEAT_DEFAULT = GlobalKeyRepeatDefault + | otherwise = error ("unmarshalGlobalKeyRepeat: illegal value " ++ show x) + +-------------------------------------------------------------------------------- + +-- | Controls the key repeat mode for the window system on a global basis if +-- possible. If supported by the window system, the key repeat can either be +-- disabled, enabled, or set to the window system\'s default key repeat state. +-- +-- /X Implementation Notes:/ X11 sends @KeyPress@ events repeatedly when the +-- window system\'s global auto repeat is enabled. 'perWindowKeyRepeat' can +-- prevent these auto repeated keystrokes from being reported as keyboard or +-- special callbacks, but there is still some minimal overhead by the X server +-- to continually stream @KeyPress@ events to the GLUT application. The +-- 'globalKeyRepeat' state variable can be used to actually disable the global +-- sending of auto repeated @KeyPress@ events. Note that 'globalKeyRepeat' +-- affects the global window system auto repeat state so other applications +-- will not auto repeat if you disable auto repeat globally through +-- 'globalKeyRepeat'. GLUT applications using the X11 GLUT implementation +-- should disable key repeat with 'globalKeyRepeat' to disable key repeats most +-- efficiently, but are responsible for explicitly restoring the default key +-- repeat state on exit. +-- +-- /Win32 Implementation Notes:/ The Win32 implementation of 'globalKeyRepeat' +-- does nothing. The 'perWindowKeyRepeat' can be used in the Win32 GLUT +-- implementation to ignore repeated keys on a per-window basis without changing +-- the global window system key repeat. + +globalKeyRepeat :: StateVar GlobalKeyRepeat +globalKeyRepeat = + makeStateVar (deviceGet unmarshalGlobalKeyRepeat glut_DEVICE_KEY_REPEAT) + (glutSetKeyRepeat . marshalGlobalKeyRepeat) + +-------------------------------------------------------------------------------- + +-- | The state of the per-window key repeat + +data PerWindowKeyRepeat + = PerWindowKeyRepeatOff + | PerWindowKeyRepeatOn + deriving ( Eq, Ord, Show ) + +marshalPerWindowKeyRepeat :: PerWindowKeyRepeat -> CInt +marshalPerWindowKeyRepeat x = case x of + PerWindowKeyRepeatOn -> 0 + PerWindowKeyRepeatOff -> 1 + +unmarshalPerWindowKeyRepeat :: CInt -> PerWindowKeyRepeat +unmarshalPerWindowKeyRepeat x + | x == 0 = PerWindowKeyRepeatOn + | otherwise = PerWindowKeyRepeatOff + +-------------------------------------------------------------------------------- + +-- | Controls if auto repeat keystrokes are reported to the /current window./ +-- Ignoring auto repeated keystrokes is generally done in conjunction with using +-- the 'Graphics.UI.GLUT.Callbacks.Window.keyboardMouseCallback'. If you do +-- not ignore auto repeated keystrokes, your GLUT application will experience +-- repeated release\/press callbacks. Games using the keyboard will typically +-- want to ignore key repeat. + +perWindowKeyRepeat :: StateVar PerWindowKeyRepeat +perWindowKeyRepeat = + makeStateVar + (deviceGet unmarshalPerWindowKeyRepeat glut_DEVICE_IGNORE_KEY_REPEAT) + (glutIgnoreKeyRepeat . marshalPerWindowKeyRepeat) + +-------------------------------------------------------------------------------- + +-- | Execute the joystick callback set by +-- 'Graphics.UI.GLUT.Callbacks.Window.joystickCallback' once (if one exists). +-- This is done in a synchronous fashion within the current context, i.e. when +-- 'forceJoystickCallback' returns, the callback will have already happened. + +forceJoystickCallback :: MonadIO m => m () +forceJoystickCallback = glutForceJoystickFunc diff --git a/src/Graphics/UI/GLUT/Fonts.hs b/src/Graphics/UI/GLUT/Fonts.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Fonts.hs @@ -0,0 +1,128 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Fonts +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- GLUT supports two types of font rendering: stroke fonts, meaning each +-- character is rendered as a set of line segments; and bitmap fonts, where each +-- character is a bitmap generated with +-- 'Graphics.Rendering.OpenGL.GL.Bitmaps.bitmap'. Stroke fonts have the +-- advantage that because they are geometry, they can be arbitrarily scale and +-- rendered. Bitmap fonts are less flexible since they are rendered as bitmaps +-- but are usually faster than stroke fonts. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Fonts ( + Font(..), BitmapFont(..), StrokeFont(..), +) where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.Char ( ord ) +import Foreign.C.String ( withCString ) +import Foreign.C.Types ( CInt ) +import Foreign.Ptr ( castPtr ) +import Graphics.Rendering.OpenGL ( GLint, GLfloat ) + +import Graphics.UI.GLUT.Raw + +-------------------------------------------------------------------------------- + +class Font a where + -- | Render the string in the named font, without using any display lists. + -- Rendering a nonexistent character has no effect. + -- + -- If the font is a bitmap font, 'renderString' automatically sets the OpenGL + -- unpack pixel storage modes it needs appropriately and saves and restores + -- the previous modes before returning. The generated call to + -- 'Graphics.Rendering.OpenGL.GL.bitmap' will adjust the current raster + -- position based on the width of the string. + -- If the font is a stroke font, + -- 'Graphics.Rendering.OpenGL.GL.CoordTrans.translate' is used to translate + -- the current model view matrix to advance the width of the string. + + renderString :: MonadIO m => a -> String -> m () + + -- | For a bitmap font, return the width in pixels of a string. For a stroke + -- font, return the width in units. While the width of characters in a font + -- may vary (though fixed width fonts do not vary), the maximum height + -- characteristics of a particular font are fixed. + + stringWidth :: MonadIO m => a -> String -> m GLint + + -- | (/freeglut only/) For a bitmap font, return the maximum height of the + -- characters in the given font measured in pixels. For a stroke font, + -- return the height in units. + + fontHeight :: MonadIO m => a -> m GLfloat + +instance Font BitmapFont where + renderString = bitmapString + stringWidth = bitmapLength + fontHeight = bitmapHeight + + +instance Font StrokeFont where + renderString = strokeString + stringWidth = strokeLength + fontHeight = strokeHeight + +-------------------------------------------------------------------------------- + +bitmapString :: MonadIO m => BitmapFont -> String -> m () +bitmapString f s = do + i <- marshalBitmapFont f + mapM_ (\c -> withChar c (glutBitmapCharacter i)) s + +withChar :: Char -> (CInt -> m a) -> m a +withChar c f = f . fromIntegral . ord $ c + +-------------------------------------------------------------------------------- + +strokeString :: MonadIO m => StrokeFont -> String -> m () +strokeString f s = do + i <- marshalStrokeFont f + mapM_ (\c -> withChar c (glutStrokeCharacter i)) s + +-------------------------------------------------------------------------------- + +bitmapLength :: MonadIO m + => BitmapFont -- ^ Bitmap font to use. + -> String -- ^ String to return width of (not confined to 8 + -- bits). + -> m GLint -- ^ Width in pixels. +bitmapLength f s = liftIO $ do + i <- marshalBitmapFont f + fmap fromIntegral $ withCString s (glutBitmapLength i . castPtr) + +-------------------------------------------------------------------------------- + +strokeLength :: MonadIO m + => StrokeFont -- ^ Stroke font to use. + -> String -- ^ String to return width of (not confined to 8 + -- bits). + -> m GLint -- ^ Width in units. +strokeLength f s = liftIO $ do + i <- marshalStrokeFont f + fmap fromIntegral $ withCString s (glutStrokeLength i . castPtr) + +-------------------------------------------------------------------------------- + +bitmapHeight :: MonadIO m + => BitmapFont -- ^ Bitmap font to use. + -> m GLfloat -- ^ Height in pixels. +bitmapHeight f = liftIO $ do + i <- marshalBitmapFont f + fromIntegral `fmap` glutBitmapHeight i + +-------------------------------------------------------------------------------- + +strokeHeight :: MonadIO m + => StrokeFont -- ^ Stroke font to use. + -> m GLfloat -- ^ Height in units. +strokeHeight f = glutStrokeHeight =<< marshalStrokeFont f diff --git a/src/Graphics/UI/GLUT/GameMode.hs b/src/Graphics/UI/GLUT/GameMode.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/GameMode.hs @@ -0,0 +1,193 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.GameMode +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- In addition to the functionality offered by +-- 'Graphics.UI.GLUT.Window.fullScreen', GLUT offers an sub-API to change the +-- screen resolution, color depth, and refresh rate of the display for a single +-- full screen window. This mode of operation is called /game mode/, and is +-- restricted in various ways: No pop-up menus are allowed for this full screen +-- window, no other (sub-)windows can be created, and all other applications are +-- hidden. +-- +-- /X Implementation Notes:/ Note that game mode is not fully supported in the +-- original GLUT for X, it is essentially the same as using +-- 'Graphics.UI.GLUT.Window.fullScreen'. The GLUT clone freeglut +-- (see ) does not have this restriction. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.GameMode ( + GameModeCapability(..), GameModeCapabilityDescription(..), + gameModeCapabilities, enterGameMode, leaveGameMode, + BitsPerPlane, RefreshRate, GameModeInfo(..), gameModeInfo, + gameModeActive +) where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.List ( intersperse ) +import Data.StateVar ( GettableStateVar, makeGettableStateVar + , SettableStateVar, makeSettableStateVar ) +import Foreign.C.String ( withCString ) +import Graphics.Rendering.OpenGL ( Size(..), GLenum ) + +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.Types + +-------------------------------------------------------------------------------- + +-- | Capabilities for 'gameModeCapabilities' + +data GameModeCapability + = GameModeWidth -- ^ Width of the screen resolution in pixels + | GameModeHeight -- ^ Height of the screen resolution in pixels + | GameModeBitsPerPlane -- ^ Color depth of the screen in bits + | GameModeRefreshRate -- ^ Refresh rate in Hertz + | GameModeNum -- ^ Match the Nth frame buffer configuration + -- compatible with the given capabilities + -- (numbering starts at 1) + deriving ( Eq, Ord, Show ) + +gameModeCapabilityToString :: GameModeCapability -> String +gameModeCapabilityToString x = case x of + GameModeWidth -> "width" + GameModeHeight -> "height" + GameModeBitsPerPlane -> "bpp" + GameModeRefreshRate -> "hertz" + GameModeNum -> "num" + +-- | A single capability description for 'gameModeCapabilities'. + +data GameModeCapabilityDescription = Where' GameModeCapability Relation Int + deriving ( Eq, Ord, Show ) + +gameModeCapabilityDescriptionToString :: GameModeCapabilityDescription -> String +gameModeCapabilityDescriptionToString (Where' c r i) = + gameModeCapabilityToString c ++ relationToString r ++ show i + +-------------------------------------------------------------------------------- + +-- | Controls the /game mode/ to be used when 'enterGameMode' is called. It is +-- described by a list of zero or more capability descriptions, which are +-- translated into a set of criteria used to select the appropriate screen +-- configuration. The criteria are matched in strict left to right order of +-- precdence. That is, the first specified criterion (leftmost) takes precedence +-- over the later criteria for non-exact criteria +-- ('Graphics.UI.GLUT.Initialization.IsGreaterThan', +-- 'Graphics.UI.GLUT.Initialization.IsLessThan', etc.). Exact criteria +-- ('Graphics.UI.GLUT.Initialization.IsEqualTo', +-- 'Graphics.UI.GLUT.Initialization.IsNotEqualTo') must match exactly so +-- precedence is not relevant. +-- +-- To determine which configuration will actually be tried by 'enterGameMode' +-- (if any), use 'gameModeInfo'. +-- +-- Note that even for game mode the current values of +-- 'Graphics.UI.GLUT.Initialization.initialDisplayMode'or +-- 'Graphics.UI.GLUT.Initialization.initialDisplayCapabilities' will +-- determine which buffers are available, if double buffering is used or not, +-- etc. + +gameModeCapabilities :: SettableStateVar [GameModeCapabilityDescription] +gameModeCapabilities = makeSettableStateVar $ \ds -> + withCString (descriptionsToString ds) glutGameModeString + +-- freeglut currently handles only simple game mode descriptions like "WxH:B@R", +-- so we try hard to use this format instead of the more general format allowed +-- by the "real" GLUT. +descriptionsToString :: [GameModeCapabilityDescription] -> String +descriptionsToString ds = + let ws = [ x | Where' GameModeWidth IsEqualTo x <- ds ] + hs = [ x | Where' GameModeHeight IsEqualTo x <- ds ] + bs = [ x | Where' GameModeBitsPerPlane IsEqualTo x <- ds ] + rs = [ x | Where' GameModeRefreshRate IsEqualTo x <- ds ] + allSimple = (length ws + length hs + length bs + length rs) == (length ds) + dimensionsOK = (null ws) == (null hs) + in if allSimple && dimensionsOK + then simpleCapStr ws hs bs rs + else generalCapStr ds + +simpleCapStr :: [Int] -> [Int] -> [Int] -> [Int] -> String +simpleCapStr ws hs bs rs = + showCap "" ws ++ showCap "x" hs ++ showCap ":" bs ++ showCap "@" rs + where showCap _ [] = "" + showCap prefix (x:_) = prefix ++ show x + +generalCapStr :: [GameModeCapabilityDescription] -> String +generalCapStr = + concat . intersperse " " . map gameModeCapabilityDescriptionToString + +-------------------------------------------------------------------------------- + +-- | Enter /game mode/, trying to change resolution, refresh rate, etc., as +-- specified by the current value of 'gameModeCapabilities'. An identifier for +-- the game mode window and a flag, indicating if the display mode actually +-- changed, are returned. The game mode window is made the /current window/. +-- +-- Re-entering /game mode/ is allowed, the previous game mode window gets +-- destroyed by this, and a new one is created. + +enterGameMode :: MonadIO m => m (Window, Bool) +enterGameMode = do + w <- glutEnterGameMode + c <- getBool glut_GAME_MODE_DISPLAY_CHANGED + return (Window w, c) + +-------------------------------------------------------------------------------- + +-- | Leave /game mode/, restoring the old display mode and destroying the game +-- mode window. + +leaveGameMode :: MonadIO m => m () +leaveGameMode = glutLeaveGameMode + +-------------------------------------------------------------------------------- + +-- | The color depth of the screen, measured in bits (e.g. 8, 16, 24, 32, ...) + +type BitsPerPlane = Int + +-- | The refresh rate of the screen, measured in Hertz (e.g. 60, 75, 100, ...) + +type RefreshRate = Int + +data GameModeInfo = GameModeInfo Size BitsPerPlane RefreshRate + deriving ( Eq, Ord, Show ) + +-------------------------------------------------------------------------------- + +-- | Return 'Just' the mode which would be tried by the next call to +-- 'enterGameMode'. Returns 'Nothing' if the mode requested by the current value +-- of 'gameModeCapabilities' is not possible, in which case 'enterGameMode' +-- would simply create a full screen window using the current mode. + +gameModeInfo :: GettableStateVar (Maybe GameModeInfo) +gameModeInfo = makeGettableStateVar $ do + possible <- getBool glut_GAME_MODE_POSSIBLE + if possible + then do + w <- glutGameModeGet glut_GAME_MODE_WIDTH + h <- glutGameModeGet glut_GAME_MODE_HEIGHT + let size = Size (fromIntegral w) (fromIntegral h) + b <- glutGameModeGet glut_GAME_MODE_PIXEL_DEPTH + r <- glutGameModeGet glut_GAME_MODE_REFRESH_RATE + return $ Just $ GameModeInfo size (fromIntegral b) (fromIntegral r) + else return Nothing + +getBool :: MonadIO m => GLenum -> m Bool +getBool x = do + val <- glutGameModeGet x + return $ val /= 0 + +-------------------------------------------------------------------------------- + +-- | Contains 'True' when the /game mode/ is active, 'False' otherwise. + +gameModeActive :: GettableStateVar Bool +gameModeActive = makeGettableStateVar $ getBool glut_GAME_MODE_ACTIVE diff --git a/src/Graphics/UI/GLUT/Initialization.hs b/src/Graphics/UI/GLUT/Initialization.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Initialization.hs @@ -0,0 +1,773 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Initialization +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- Actions and state variables in this module are used to initialize GLUT state. +-- The primary initialization routine is 'initialize', which should only be +-- called exactly once in a GLUT program. No other GLUT or OpenGL actions should +-- be called before 'initialize', apart from getting or setting the state +-- variables in this module. +-- +-- The reason is that these state variables can be used to set default window +-- initialization state that might be modified by the command processing done in +-- 'initialize'. For example, 'initialWindowSize' can be set to @('Size' +-- 400 400)@ before 'initialize' is called to indicate 400 by 400 is the +-- program\'s default window size. Setting the initial window size or position +-- before 'initialize' allows the GLUT program user to specify the initial size +-- or position using command line arguments. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Initialization ( + -- * Primary initialization + initialize, getArgsAndInitialize, exit, + + -- * Initial window geometry + initialWindowPosition, initialWindowSize, + + -- * Setting the initial display mode (I) + DisplayMode(..), initialDisplayMode, displayModePossible, + + -- * Setting the initial display mode (II) + DisplayCapability(..), Relation(..), DisplayCapabilityDescription(..), + initialDisplayCapabilities, + + -- * Controlling the creation of rendering contexts + RenderingContext(..), renderingContext, + + -- * Direct\/indirect rendering + DirectRendering(..), directRendering, + + -- * OpenGL 3.x context support + initialContextVersion, ContextFlag(..), initialContextFlags, + ContextProfile(..), initialContextProfile +) where + +import Control.Monad ( when ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.Bits ( Bits(..) ) +import Data.List ( genericLength, intersperse, mapAccumR ) +import Data.StateVar ( get, ($=), GettableStateVar, makeGettableStateVar + , SettableStateVar, makeSettableStateVar, StateVar, makeStateVar ) +import Foreign.C.String ( peekCString, withCString ) +import Foreign.C.Types ( CInt, CUInt ) +import Foreign.Marshal.Array ( peekArray, withArray0 ) +import Foreign.Marshal.Utils ( with, withMany ) +import Foreign.Ptr ( nullPtr ) +import Foreign.Storable ( peek ) +import Graphics.Rendering.OpenGL ( Position(..), Size(..) ) +import System.Environment ( getArgs, getProgName ) + +import Graphics.UI.GLUT.QueryUtils +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.Types + +-------------------------------------------------------------------------------- + +-- | Given the program name and command line arguments, initialize the GLUT +-- library and negotiate a session with the window system. During this +-- process, 'initialize' may cause the termination of the GLUT program with an +-- error message to the user if GLUT cannot be properly initialized. +-- Examples of this situation include the failure to connect to the window +-- system, the lack of window system support for OpenGL, and invalid command +-- line options. +-- +-- 'initialize' also processes command line options, but the specific options +-- parsed are window system dependent. Any command line arguments which are +-- not GLUT-specific are returned. +-- +-- /X Implementation Notes:/ The X Window System specific options parsed by +-- 'initialize' are as follows: +-- +-- * @-display /DISPLAY/@: Specify the X server to connect to. If not specified, +-- the value of the @DISPLAY@ environment variable is used. +-- +-- * @-geometry /WxH+X+Y/@: Determines where windows should be created on the +-- screen. The parameter following @-geometry@ should be formatted as a +-- standard X geometry specification. The effect of using this option is to +-- change the GLUT initial size and initial position the same as if +-- 'initialWindowSize' or 'initialWindowPosition' were modified directly. +-- +-- * @-iconic@: Requests all top-level windows be created in an iconic state. +-- +-- * @-indirect@: Force the use of indirect OpenGL rendering contexts. +-- +-- * @-direct@: Force the use of direct OpenGL rendering contexts (not all GLX +-- implementations support direct rendering contexts). A fatal error is +-- generated if direct rendering is not supported by the OpenGL +-- implementation. If neither @-indirect@ or @-direct@ are used to force a +-- particular behavior, GLUT will attempt to use direct rendering if +-- possible and otherwise fallback to indirect rendering. +-- +-- * @-gldebug@: After processing callbacks and\/or events, call +-- 'Graphics.UI.GLUT.Debugging.reportErrors' to check if there are any pending +-- OpenGL errors. Using this option is helpful in detecting OpenGL run-time +-- errors. +-- +-- * @-sync@: Enable synchronous X protocol transactions. This option makes +-- it easier to track down potential X protocol errors. + +initialize :: MonadIO m + => String -- ^ The program name. + -> [String] -- ^ The command line arguments + -> m [String] -- ^ Non-GLUT command line arguments +initialize prog args = liftIO $ + with (1 + genericLength args) $ \argcBuf -> + withMany withCString (prog : args) $ \argvPtrs -> + withArray0 nullPtr argvPtrs $ \argvBuf -> do + glutInit argcBuf argvBuf + newArgc <- peek argcBuf + newArgvPtrs <- peekArray (fromIntegral newArgc) argvBuf + newArgv <- mapM peekCString newArgvPtrs + return $ tail newArgv + +-- | Convenience action: Initialize GLUT, returning the program name and any +-- non-GLUT command line arguments. + +getArgsAndInitialize :: MonadIO m => m (String, [String]) +getArgsAndInitialize = liftIO $ do + prog <- getProgName + args <- getArgs + nonGLUTArgs <- initialize prog args + return (prog, nonGLUTArgs) + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) De-initialize GLUT. After this, one has to use +-- 'initialize' or 'getArgsAndInitialize' to initialize GLUT again. + +exit :: MonadIO m => m () +exit = glutExit + +-------------------------------------------------------------------------------- + +-- | Controls the /initial window position/. Windows created by +-- 'Graphics.UI.GLUT.Window.createWindow' will be requested to be created with +-- the current /initial window position/. The initial value of the /initial +-- window position/ GLUT state is @'Position' (-1) (-1)@. If either the X or Y +-- component of the /initial window position/ is negative, the actual window +-- position is left to the window system to determine. +-- +-- The intent of the /initial window position/ is to provide a suggestion to +-- the window system for a window\'s initial position. The window system is +-- not obligated to use this information. Therefore, GLUT programs should not +-- assume the window was created at the specified position. + +initialWindowPosition :: StateVar Position +initialWindowPosition = + makeStateVar getInitialWindowPosition setInitialWindowPosition + +getInitialWindowPosition :: IO Position +getInitialWindowPosition = do + x <- simpleGet fromIntegral glut_INIT_WINDOW_X + y <- simpleGet fromIntegral glut_INIT_WINDOW_Y + return $ Position x y + +setInitialWindowPosition :: Position -> IO () +setInitialWindowPosition (Position x y) = + glutInitWindowPosition (fromIntegral x) (fromIntegral y) + +-------------------------------------------------------------------------------- + +-- | Controls the /initial window size/. Windows created by +-- 'Graphics.UI.GLUT.Window.createWindow' will be requested to be created with +-- the current /initial window size/. The initial value of the /initial window +-- size/ GLUT state is @'Size' 300 300@. If either the width or the height +-- component of the /initial window size/ is non-positive, the actual window +-- size is left to the window system to determine. +-- +-- The intent of the /initial window size/ is to provide a suggestion to the +-- window system for a window\'s initial size. The window system is not +-- obligated to use this information. Therefore, GLUT programs should not +-- assume the window was created at the specified size. A GLUT program should +-- use the window\'s reshape callback to determine the true size of the +-- window. + +initialWindowSize :: StateVar Size +initialWindowSize = makeStateVar getInitialWindowSize setInitialWindowSize + +getInitialWindowSize :: IO Size +getInitialWindowSize = do + w <- simpleGet fromIntegral glut_INIT_WINDOW_WIDTH + h <- simpleGet fromIntegral glut_INIT_WINDOW_HEIGHT + return $ Size w h + +setInitialWindowSize :: Size -> IO () +setInitialWindowSize (Size w h) = + glutInitWindowSize (fromIntegral w) (fromIntegral h) + +-------------------------------------------------------------------------------- + +-- | A single aspect of a window which is to be created, used in conjunction +-- with 'initialDisplayMode'. + +data DisplayMode + = RGBAMode + -- ^ Select an RGBA mode window. This is the default if neither 'RGBAMode' + -- nor 'IndexMode' are specified. + | RGBMode + -- ^ An alias for 'RGBAMode'. + | IndexMode + -- ^ Select a color index mode window. This overrides 'RGBAMode' if it is + -- also specified. + | LuminanceMode + -- ^ Select a window with a \"luminance\" color model. This model provides + -- the functionality of OpenGL\'s RGBA color model, but the green and blue + -- components are not maintained in the frame buffer. Instead each pixel\'s + -- red component is converted to an index between zero and + -- 'Graphics.UI.GLUT.Colormap.numColorMapEntries' and looked up in a + -- per-window color map to determine the color of pixels within the window. + -- The initial colormap of 'LuminanceMode' windows is initialized to be a + -- linear gray ramp, but can be modified with GLUT\'s colormap actions. + -- /Implementation Notes:/ 'LuminanceMode' is not supported on most OpenGL + -- platforms. + | WithAlphaComponent + -- ^ Select a window with an alpha component to the color buffer(s). + | WithAccumBuffer + -- ^ Select a window with an accumulation buffer. + | WithDepthBuffer + -- ^ Select a window with a depth buffer. + | WithStencilBuffer + -- ^ Select a window with a stencil buffer. + | WithAuxBuffers Int + -- ^ (/freeglut only/) Select a window with /n/ (1 .. 4) auxiliary buffers. + -- Any /n/ outside the range 1 .. 4 is a fatal error. + | SingleBuffered + -- ^ Select a single buffered window. This is the default if neither + -- 'DoubleBuffered' nor 'SingleBuffered' are specified. + | DoubleBuffered + -- ^ Select a double buffered window. This overrides 'SingleBuffered' if it + -- is also specified. + | Multisampling + -- ^ Select a window with multisampling support. If multisampling is not + -- available, a non-multisampling window will automatically be chosen. + -- Note: both the OpenGL client-side and server-side implementations must + -- support the @GLX_SAMPLE_SGIS@ extension for multisampling to be + -- available. Deprecated, use 'WithSamplesPerPixel'. + | WithSamplesPerPixel Int + -- ^ Select a window with multisampling, using the given samples per pixel. + | Stereoscopic + -- ^ Select a stereo window. + | Captionless + -- ^ Select a window without a caption (/freeglut only/). + | Borderless + -- ^ Select a window without any borders (/freeglut only/). + | SRGBMode + -- ^ Select an sRGB mode window (/freeglut only/). + deriving ( Eq, Ord, Show ) + +marshalDisplayMode :: DisplayMode -> CUInt +marshalDisplayMode m = case m of + RGBAMode -> glut_RGBA + RGBMode -> glut_RGB + IndexMode -> glut_INDEX + LuminanceMode -> glut_LUMINANCE + WithAlphaComponent -> glut_ALPHA + WithAccumBuffer -> glut_ACCUM + WithDepthBuffer -> glut_DEPTH + WithStencilBuffer -> glut_STENCIL + WithAuxBuffers 1 -> glut_AUX1 + WithAuxBuffers 2 -> glut_AUX2 + WithAuxBuffers 3 -> glut_AUX3 + WithAuxBuffers 4 -> glut_AUX4 + WithAuxBuffers n -> + error ("marshalDisplayMode: illegal number of auxiliary buffers: " ++ show n) + SingleBuffered -> glut_SINGLE + DoubleBuffered -> glut_DOUBLE + Multisampling -> glut_MULTISAMPLE + WithSamplesPerPixel _ -> error ("marshalDisplayMode: this should not happen") + Stereoscopic -> glut_STEREO + Captionless -> glut_CAPTIONLESS + Borderless -> glut_BORDERLESS + SRGBMode -> glut_SRGB + +-------------------------------------------------------------------------------- + +-- | Controls the /initial display mode/ used when creating top-level windows, +-- subwindows, and overlays to determine the OpenGL display mode for the +-- to-be-created window or overlay. +-- +-- Note that 'RGBAMode' selects the RGBA color model, but it does not request any +-- bits of alpha (sometimes called an /alpha buffer/ or /destination alpha/) +-- be allocated. To request alpha, specify 'WithAlphaComponent'. The same +-- applies to 'LuminanceMode'. + +initialDisplayMode :: StateVar [DisplayMode] +initialDisplayMode = makeStateVar getInitialDisplayMode setInitialDisplayMode + +getInitialDisplayMode :: IO [DisplayMode] +getInitialDisplayMode = do + mode <- simpleGet fromIntegral glut_INIT_DISPLAY_MODE + let displayModes = i2dms (mode .&. complement glut_MULTISAMPLE) + if mode .&. glut_MULTISAMPLE == 0 + then return displayModes + else do + n <- get samplesPerPixel + return $ WithSamplesPerPixel n : displayModes + +i2dms :: CUInt -> [DisplayMode] +i2dms bitfield | IndexMode `elem` modes || LuminanceMode `elem` modes = modes + | otherwise = RGBAMode : modes + where modes = i2dmsWithoutRGBA bitfield + +i2dmsWithoutRGBA :: CUInt -> [DisplayMode] +i2dmsWithoutRGBA bitfield = + [ c | c <- [ IndexMode, LuminanceMode, WithAlphaComponent, + WithAccumBuffer, WithDepthBuffer, WithStencilBuffer, + WithAuxBuffers 1, WithAuxBuffers 2, WithAuxBuffers 3, + WithAuxBuffers 4, SingleBuffered, DoubleBuffered, Multisampling, + Stereoscopic, Captionless, Borderless, SRGBMode ] + , (bitfield .&. marshalDisplayMode c) /= 0 ] + +setInitialDisplayMode :: [DisplayMode] -> IO () +setInitialDisplayMode modes = do + let (spps, transformedModes) = mapAccumR handleMultisampling [] modes + mapM_ (samplesPerPixel $=) spps + glutInitDisplayMode (toBitfield marshalDisplayMode transformedModes) + +handleMultisampling :: [Int] -> DisplayMode -> ([Int], DisplayMode) +handleMultisampling spps (WithSamplesPerPixel spp) = (spp : spps, Multisampling) +handleMultisampling spps mode = (spps, mode) + +toBitfield :: (Num b, Bits b) => (a -> b) -> [a] -> b +toBitfield marshal = foldl (.|.) 0 . map marshal + +-- | Contains 'True' if the /current display mode/ is supported, 'False' +-- otherwise. + +displayModePossible :: GettableStateVar Bool +displayModePossible = + makeGettableStateVar $ simpleGet (/= 0) glut_DISPLAY_MODE_POSSIBLE + +-------------------------------------------------------------------------------- + +samplesPerPixel :: StateVar Int +samplesPerPixel = makeStateVar getSamplesPerPixel setSamplesPerPixel + +getSamplesPerPixel :: IO Int +getSamplesPerPixel = do + m <- multisamplingSupported + if m + then simpleGet fromIntegral (fromIntegral glut_MULTISAMPLE) + else return defaultSamplesPerPixels + +defaultSamplesPerPixels :: Int +defaultSamplesPerPixels = 4 + +setSamplesPerPixel :: Int -> IO () +setSamplesPerPixel spp = do + m <- multisamplingSupported + when m $ + glutSetOption (fromIntegral glut_MULTISAMPLE) (fromIntegral spp) + +multisamplingSupported :: IO Bool +multisamplingSupported = isKnown "glutGetModeValues" + +-------------------------------------------------------------------------------- + +-- | Capabilities for 'initialDisplayCapabilities', most of them are extensions +-- of the constructors of 'DisplayMode'. + +data DisplayCapability + = DisplayRGBA -- ^ Number of bits of red, green, blue, and alpha in the RGBA + -- color buffer. Default is \"'IsAtLeast' @1@\" for red, + -- green, blue, and alpha capabilities, and \"'IsEqualTo' + -- @1@\" for the RGBA color model capability. + | DisplayRGB -- ^ Number of bits of red, green, and blue in the RGBA color + -- buffer and zero bits of alpha color buffer precision. + -- Default is \"'IsAtLeast' @1@\" for the red, green, and + -- blue capabilities, and \"'IsNotLessThan' @0@\" for alpha + -- capability, and \"'IsEqualTo' @1@\" for the RGBA color + -- model capability. + | DisplayRed -- ^ Red color buffer precision in bits. Default is + -- \"'IsAtLeast' @1@\". + | DisplayGreen -- ^ Green color buffer precision in bits. Default is + -- \"'IsAtLeast' @1@\". + | DisplayBlue -- ^ Blue color buffer precision in bits. Default is + -- \"'IsAtLeast' @1@\". + | DisplayIndex -- ^ Boolean if the color model is color index or not. True is + -- color index. Default is \"'IsAtLeast' @1@\". + | DisplayBuffer -- ^ Number of bits in the color index color buffer. Default + -- is \"'IsAtLeast' @1@\". + | DisplaySingle -- ^ Boolean indicate the color buffer is single buffered. + -- Default is \"'IsEqualTo' @1@\". + | DisplayDouble -- ^ Boolean indicating if the color buffer is double + -- buffered. Default is \"'IsEqualTo' @1@\". + | DisplayAccA -- ^ Red, green, blue, and alpha accumulation buffer precision + -- in bits. Default is \"'IsAtLeast' @1@\" for red, green, + -- blue, and alpha capabilities. + | DisplayAcc -- ^ Red, green, and green accumulation buffer precision in + -- bits and zero bits of alpha accumulation buffer precision. + -- Default is \"'IsAtLeast' @1@\" for red, green, and blue + -- capabilities, and \"'IsNotLessThan' @0@\" for the alpha + -- capability. + | DisplayAlpha -- ^ Alpha color buffer precision in bits. Default is + -- \"'IsAtLeast' @1@\". + | DisplayDepth -- ^ Number of bits of precsion in the depth buffer. Default + -- is \"'IsAtLeast' @12@\". + | DisplayStencil -- ^ Number of bits in the stencil buffer. Default is + -- \"'IsNotLessThan' @1@\". + | DisplaySamples -- ^ Indicates the number of multisamples to use based on + -- GLX\'s @SGIS_multisample@ extension (for antialiasing). + -- Default is \"'IsNotGreaterThan' @4@\". This default means + -- that a GLUT application can request multisampling if + -- available by simply specifying \"'With' 'DisplaySamples'\". + | DisplayStereo -- ^ Boolean indicating the color buffer is supports + -- OpenGL-style stereo. Default is \"'IsEqualTo' @1@\". + | DisplayLuminance -- ^ Number of bits of red in the RGBA and zero bits of green, + -- blue (alpha not specified) of color buffer precision. + -- Default is \"'IsAtLeast' @1@\" for the red capabilitis, + -- and \"'IsEqualTo' @0@\" for the green and blue + -- capabilities, and \"'IsEqualTo' @1@\" for the RGBA color + -- model capability, and, for X11, \"'IsEqualTo' @1@\" for + -- the 'DisplayXStaticGray' capability. SGI InfiniteReality (and + -- other future machines) support a 16-bit luminance (single + -- channel) display mode (an additional 16-bit alpha channel + -- can also be requested). The red channel maps to gray + -- scale and green and blue channels are not available. A + -- 16-bit precision luminance display mode is often + -- appropriate for medical imaging applications. Do not + -- expect many machines to support extended precision + -- luminance display modes. + | DisplayAux -- ^ (/freeglut only/) Number of auxiliary buffers. Default is + -- \"'IsEqualTo' @1@\". + | DisplayNum -- ^ A special capability name indicating where the value + -- represents the Nth frame buffer configuration matching + -- the description string. When not specified, + -- 'initialDisplayCapabilities' also uses the first + -- (best matching) configuration. 'Num' requires a relation + -- and numeric value. + | DisplayConformant -- ^ Boolean indicating if the frame buffer configuration is + -- conformant or not. Conformance information is based on + -- GLX\'s @EXT_visual_rating@ extension if supported. If the + -- extension is not supported, all visuals are assumed + -- conformant. Default is \"'IsEqualTo' @1@\". + | DisplaySlow -- ^ Boolean indicating if the frame buffer configuration is + -- slow or not. Slowness information is based on GLX\'s + -- @EXT_visual_rating@ extension if supported. If the + -- extension is not supported, all visuals are assumed fast. + -- Note that slowness is a relative designation relative to + -- other frame buffer configurations available. The intent + -- of the slow capability is to help programs avoid frame + -- buffer configurations that are slower (but perhaps higher + -- precision) for the current machine. Default is + -- \"'IsAtLeast' @0@\". This default means that slow visuals + -- are used in preference to fast visuals, but fast visuals + -- will still be allowed. + | DisplayWin32PFD -- ^ Only recognized on GLUT implementations for Win32, this + -- capability name matches the Win32 Pixel Format Descriptor + -- by number. 'DisplayWin32PFD' can only be used with 'Where'. + | DisplayXVisual -- ^ Only recongized on GLUT implementations for the X Window + -- System, this capability name matches the X visual ID by + -- number. 'DisplayXVisual' requires a relation and numeric value. + | DisplayXStaticGray -- ^ Only recongized on GLUT implementations for the X Window + -- System, boolean indicating if the frame buffer + -- configuration\'s X visual is of type @StaticGray@. + -- Default is \"'IsEqualTo' @1@\". + | DisplayXGrayScale -- ^ Only recongized on GLUT implementations for the X Window + -- System, boolean indicating if the frame buffer + -- configuration\'s X visual is of type @GrayScale@. Default + -- is \"'IsEqualTo' @1@\". + | DisplayXStaticColor -- ^ Only recongized on GLUT implementations for the X Window + -- System, boolean indicating if the frame buffer + -- configuration\'s X visual is of type @StaticColor@. + -- Default is \"'IsEqualTo' @1@\". + | DisplayXPseudoColor -- ^ Only recongized on GLUT implementations for the X Window + -- System, boolean indicating if the frame buffer + -- configuration\'s X visual is of type @PsuedoColor@. + -- Default is \"'IsEqualTo' @1@\". + | DisplayXTrueColor -- ^ Only recongized on GLUT implementations for the X Window + -- System, boolean indicating if the frame buffer + -- configuration\'s X visual is of type @TrueColor@. Default + -- is \"'IsEqualTo' @1@\". + | DisplayXDirectColor -- ^ Only recongized on GLUT implementations for the X Window + -- System, boolean indicating if the frame buffer + -- configuration\'s X visual is of type @DirectColor@. + -- Default is \"'IsEqualTo' @1@\". + deriving ( Eq, Ord, Show ) + +displayCapabilityToString :: DisplayCapability -> String +displayCapabilityToString x = case x of + DisplayRGBA -> "rgba" + DisplayRGB -> "rgb" + DisplayRed -> "red" + DisplayGreen -> "green" + DisplayBlue -> "blue" + DisplayIndex -> "index" + DisplayBuffer -> "buffer" + DisplaySingle -> "single" + DisplayDouble -> "double" + DisplayAccA -> "acca" + DisplayAcc -> "acc" + DisplayAlpha -> "alpha" + DisplayDepth -> "depth" + DisplayStencil -> "stencil" + DisplaySamples -> "samples" + DisplayStereo -> "stereo" + DisplayLuminance -> "luminance" + DisplayAux -> "aux" + DisplayNum -> "num" + DisplayConformant -> "conformant" + DisplaySlow -> "slow" + DisplayWin32PFD -> "win32pfd" + DisplayXVisual -> "xvisual" + DisplayXStaticGray -> "xstaticgray" + DisplayXGrayScale -> "xgrayscale" + DisplayXStaticColor -> "xstaticcolor" + DisplayXPseudoColor -> "xpseudocolor" + DisplayXTrueColor -> "xtruecolor" + DisplayXDirectColor -> "xdirectcolor" + +-- | A single capability description for 'initialDisplayCapabilities'. + +data DisplayCapabilityDescription + = Where DisplayCapability Relation Int + -- ^ A description of a capability with a specific relation to a numeric + -- value. + | With DisplayCapability + -- ^ When the relation and numeric value are not specified, each capability + -- has a different default, see the different constructors of + -- 'DisplayCapability'. + deriving ( Eq, Ord, Show ) + +displayCapabilityDescriptionToString :: DisplayCapabilityDescription -> String +displayCapabilityDescriptionToString (Where c r i) = + displayCapabilityToString c ++ relationToString r ++ show i +displayCapabilityDescriptionToString (With c) = displayCapabilityToString c + +-- | Controls the /initial display mode/ used when creating top-level windows, +-- subwindows, and overlays to determine the OpenGL display mode for the +-- to-be-created window or overlay. It is described by a list of zero or more +-- capability descriptions, which are translated into a set of criteria used to +-- select the appropriate frame buffer configuration. The criteria are matched +-- in strict left to right order of precdence. That is, the first specified +-- criterion (leftmost) takes precedence over the later criteria for non-exact +-- criteria ('IsGreaterThan', 'IsLessThan', etc.). Exact criteria ('IsEqualTo', +-- 'IsNotEqualTo') must match exactly so precedence is not relevant. +-- +-- Unspecified capability descriptions will result in unspecified criteria being +-- generated. These unspecified criteria help 'initialDisplayCapabilities' +-- behave sensibly with terse display mode descriptions. +-- +-- Here is an example using 'initialDisplayCapabilities': +-- +-- @ +-- initialDisplayCapabilities $= [ With DisplayRGB, +-- Where DisplayDepth IsAtLeast 16, +-- With DisplaySamples, +-- Where DisplayStencil IsNotLessThan 2, +-- With DisplayDouble ] +-- @ +-- +-- The above call requests a window with an RGBA color model (but requesting +-- no bits of alpha), a depth buffer with at least 16 bits of precision but +-- preferring more, multisampling if available, at least 2 bits of stencil +-- (favoring less stencil to more as long as 2 bits are available), and double +-- buffering. + +initialDisplayCapabilities :: SettableStateVar [DisplayCapabilityDescription] +initialDisplayCapabilities = + makeSettableStateVar $ \caps -> + withCString + (concat . intersperse " " . map displayCapabilityDescriptionToString $ + caps) + glutInitDisplayString + +----------------------------------------------------------------------------- + +-- | How rendering context for new windows are created. + +data RenderingContext + = -- | Create a new context via @glXCreateContext@ or @wglCreateContext@ + -- (default). + CreateNewContext + | -- | Re-use the current rendering context. + UseCurrentContext + deriving ( Eq, Ord, Show ) + +marshalRenderingContext :: RenderingContext -> CInt +marshalRenderingContext CreateNewContext = glut_CREATE_NEW_CONTEXT +marshalRenderingContext UseCurrentContext = glut_USE_CURRENT_CONTEXT + +unmarshalRenderingContext :: CInt -> RenderingContext +unmarshalRenderingContext r + | r == glut_CREATE_NEW_CONTEXT = CreateNewContext + | r == glut_USE_CURRENT_CONTEXT = UseCurrentContext + | otherwise = error "unmarshalRenderingContext" + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Controls the creation of rendering contexts for new +-- windows. + +renderingContext :: StateVar RenderingContext +renderingContext = + makeStateVar + (simpleGet unmarshalRenderingContext glut_RENDERING_CONTEXT) + (glutSetOption glut_RENDERING_CONTEXT . marshalRenderingContext) + +----------------------------------------------------------------------------- + +-- | The kind of GLX rendering context used. Direct rendering provides a +-- performance advantage in some implementations. However, direct rendering +-- contexts cannot be shared outside a single process, and they may be unable +-- to render to GLX pixmaps. + +data DirectRendering + = -- | Rendering is always done through the X server. This corresponds to + -- the command line argument @-indirect@, see 'initialize'. + ForceIndirectContext + | -- | Try to use direct rendering, silently using indirect rendering if this + -- is not possible. + AllowDirectContext + | -- | Try to use direct rendering, issue a warning and use indirect + -- rendering if this is not possible. + TryDirectContext + | -- | Try to use direct rendering, issue an error and terminate the program + -- if this is not possible.This corresponds to the command line argument + -- @-direct@, see 'initialize'. + ForceDirectContext + deriving ( Eq, Ord, Show ) + +marshalDirectRendering :: DirectRendering -> CInt +marshalDirectRendering x = case x of + ForceIndirectContext -> glut_FORCE_INDIRECT_CONTEXT + AllowDirectContext -> glut_ALLOW_DIRECT_CONTEXT + TryDirectContext -> glut_TRY_DIRECT_CONTEXT + ForceDirectContext -> glut_FORCE_DIRECT_CONTEXT + +unmarshalDirectRendering :: CInt -> DirectRendering +unmarshalDirectRendering x + | x == glut_FORCE_INDIRECT_CONTEXT = ForceIndirectContext + | x == glut_ALLOW_DIRECT_CONTEXT = AllowDirectContext + | x == glut_TRY_DIRECT_CONTEXT = TryDirectContext + | x == glut_FORCE_DIRECT_CONTEXT = ForceDirectContext + | otherwise = error ("unmarshalDirectRendering: illegal value " ++ show x) + +----------------------------------------------------------------------------- + +-- | (/freeglut on X11 only/) Controls which kind of rendering context is +-- created when a new one is required. + +directRendering :: StateVar DirectRendering +directRendering = + makeStateVar + (simpleGet unmarshalDirectRendering glut_DIRECT_RENDERING) + (glutSetOption glut_DIRECT_RENDERING . marshalDirectRendering) + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Controls the API major\/minor version of the OpenGL +-- context. If a version less than or equal to 2.1 is requested, the context +-- returned may implement any version no less than that requested and no +-- greater than 2.1. If version 3.0 is requested, the context returned must +-- implement exactly version 3.0. Versioning behavior once GL versions beyond +-- 3.0 are defined will be defined by an amendment to the OpenGL specification +-- to define dependencies on such GL versions. +-- +-- 'Graphics.Rendering.OpenGL.GL.StringQueries.glVersion' and +-- 'Graphics.Rendering.OpenGL.GL.StringQueries.majorMinor' will return the +-- actual version supported by a context. +-- +-- The default context version is (1, 0), which will typically return an +-- OpenGL 2.1 context, if one is available. + +initialContextVersion :: StateVar (Int, Int) +initialContextVersion = makeStateVar getContextVersion setContextVersion + +getContextVersion :: IO (Int, Int) +getContextVersion = do + major <- simpleGet fromIntegral glut_INIT_MAJOR_VERSION + minor <- simpleGet fromIntegral glut_INIT_MINOR_VERSION + return (major, minor) + +setContextVersion :: (Int, Int) -> IO () +setContextVersion (major, minor) = + glutInitContextVersion (fromIntegral major) (fromIntegral minor) + +----------------------------------------------------------------------------- + +-- | A flag affecting the rendering context to create, used in conjunction +-- with 'initialContextFlags'. + +data ContextFlag + = -- | Debug contexts are intended for use during application development, + -- and provide additional runtime checking, validation, and logging + -- functionality while possibly incurring performance penalties. The + -- additional functionality provided by debug contexts may vary according + -- to the implementation. In some cases a debug context may be identical + -- to a non-debug context. + DebugContext + | -- | Forward-compatible contexts are defined only for OpenGL versions 3.0 + -- and later. They must not support functionality marked as /deprecated/ + -- by that version of the API, while a non-forward-compatible context must + -- support all functionality in that version, deprecated or not. + ForwardCompatibleContext + deriving ( Eq, Ord, Show ) + +marshalContextFlag :: ContextFlag -> CInt +marshalContextFlag x = case x of + DebugContext -> glut_DEBUG + ForwardCompatibleContext -> glut_FORWARD_COMPATIBLE + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Controls the set of flags for the rendering context. + +initialContextFlags :: StateVar [ContextFlag] +initialContextFlags = makeStateVar getContextFlags setContextFlags + +getContextFlags :: IO [ContextFlag] +getContextFlags = simpleGet i2cfs glut_INIT_FLAGS + +i2cfs :: CInt -> [ContextFlag] +i2cfs bitfield = + [ c | c <- [ DebugContext, ForwardCompatibleContext ] + , (fromIntegral bitfield .&. marshalContextFlag c) /= 0 ] + +setContextFlags :: [ContextFlag] -> IO () +setContextFlags = glutInitContextFlags . toBitfield marshalContextFlag + + +----------------------------------------------------------------------------- + +-- | An OpenGL API profile, affecting the rendering context to create, used +-- in conjunction with 'initialContextProfile'. + +data ContextProfile + = -- | The OpenGL /core/ profile, which all OpenGL 3.2 implementations + -- are required to support. + CoreProfile + | -- | The OpenGL /compatibility/ profile, which is optional for OpenGL + -- 3.2 implementations. + CompatibilityProfile + deriving ( Eq, Ord, Show ) + +marshalContextProfile :: ContextProfile -> CInt +marshalContextProfile x = case x of + CoreProfile -> glut_CORE_PROFILE + CompatibilityProfile -> glut_COMPATIBILITY_PROFILE + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Controls the set of profiles for the rendering context. + +initialContextProfile :: StateVar [ContextProfile] +initialContextProfile = makeStateVar getContextProfiles setContextProfiles + +getContextProfiles :: IO [ContextProfile] +getContextProfiles = simpleGet i2cps glut_INIT_PROFILE + +i2cps :: CInt -> [ContextProfile] +i2cps bitfield = + [ c | c <- [ CoreProfile, CompatibilityProfile ] + , (fromIntegral bitfield .&. marshalContextProfile c) /= 0 ] + +setContextProfiles :: [ContextProfile] -> IO () +setContextProfiles = glutInitContextProfile . toBitfield marshalContextProfile diff --git a/src/Graphics/UI/GLUT/Menu.hs b/src/Graphics/UI/GLUT/Menu.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Menu.hs @@ -0,0 +1,265 @@ +{-# OPTIONS_GHC -fno-cse #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Menu +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- GLUT supports simple cascading pop-up menus. They are designed to let a user +-- select various modes within a program. The functionality is simple and +-- minimalistic and is meant to be that way. Do not mistake GLUT\'s pop-up menu +-- facility with an attempt to create a full-featured user interface. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Menu ( + Menu(..), MenuItem(..), MenuCallback, attachMenu, + numMenuItems +) where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad ( when, unless, zipWithM ) +import Data.Array ( listArray, (!) ) +import Data.IORef ( IORef, newIORef, readIORef, modifyIORef ) +import qualified Data.Map as M +import Data.StateVar ( get, ($=), GettableStateVar, makeGettableStateVar + , StateVar, makeStateVar ) +import Foreign.C.String ( withCString ) +import Foreign.C.Types ( CInt ) +import Foreign.Ptr ( freeHaskellFunPtr ) +import System.IO.Unsafe ( unsafePerformIO ) + +import Graphics.UI.GLUT.Callbacks.Registration +import Graphics.UI.GLUT.QueryUtils +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.Types + +-------------------------------------------------------------------------------- + +-- | A menu is simply a list of menu items, possibly with an associated font. +data Menu + = Menu [MenuItem] + | MenuWithFont BitmapFont [MenuItem] + +menuFont :: Menu -> Maybe BitmapFont +menuFont (Menu _) = Nothing +menuFont (MenuWithFont font _) = Just font + +menuItems :: Menu -> [MenuItem] +menuItems (Menu items) = items +menuItems (MenuWithFont _ items) = items + +-- | A single item within a menu can either be a plain menu entry or a sub-menu +-- entry, allowing for arbitrarily deep nested menus. +data MenuItem + = MenuEntry String MenuCallback -- ^ A plain menu entry with an associated + -- callback, which is triggered when the + -- user selects the entry + | SubMenu String Menu -- ^ A sub-menu, which is cascaded when the + -- user selects the entry, allowing + -- sub-menu entries to be selected + +type MenuCallback = IO () + +-- | Create a new pop-up menu for the /current window,/ attaching it to the +-- given mouse button. A previously attached menu (if any), is detached before +-- and won\'t receive callbacks anymore. +-- +-- It is illegal to call 'attachMenu' while any (sub-)menu is in use, i.e. +-- popped up. +-- +-- /X Implementation Notes:/ If available, GLUT for X will take advantage of +-- overlay planes for implementing pop-up menus. The use of overlay planes can +-- eliminate display callbacks when pop-up menus are deactivated. The +-- @SERVER_OVERLAY_VISUALS@ convention is used to determine if overlay visuals +-- are available. + +attachMenu :: MonadIO m => MouseButton -> Menu -> m () +attachMenu mouseButton menu = liftIO $ do + win <- getCurrentWindow "attachMenu" + let hook = MenuHook win mouseButton + detachMenu hook + unless (null (menuItems menu)) $ do + (_, destructor) <- traverseMenu menu + addToMenuTable hook destructor + attachMenu_ mouseButton + +detachMenu :: MenuHook -> IO () +detachMenu hook@(MenuHook _ mouseButton) = do + maybeDestructor <- lookupInMenuTable hook + case maybeDestructor of + Nothing -> return () + Just destructor -> do detachMenu_ mouseButton + destructor + deleteFromMenuTable hook + +traverseMenu :: Menu -> IO (MenuID, Destructor) +traverseMenu menu = do + let items = menuItems menu + callbackArray = listArray (1, length items) (map makeCallback items) + cb <- makeMenuFunc (\i -> callbackArray ! (fromIntegral i)) + menuID <- glutCreateMenu cb + maybe (return ()) (setMenuFont menuID) (menuFont menu) + destructors <- zipWithM addMenuItem items [1..] + let destructor = do sequence_ destructors + glutDestroyMenu menuID + freeHaskellFunPtr cb + return (menuID, destructor) + +makeCallback :: MenuItem -> MenuCallback +makeCallback (MenuEntry _ cb) = cb +makeCallback _ = error "shouldn't receive a callback for submenus" + +addMenuItem :: MenuItem -> Value -> IO Destructor +addMenuItem (MenuEntry s _) v = do + addMenuEntry s v + return $ glutRemoveMenuItem 1 +addMenuItem (SubMenu s m) _ = do + (menuID, destructor) <- saveExcursion (traverseMenu m) + addSubMenu s menuID + return $ do glutRemoveMenuItem 1 + destructor + +-- Perform an action, saving/restoring the current menu around it +saveExcursion :: IO a -> IO a +saveExcursion act = do + menuID <- get currentMenu + returnValue <- act + when (isRealMenu menuID) $ + currentMenu $= menuID + return returnValue + +-------------------------------------------------------------------------------- +-- This seems to be a common Haskell hack nowadays: A plain old global variable +-- with an associated mutator. Perhaps some language/library support is needed? + +{-# NOINLINE theMenuTable #-} +theMenuTable :: IORef MenuTable +theMenuTable = unsafePerformIO (newIORef emptyMenuTable) + +getMenuTable :: IO MenuTable +getMenuTable = readIORef theMenuTable + +modifyMenuTable :: (MenuTable -> MenuTable) -> IO () +modifyMenuTable = modifyIORef theMenuTable + +-------------------------------------------------------------------------------- +-- To facilitate cleanup, we have to keep track how to destroy menus which are +-- currently attached in a window to a mouse button. + +data MenuHook = MenuHook Window MouseButton + deriving ( Eq, Ord ) + +type Destructor = IO () + +type MenuTable = M.Map MenuHook Destructor + +emptyMenuTable :: MenuTable +emptyMenuTable = M.empty + +lookupInMenuTable :: MenuHook -> IO (Maybe Destructor) +lookupInMenuTable callbackID = + fmap (M.lookup callbackID) getMenuTable + +deleteFromMenuTable :: MenuHook -> IO () +deleteFromMenuTable callbackID = + modifyMenuTable (M.delete callbackID) + +addToMenuTable :: MenuHook -> Destructor -> IO () +addToMenuTable callbackID funPtr = + modifyMenuTable (M.insert callbackID funPtr) + +-------------------------------------------------------------------------------- + +type MenuID = CInt +type Value = CInt + +-------------------------------------------------------------------------------- + +-- | Controls the /current menu./ If no menus exist or the previous /current +-- menu/ was destroyed, a pseudo menu is returned. + +currentMenu :: StateVar MenuID +currentMenu = makeStateVar glutGetMenu glutSetMenu + +-- | Returns 'True' if the given menu identifier refers to a real menu, not +-- a pseudo one. + +isRealMenu :: MenuID -> Bool +isRealMenu = (/= 0) + +-------------------------------------------------------------------------------- + +-- | Add a menu entry to the bottom of the /current menu./ The given string will +-- be displayed for the newly added menu entry. If the menu entry is selected by +-- the user, the menu\'s callback will be called passing the given value as the +-- callback\'s parameter. + +addMenuEntry :: String -> Value -> IO () +addMenuEntry name value = withCString name $ \n -> glutAddMenuEntry n value + +-- | Add a sub-menu trigger to the bottom of the /current menu./ The given +-- string will be displayed for the newly added sub-menu trigger. If the +-- sub-menu trigger is entered, the sub-menu specified by the given menu +-- identifier will be cascaded, allowing sub-menu menu items to be selected. + +addSubMenu :: String -> MenuID -> IO () +addSubMenu name menuID = withCString name $ \n -> glutAddSubMenu n menuID + +-------------------------------------------------------------------------------- + +{- UNUSED +-- | Change the specified menu entry in the /current menu/ into a menu entry. +-- The given position determines which menu item should be changed and must be +-- between 1 (the topmost menu item) and +-- 'Graphics.UI.GLUT.State.getNumMenuItems' inclusive. The menu item to change +-- does not have to be a menu entry already. The given string will be displayed +-- for the newly changed menu entry. The given value will be returned to the +-- menu\'s callback if this menu entry is selected. + +foreign import CALLCONV unsafe "glutChangeToMenuEntry" glutChangeToMenuEntry :: + Item -> CString -> Value -> IO () + +-- | Change the specified menu item in the /current menu/ into a sub-menu +-- trigger. The given position determines which menu item should be changed and +-- must be between 1 and 'Graphics.UI.GLUT.State.getNumMenuItems' inclusive. The +-- menu item to change does not have to be a sub-menu trigger already. The +-- given name will be displayed for the newly changed sub-menu trigger. The +-- given menu identifier names the sub-menu to cascade from the newly added +-- sub-menu trigger. + +foreign import CALLCONV unsafe "glutChangeToSubMenu" glutChangeToSubMenu :: + Item -> CString -> MenuID -> IO () +-} + +-------------------------------------------------------------------------------- + +-- | Attach a mouse button for the /current window/ to the identifier of the +-- /current menu./ By attaching a menu identifier to a button, the named menu +-- will be popped up when the user presses the specified button. Note that the +-- menu is attached to the button by identifier, not by reference. + +attachMenu_ :: MouseButton -> IO () +attachMenu_ = glutAttachMenu . marshalMouseButton + +-- | Detach an attached mouse button from the /current window./ + +detachMenu_ :: MouseButton -> IO () +detachMenu_ = glutDetachMenu . marshalMouseButton + +-------------------------------------------------------------------------------- + +-- | Contains the number of menu items in the /current menu./ + +numMenuItems :: GettableStateVar Int +numMenuItems = makeGettableStateVar $ simpleGet fromIntegral glut_MENU_NUM_ITEMS + +-------------------------------------------------------------------------------- + +setMenuFont :: MenuID -> BitmapFont -> IO () +setMenuFont menuID font = glutSetMenuFont menuID =<< marshalBitmapFont font diff --git a/src/Graphics/UI/GLUT/Objects.hs b/src/Graphics/UI/GLUT/Objects.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Objects.hs @@ -0,0 +1,183 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Objects +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- GLUT includes a number of routines for generating easily recognizable 3D +-- geometric objects. These routines reflect functionality available in the +-- @aux@ toolkit described in the /OpenGL Programmer\'s Guide/ and are included +-- in GLUT to allow the construction of simple GLUT programs that render +-- recognizable objects. These routines can be implemented as pure OpenGL +-- rendering routines. The routines do not generate display lists for the +-- objects they create. The routines generate normals appropriate for lighting +-- but do not generate texture coordinates (except for the solid teapot, teacup +-- and teaspoon). If VBOs should be used instead of the fixed function pipeline, +-- specify at least one of the attribute locations +-- 'Graphics.UI.GLUT.State.vertexAttribCoord3' or +-- 'Graphics.UI.GLUT.State.vertexAttribNormal'. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Objects ( + -- * Rendering flavour + Flavour(..), + + -- * Object description + Object(..), + + -- * Type synonyms + Sides, Rings, NumLevels, + + -- * Rendering + renderObject +) where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Foreign.C.Types ( CInt ) +import Foreign.Marshal.Utils ( with ) +import Foreign.Ptr ( Ptr, castPtr ) +import Graphics.Rendering.OpenGL ( + Height, Radius, Slices, Stacks, Vertex3(..), GLdouble, GLint ) + +import Graphics.UI.GLUT.Raw + +-------------------------------------------------------------------------------- + +-- | Flavour of object rendering + +data Flavour + = -- | Object is rendered as a solid with shading and surface normals. + Solid + | -- | Object is rendered as a wireframe without surface normals. + Wireframe + deriving ( Eq, Ord, Show ) + +-------------------------------------------------------------------------------- + +-- | GLUT offers five types of objects: +-- +-- * The five Platonic solids, see +-- . +-- +-- * A rhombic dodecahedron, see +-- . +-- +-- * Approximations to rounded objects. +-- +-- * The classic teaset modeled by Martin Newell in 1975. Both surface normals +-- and texture coordinates for the teaset are generated. +-- +-- * A Sierpinski sponge, see +-- . + +data Object + = -- | A cube centered at the modeling coordinates origin with sides of the + -- given length. + Cube Height + | -- | A dodecahedron (12-sided regular solid) centered at the modeling + -- coordinates origin with a radius of @sqrt 3@. + Dodecahedron + | -- | A icosahedron (20-sided regular solid) centered at the modeling + -- coordinates origin with a radius of 1.0. + Icosahedron + | -- | Render a solid octahedron (8-sided regular solid) centered at the + -- modeling coordinates origin with a radius of 1.0. + Octahedron + | -- | Render a solid tetrahedron (4-sided regular solid) centered at the + -- modeling coordinates origin with a radius of @sqrt 3@. + Tetrahedron + | -- | (/freeglut only/) A rhombic dodecahedron whose corners are at most a + -- distance of one from the origin. The rhombic dodecahedron has faces + -- which are identical rhombi, but which have some vertices at which three + -- faces meet and some vertices at which four faces meet. The length of + -- each side is @(sqrt 3)\/2@. Vertices at which four faces meet are found + -- at @(0, 0, +\/-1)@ and @(+\/-(sqrt 2)\/2, +\/-(sqrt 2)\/2, 0)@. + RhombicDodecahedron + | -- | A sphere centered at the modeling coordinates origin of the specified + -- radius. The sphere is subdivided around the Z axis into slices + -- (similar to lines of longitude) and along the Z axis into stacks + -- (similar to lines of latitude). + Sphere' Radius Slices Stacks + | -- | A cone oriented along the Z axis. The base of the cone is placed at Z + -- = 0, and the top at Z = the given height. The cone is subdivided + -- around the Z axis into slices, and along the Z axis into stacks. + Cone Radius Height Slices Stacks + | -- |(/freeglut only/) A cylinder oriented along the Z axis. The base of the + -- cylinder is placed at Z = 0, and the top at Z = the given height. The + -- cylinder is subdivided around the Z axis into slices, and along the Z + -- axis into stacks. + Cylinder' Radius Height Slices Stacks + | -- | A torus (doughnut) centered at the modeling coordinates origin + -- whose axis is aligned with the Z axis. The torus is described by its + -- inner and outer radius, the number of sides for each radial section, + -- and the number of radial divisions (rings). + Torus Radius Radius Sides Rings + | -- | A teapot with a given relative size. + Teapot Height + | -- |(/freeglut only/) A teacup with a given relative size. + Teacup Height + | -- |(/freeglut only/) A teaspoon with a given relative size. + Teaspoon Height + | -- |(/freeglut only/) A Sierpinski sponge of a given level, where a level + -- 0 sponge is the same as a 'Tetrahedron'. + SierpinskiSponge NumLevels + deriving ( Eq, Ord, Show ) + +-------------------------------------------------------------------------------- + +type Sides = GLint +type Rings = GLint +type NumLevels = GLint + +-------------------------------------------------------------------------------- + +-- | Render an object in the given flavour. + +renderObject :: MonadIO m => Flavour -> Object -> m () +renderObject Solid (Cube h) = glutSolidCube h +renderObject Wireframe (Cube h) = glutWireCube h +renderObject Solid Dodecahedron = glutSolidDodecahedron +renderObject Wireframe Dodecahedron = glutWireDodecahedron +renderObject Solid Icosahedron = glutSolidIcosahedron +renderObject Wireframe Icosahedron = glutWireIcosahedron +renderObject Solid Octahedron = glutSolidOctahedron +renderObject Wireframe Octahedron = glutWireOctahedron +renderObject Solid Tetrahedron = glutSolidTetrahedron +renderObject Wireframe Tetrahedron = glutWireTetrahedron +renderObject Solid RhombicDodecahedron = glutSolidRhombicDodecahedron +renderObject Wireframe RhombicDodecahedron = glutWireRhombicDodecahedron +renderObject Solid (Sphere' r s t) = glutSolidSphere r s t +renderObject Wireframe (Sphere' r s t) = glutWireSphere r s t +renderObject Solid (Cone r h s t) = glutSolidCone r h s t +renderObject Wireframe (Cone r h s t) = glutWireCone r h s t +renderObject Solid (Cylinder' r h s t) = glutSolidCylinder r h s t +renderObject Wireframe (Cylinder' r h s t) = glutWireCylinder r h s t +renderObject Solid (Torus i o s r) = glutSolidTorus i o s r +renderObject Wireframe (Torus i o s r) = glutWireTorus i o s r +renderObject Solid (Teapot h) = glutSolidTeapot h +renderObject Wireframe (Teapot h) = glutWireTeapot h +renderObject Solid (Teacup h) = glutSolidTeacup h +renderObject Wireframe (Teacup h) = glutWireTeacup h +renderObject Solid (Teaspoon h) = glutSolidTeaspoon h +renderObject Wireframe (Teaspoon h) = glutWireTeaspoon h +renderObject Solid (SierpinskiSponge n) = solidSierpinskiSponge n +renderObject Wireframe (SierpinskiSponge n) = wireSierpinskiSponge n + +-------------------------------------------------------------------------------- + +solidSierpinskiSponge :: MonadIO m => NumLevels -> m () +solidSierpinskiSponge = sierpinskiSponge glutSolidSierpinskiSponge + +wireSierpinskiSponge :: MonadIO m => NumLevels -> m () +wireSierpinskiSponge = sierpinskiSponge glutWireSierpinskiSponge + +-- for consistency, we hide the offset and scale on the Haskell side +sierpinskiSponge :: MonadIO m => (CInt -> Ptr GLdouble -> Height -> IO ()) -> NumLevels -> m () +sierpinskiSponge f n = liftIO $ + with (Vertex3 0 0 0) $ \offsetBuf -> + f (fromIntegral n) ((castPtr :: Ptr (Vertex3 GLdouble) -> Ptr GLdouble) offsetBuf) 1 diff --git a/src/Graphics/UI/GLUT/Overlay.hs b/src/Graphics/UI/GLUT/Overlay.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Overlay.hs @@ -0,0 +1,171 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Overlay +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- When overlay hardware is available, GLUT provides a set of routines for +-- establishing, using, and removing an overlay for GLUT windows. When an +-- overlay is established, a separate OpenGL context is also established. A +-- window\'s overlay OpenGL state is kept distinct from the normal planes\' +-- OpenGL state. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Overlay ( + -- * Overlay creation and destruction + hasOverlay, overlayPossible, + + -- * Showing and hiding an overlay + overlayVisible, + + -- * Changing the /layer in use/ + Layer(..), layerInUse, + + -- * Re-displaying + postOverlayRedisplay +) where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.StateVar ( GettableStateVar, makeGettableStateVar + , SettableStateVar, makeSettableStateVar + , StateVar, makeStateVar ) +import Graphics.Rendering.OpenGL ( GLenum ) + +import Graphics.UI.GLUT.QueryUtils +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.Types + +-------------------------------------------------------------------------------- + +-- | Controls the overlay for the /current window/. The requested display mode +-- for the overlay is determined by the /initial display mode/. +-- 'overlayPossible' can be used to determine if an overlay is possible for the +-- /current window/ with the current /initial display mode/. Do not attempt to +-- establish an overlay when one is not possible; GLUT will terminate the +-- program. +-- +-- When 'hasOverlay' is set to 'True' when an overlay already exists, the +-- existing overlay is first removed, and then a new overlay is established. The +-- state of the old overlay\'s OpenGL context is discarded. Implicitly, the +-- window\'s /layer in use/ changes to the overlay immediately after the overlay +-- is established. +-- +-- The initial display state of an overlay is shown, however the overlay is only +-- actually shown if the overlay\'s window is shown. +-- +-- Setting 'hasOverlay' to 'False' is safe even if no overlay is currently +-- established, nothing happens in this case. Implicitly, the window\'s /layer +-- in use/ changes to the normal plane immediately once the overlay is removed. +-- +-- If the program intends to re-establish the overlay later, it is typically +-- faster and less resource intensive to use 'overlayVisible' to simply change +-- the display status of the overlay. +-- +-- /X Implementation Notes:/ GLUT for X uses the @SERVER_OVERLAY_VISUALS@ +-- convention to determine if overlay visuals are available. While the +-- convention allows for opaque overlays (no transparency) and overlays with the +-- transparency specified as a bitmask, GLUT overlay management only provides +-- access to transparent pixel overlays. +-- +-- Until RGBA overlays are better understood, GLUT only supports color index +-- overlays. + +hasOverlay :: StateVar Bool +hasOverlay = makeStateVar getHasOverlay setHasOverlay + +setHasOverlay :: Bool -> IO () +setHasOverlay False = glutRemoveOverlay +setHasOverlay True = glutEstablishOverlay + +getHasOverlay :: IO Bool +getHasOverlay = layerGet (/= 0) glut_HAS_OVERLAY + +-------------------------------------------------------------------------------- + +-- | Contains 'True' if an overlay could be established for the /current window/ +-- given the current /initial display mode/. If it contains 'False', setting +-- 'hasOverlay' will fail with a fatal error. + +overlayPossible :: GettableStateVar Bool +overlayPossible = makeGettableStateVar $ layerGet (/= 0) glut_OVERLAY_POSSIBLE + +-------------------------------------------------------------------------------- + +-- | Controls the visibility of the overlay of the /current window/. +-- +-- The effect of showing or hiding an overlay takes place immediately. Note that +-- setting 'overlayVisible' to 'True' will not actually display the overlay +-- unless the window is also shown (and even a shown window may be obscured by +-- other windows, thereby obscuring the overlay). It is typically faster and +-- less resource intensive to use the routines below to control the display +-- status of an overlay as opposed to removing and re-establishing the overlay. + +overlayVisible :: SettableStateVar Bool +overlayVisible = + makeSettableStateVar $ \flag -> + if flag then glutShowOverlay else glutHideOverlay + +-------------------------------------------------------------------------------- + +-- | The /layer in use/. +data Layer + = Normal -- ^ The normal plane. + | Overlay -- ^ The overlay. + deriving ( Eq, Ord, Show ) + +marshalLayer :: Layer -> GLenum +marshalLayer x = case x of + Normal -> glut_NORMAL + Overlay -> glut_OVERLAY + +unmarshalLayer :: GLenum -> Layer +unmarshalLayer x + | x == glut_NORMAL = Normal + | x == glut_OVERLAY = Overlay + | otherwise = error ("unmarshalLayer: illegal value " ++ show x) + +-------------------------------------------------------------------------------- + +-- | Controls the per-window /layer in use/ for the /current window/, which can +-- either be the normal plane or the overlay. Selecting the overlay should only +-- be done if an overlay exists, however windows without an overlay may still +-- set the /layer in use/ to 'Normal'. OpenGL commands for the window are +-- directed to the current /layer in use/. + +layerInUse :: StateVar Layer +layerInUse = + makeStateVar getLayerInUse setLayerInUse + +setLayerInUse :: Layer -> IO () +setLayerInUse = glutUseLayer . marshalLayer + +getLayerInUse :: IO Layer +getLayerInUse = layerGet (unmarshalLayer . fromIntegral) glut_LAYER_IN_USE + +-------------------------------------------------------------------------------- + +-- | Mark the overlay of the given window (or the /current window/, if none is +-- supplied) as needing to be redisplayed. The next iteration through +-- 'Graphics.UI.GLUT.Begin.mainLoop', the window\'s overlay display callback +-- (or simply the display callback if no overlay display callback is registered) +-- will be called to redisplay the window\'s overlay plane. Multiple calls to +-- 'postOverlayRedisplay' before the next display callback opportunity (or +-- overlay display callback opportunity if one is registered) generate only a +-- single redisplay. 'postOverlayRedisplay' may be called within a window\'s +-- display or overlay display callback to re-mark that window for redisplay. +-- +-- Logically, overlay damage notification for a window is treated as a +-- 'postOverlayRedisplay' on the damaged window. Unlike damage reported by the +-- window system, 'postOverlayRedisplay' will not set to true the overlay\'s +-- damaged status (see 'Graphics.UI.GLUT.State.damaged'). +-- +-- Also, see 'Graphics.UI.GLUT.Window.postRedisplay'. + +postOverlayRedisplay :: MonadIO m => Maybe Window -> m () +postOverlayRedisplay = + maybe glutPostOverlayRedisplay (\(Window win) -> glutPostWindowOverlayRedisplay win) diff --git a/src/Graphics/UI/GLUT/QueryUtils.hs b/src/Graphics/UI/GLUT/QueryUtils.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/QueryUtils.hs @@ -0,0 +1,36 @@ +{-# OPTIONS_HADDOCK hide #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.QueryUtils +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- This is a purely internal module with utilities to query GLUT state. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.QueryUtils ( + Getter, simpleGet, layerGet, deviceGet +) where + +import Foreign.C.Types ( CInt ) +import Graphics.Rendering.OpenGL ( GLenum ) + +import Graphics.UI.GLUT.Raw + +-------------------------------------------------------------------------------- + +type PrimGetter = GLenum -> IO CInt +type Getter a = (CInt -> a) -> GLenum -> IO a + +makeGetter :: PrimGetter -> Getter a +makeGetter g f = fmap f . g + +simpleGet, layerGet, deviceGet :: Getter a +simpleGet = makeGetter glutGet +layerGet = makeGetter glutLayerGet +deviceGet = makeGetter glutDeviceGet diff --git a/src/Graphics/UI/GLUT/Raw.hs b/src/Graphics/UI/GLUT/Raw.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Raw.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Raw +-- Copyright : (c) Sven Panne 2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- A convenience module, combining all raw GLUT modules. +-- +----------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Raw ( + module Graphics.UI.GLUT.Raw.Callbacks, + module Graphics.UI.GLUT.Raw.Fonts, + module Graphics.UI.GLUT.Raw.Functions, + module Graphics.UI.GLUT.Raw.Tokens +) where + +import Graphics.UI.GLUT.Raw.Callbacks +import Graphics.UI.GLUT.Raw.Fonts +import Graphics.UI.GLUT.Raw.Functions +import Graphics.UI.GLUT.Raw.Tokens diff --git a/src/Graphics/UI/GLUT/Raw/Callbacks.hs b/src/Graphics/UI/GLUT/Raw/Callbacks.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Raw/Callbacks.hs @@ -0,0 +1,242 @@ +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Raw.Callbacks +-- Copyright : (c) Sven Panne 2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- All GLUT callbacks. +-- +----------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Raw.Callbacks ( + AppStatusFunc, makeAppStatusFunc, + ButtonBoxFunc, makeButtonBoxFunc, + CloseFunc, makeCloseFunc, + DialsFunc, makeDialsFunc, + DisplayFunc, makeDisplayFunc, + EntryFunc, makeEntryFunc, + IdleFunc, makeIdleFunc, + InitContextFunc, makeInitContextFunc, + JoystickFunc, makeJoystickFunc, + KeyboardFunc, makeKeyboardFunc, + KeyboardUpFunc, makeKeyboardUpFunc, + MenuDestroyFunc, makeMenuDestroyFunc, + MenuFunc, makeMenuFunc, + MenuStateFunc, makeMenuStateFunc, + MenuStatusFunc, makeMenuStatusFunc, + MotionFunc, makeMotionFunc, + MouseFunc, makeMouseFunc, + MouseWheelFunc, makeMouseWheelFunc, + MultiButtonFunc, makeMultiButtonFunc, + MultiEntryFunc, makeMultiEntryFunc, + MultiMotionFunc, makeMultiMotionFunc, + MultiPassiveFunc, makeMultiPassiveFunc, + OverlayDisplayFunc, makeOverlayDisplayFunc, + PassiveMotionFunc, makePassiveMotionFunc, + PositionFunc, makePositionFunc, + ReshapeFunc, makeReshapeFunc, + SpaceballButtonFunc, makeSpaceballButtonFunc, + SpaceballMotionFunc, makeSpaceballMotionFunc, + SpaceballRotateFunc, makeSpaceballRotateFunc, + SpecialFunc, makeSpecialFunc, + SpecialUpFunc, makeSpecialUpFunc, + TabletButtonFunc, makeTabletButtonFunc, + TabletMotionFunc, makeTabletMotionFunc, + TimerFunc, makeTimerFunc, + VisibilityFunc, makeVisibilityFunc, + WMCloseFunc, makeWMCloseFunc, + WindowStatusFunc, makeWindowStatusFunc +) where + +import Foreign.C.Types +import Foreign.Ptr + +type AppStatusFunc = CInt -> IO () + +foreign import ccall "wrapper" + makeAppStatusFunc :: AppStatusFunc -> IO (FunPtr AppStatusFunc) + +type ButtonBoxFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeButtonBoxFunc :: ButtonBoxFunc -> IO (FunPtr ButtonBoxFunc) + +type CloseFunc = IO () + +foreign import ccall "wrapper" + makeCloseFunc :: CloseFunc -> IO (FunPtr CloseFunc) + +type DialsFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeDialsFunc :: DialsFunc -> IO (FunPtr DialsFunc) + +type DisplayFunc = IO () + +foreign import ccall "wrapper" + makeDisplayFunc :: DisplayFunc -> IO (FunPtr DisplayFunc) + +type EntryFunc = CInt -> IO () + +foreign import ccall "wrapper" + makeEntryFunc :: EntryFunc -> IO (FunPtr EntryFunc) + +type IdleFunc = IO () + +foreign import ccall "wrapper" + makeIdleFunc :: IdleFunc -> IO (FunPtr IdleFunc) + +type InitContextFunc = IO () + +foreign import ccall "wrapper" + makeInitContextFunc :: InitContextFunc -> IO (FunPtr InitContextFunc) + +type JoystickFunc = CUInt -> CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeJoystickFunc :: JoystickFunc -> IO (FunPtr JoystickFunc) + +type KeyboardFunc = CUChar -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeKeyboardFunc :: KeyboardFunc -> IO (FunPtr KeyboardFunc) + +type KeyboardUpFunc = CUChar -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeKeyboardUpFunc :: KeyboardUpFunc -> IO (FunPtr KeyboardUpFunc) + +type MenuDestroyFunc = IO () + +foreign import ccall "wrapper" + makeMenuDestroyFunc :: MenuDestroyFunc -> IO (FunPtr MenuDestroyFunc) + +type MenuFunc = CInt -> IO () + +foreign import ccall "wrapper" + makeMenuFunc :: MenuFunc -> IO (FunPtr MenuFunc) + +type MenuStateFunc = CInt -> IO () + +foreign import ccall "wrapper" + makeMenuStateFunc :: MenuStateFunc -> IO (FunPtr MenuStateFunc) + +type MenuStatusFunc = CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeMenuStatusFunc :: MenuStatusFunc -> IO (FunPtr MenuStatusFunc) + +type MotionFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeMotionFunc :: MotionFunc -> IO (FunPtr MotionFunc) + +type MouseFunc = CInt -> CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeMouseFunc :: MouseFunc -> IO (FunPtr MouseFunc) + +type MouseWheelFunc = CInt -> CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeMouseWheelFunc :: MouseWheelFunc -> IO (FunPtr MouseWheelFunc) + +type MultiButtonFunc = CInt -> CInt -> CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeMultiButtonFunc :: MultiButtonFunc -> IO (FunPtr MultiButtonFunc) + +type MultiEntryFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeMultiEntryFunc :: MultiEntryFunc -> IO (FunPtr MultiEntryFunc) + +type MultiMotionFunc = CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeMultiMotionFunc :: MultiMotionFunc -> IO (FunPtr MultiMotionFunc) + +type MultiPassiveFunc = CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeMultiPassiveFunc :: MultiPassiveFunc -> IO (FunPtr MultiPassiveFunc) + +type OverlayDisplayFunc = IO () + +foreign import ccall "wrapper" + makeOverlayDisplayFunc :: OverlayDisplayFunc -> IO (FunPtr OverlayDisplayFunc) + +type PassiveMotionFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makePassiveMotionFunc :: PassiveMotionFunc -> IO (FunPtr PassiveMotionFunc) + +type PositionFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makePositionFunc :: PositionFunc -> IO (FunPtr PositionFunc) + +type ReshapeFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeReshapeFunc :: ReshapeFunc -> IO (FunPtr ReshapeFunc) + +type SpaceballButtonFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeSpaceballButtonFunc :: SpaceballButtonFunc -> IO (FunPtr SpaceballButtonFunc) + +type SpaceballMotionFunc = CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeSpaceballMotionFunc :: SpaceballMotionFunc -> IO (FunPtr SpaceballMotionFunc) + +type SpaceballRotateFunc = CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeSpaceballRotateFunc :: SpaceballRotateFunc -> IO (FunPtr SpaceballRotateFunc) + +type SpecialFunc = CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeSpecialFunc :: SpecialFunc -> IO (FunPtr SpecialFunc) + +type SpecialUpFunc = CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeSpecialUpFunc :: SpecialUpFunc -> IO (FunPtr SpecialUpFunc) + +type TabletButtonFunc = CInt -> CInt -> CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeTabletButtonFunc :: TabletButtonFunc -> IO (FunPtr TabletButtonFunc) + +type TabletMotionFunc = CInt -> CInt -> IO () + +foreign import ccall "wrapper" + makeTabletMotionFunc :: TabletMotionFunc -> IO (FunPtr TabletMotionFunc) + +type TimerFunc = CInt -> IO () + +foreign import ccall "wrapper" + makeTimerFunc :: TimerFunc -> IO (FunPtr TimerFunc) + +type VisibilityFunc = CInt -> IO () + +foreign import ccall "wrapper" + makeVisibilityFunc :: VisibilityFunc -> IO (FunPtr VisibilityFunc) + +type WMCloseFunc = IO () + +foreign import ccall "wrapper" + makeWMCloseFunc :: WMCloseFunc -> IO (FunPtr WMCloseFunc) + +type WindowStatusFunc = CInt -> IO () + +foreign import ccall "wrapper" + makeWindowStatusFunc :: WindowStatusFunc -> IO (FunPtr WindowStatusFunc) diff --git a/src/Graphics/UI/GLUT/Raw/Fonts.hs b/src/Graphics/UI/GLUT/Raw/Fonts.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Raw/Fonts.hs @@ -0,0 +1,92 @@ +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Raw.Fonts +-- Copyright : (c) Sven Panne 2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- Our own functions to access font identifiers in a portable way. +-- +----------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Raw.Fonts ( + BitmapFont(..), GLUTbitmapFont, marshalBitmapFont, + StrokeFont(..), GLUTstrokeFont, marshalStrokeFont +) where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Foreign.C.Types +import Foreign.Ptr ( 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 :: MonadIO m => BitmapFont -> m GLUTbitmapFont +marshalBitmapFont x = liftIO $ 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 :: MonadIO m => StrokeFont -> m GLUTstrokeFont +marshalStrokeFont x = liftIO $ case x of + Roman -> hs_GLUT_marshalStrokeFont 0 + MonoRoman -> hs_GLUT_marshalStrokeFont 1 + +foreign import ccall unsafe "hs_GLUT_marshalStrokeFont" + hs_GLUT_marshalStrokeFont :: CInt -> IO (Ptr a) diff --git a/src/Graphics/UI/GLUT/Raw/Functions.hs b/src/Graphics/UI/GLUT/Raw/Functions.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Raw/Functions.hs @@ -0,0 +1,2267 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Raw.Functions +-- Copyright : (c) Sven Panne 2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- All raw functions from GLUT and freeglut. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Raw.Functions ( + isKnown, + + glutAddMenuEntry, + glutAddSubMenu, + glutAppStatusFunc, + glutAttachMenu, + glutBitmapCharacter, + glutBitmapHeight, + glutBitmapLength, + glutBitmapString, + glutBitmapWidth, + glutButtonBoxFunc, + glutChangeToMenuEntry, + glutChangeToSubMenu, + glutCloseFunc, + glutCopyColormap, + glutCreateMenu, + glutCreateSubWindow, + glutCreateWindow, + glutDestroyMenu, + glutDestroyWindow, + glutDetachMenu, + glutDeviceGet, + glutDialsFunc, + glutDisplayFunc, + glutEnterGameMode, + glutEntryFunc, + glutEstablishOverlay, + glutExit, + glutExtensionSupported, + glutForceJoystickFunc, + glutFullScreen, + glutFullScreenToggle, + glutGameModeGet, + glutGameModeString, + glutGet, + glutGetColor, + glutGetMenu, + glutGetMenuData, + glutGetModeValues, + glutGetModifiers, + glutGetProcAddress, + glutGetWindow, + glutGetWindowData, + glutHideOverlay, + glutHideWindow, + glutIconifyWindow, + glutIdleFunc, + glutIgnoreKeyRepeat, + glutInit, + glutInitContextFlags, + glutInitContextFunc, + glutInitContextProfile, + glutInitContextVersion, + glutInitDisplayMode, + glutInitDisplayString, + glutInitWindowPosition, + glutInitWindowSize, + glutJoystickFunc, + glutKeyboardFunc, + glutKeyboardUpFunc, + glutLayerGet, + glutLeaveFullScreen, + glutLeaveGameMode, + glutLeaveMainLoop, + glutMainLoop, + glutMainLoopEvent, + glutMenuDestroyFunc, + glutMenuStateFunc, + glutMenuStatusFunc, + glutMotionFunc, + glutMouseFunc, + glutMouseWheelFunc, + glutMultiButtonFunc, + glutMultiEntryFunc, + glutMultiMotionFunc, + glutMultiPassiveFunc, + glutOverlayDisplayFunc, + glutPassiveMotionFunc, + glutPopWindow, + glutPositionFunc, + glutPositionWindow, + glutPostOverlayRedisplay, + glutPostRedisplay, + glutPostWindowOverlayRedisplay, + glutPostWindowRedisplay, + glutPushWindow, + glutRemoveMenuItem, + glutRemoveOverlay, + glutReportErrors, + glutReshapeFunc, + glutReshapeWindow, + glutSetColor, + glutSetCursor, + glutSetIconTitle, + glutSetKeyRepeat, + glutSetMenu, + glutSetMenuData, + glutSetMenuFont, + glutSetOption, + glutSetVertexAttribCoord3, + glutSetVertexAttribNormal, + glutSetVertexAttribTexCoord2, + glutSetWindow, + glutSetWindowData, + glutSetWindowTitle, + glutSetupVideoResizing, + glutShowOverlay, + glutShowWindow, + glutSolidCone, + glutSolidCube, + glutSolidCylinder, + glutSolidDodecahedron, + glutSolidIcosahedron, + glutSolidOctahedron, + glutSolidRhombicDodecahedron, + glutSolidSierpinskiSponge, + glutSolidSphere, + glutSolidTeacup, + glutSolidTeapot, + glutSolidTeaspoon, + glutSolidTetrahedron, + glutSolidTorus, + glutSpaceballButtonFunc, + glutSpaceballMotionFunc, + glutSpaceballRotateFunc, + glutSpecialFunc, + glutSpecialUpFunc, + glutStopVideoResizing, + glutStrokeCharacter, + glutStrokeHeight, + glutStrokeLength, + glutStrokeString, + glutStrokeWidth, + glutSwapBuffers, + glutTabletButtonFunc, + glutTabletMotionFunc, + glutTimerFunc, + glutUseLayer, + glutVideoPan, + glutVideoResize, + glutVideoResizeGet, + glutVisibilityFunc, + glutWMCloseFunc, + glutWarpPointer, + glutWindowStatusFunc, + glutWireCone, + glutWireCube, + glutWireCylinder, + glutWireDodecahedron, + glutWireIcosahedron, + glutWireOctahedron, + glutWireRhombicDodecahedron, + glutWireSierpinskiSponge, + glutWireSphere, + glutWireTeacup, + glutWireTeapot, + glutWireTeaspoon, + glutWireTetrahedron, + glutWireTorus +) where + +-- Make the foreign imports happy. +import Foreign.C.Types + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Foreign.C.String ( withCString, CString ) +import Foreign.Marshal.Error ( throwIf ) +import Foreign.Ptr ( Ptr, FunPtr, nullFunPtr ) +import Graphics.Rendering.OpenGL ( GLdouble, GLenum, GLfloat, GLint ) +import System.IO.Unsafe ( unsafePerformIO ) + +import Graphics.UI.GLUT.Raw.Callbacks + +-------------------------------------------------------------------------------- + +-- | Retrieve a GLUT API entry by name. Throws a userError when no entry with +-- the given name was found. +getAPIEntry :: String -> IO (FunPtr a) +getAPIEntry extensionEntry = + throwIfNullFunPtr ("unknown GLUT entry " ++ extensionEntry) $ + getAPIEntryInternal extensionEntry + +throwIfNullFunPtr :: String -> IO (FunPtr a) -> IO (FunPtr a) +throwIfNullFunPtr = throwIf (== nullFunPtr) . const + +getAPIEntryInternal :: String -> IO (FunPtr a) +getAPIEntryInternal extensionEntry = + withCString extensionEntry hs_GLUT_getProcAddress + +isKnown :: MonadIO m => String -> m Bool +isKnown = liftIO . fmap (/= nullFunPtr) . getAPIEntryInternal + +foreign import ccall unsafe "hs_GLUT_getProcAddress" + hs_GLUT_getProcAddress :: CString -> IO (FunPtr a) + +-- glutAddMenuEntry ------------------------------------------------------------ + +glutAddMenuEntry :: MonadIO m => Ptr CChar -> CInt -> m () +glutAddMenuEntry v1 v2 = liftIO $ dyn_glutAddMenuEntry ptr_glutAddMenuEntry v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutAddMenuEntry + :: FunPtr (Ptr CChar -> CInt -> IO ()) + -> Ptr CChar -> CInt -> IO () + +{-# NOINLINE ptr_glutAddMenuEntry #-} +ptr_glutAddMenuEntry :: FunPtr a +ptr_glutAddMenuEntry = unsafePerformIO $ getAPIEntry "glutAddMenuEntry" + +-- glutAddSubMenu -------------------------------------------------------------- + +glutAddSubMenu :: MonadIO m => Ptr CChar -> CInt -> m () +glutAddSubMenu v1 v2 = liftIO $ dyn_glutAddSubMenu ptr_glutAddSubMenu v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutAddSubMenu + :: FunPtr (Ptr CChar -> CInt -> IO ()) + -> Ptr CChar -> CInt -> IO () + +{-# NOINLINE ptr_glutAddSubMenu #-} +ptr_glutAddSubMenu :: FunPtr a +ptr_glutAddSubMenu = unsafePerformIO $ getAPIEntry "glutAddSubMenu" + +-- glutAppStatusFunc ----------------------------------------------------------- + +glutAppStatusFunc :: MonadIO m => FunPtr AppStatusFunc -> m () +glutAppStatusFunc v1 = liftIO $ dyn_glutAppStatusFunc ptr_glutAppStatusFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutAppStatusFunc + :: FunPtr (FunPtr AppStatusFunc -> IO ()) + -> FunPtr AppStatusFunc -> IO () + +{-# NOINLINE ptr_glutAppStatusFunc #-} +ptr_glutAppStatusFunc :: FunPtr a +ptr_glutAppStatusFunc = unsafePerformIO $ getAPIEntry "glutAppStatusFunc" + +-- glutAttachMenu -------------------------------------------------------------- + +glutAttachMenu :: MonadIO m => CInt -> m () +glutAttachMenu v1 = liftIO $ dyn_glutAttachMenu ptr_glutAttachMenu v1 + +foreign import CALLCONV "dynamic" dyn_glutAttachMenu + :: FunPtr (CInt -> IO ()) + -> CInt -> IO () + +{-# NOINLINE ptr_glutAttachMenu #-} +ptr_glutAttachMenu :: FunPtr a +ptr_glutAttachMenu = unsafePerformIO $ getAPIEntry "glutAttachMenu" + +-- glutBitmapCharacter --------------------------------------------------------- + +glutBitmapCharacter :: MonadIO m => Ptr a -> CInt -> m () +glutBitmapCharacter v1 v2 = liftIO $ dyn_glutBitmapCharacter ptr_glutBitmapCharacter v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutBitmapCharacter + :: FunPtr (Ptr a -> CInt -> IO ()) + -> Ptr a -> CInt -> IO () + +{-# NOINLINE ptr_glutBitmapCharacter #-} +ptr_glutBitmapCharacter :: FunPtr a +ptr_glutBitmapCharacter = unsafePerformIO $ getAPIEntry "glutBitmapCharacter" + +-- glutBitmapHeight ------------------------------------------------------------ + +glutBitmapHeight :: MonadIO m => Ptr a -> m CInt +glutBitmapHeight v1 = liftIO $ dyn_glutBitmapHeight ptr_glutBitmapHeight v1 + +foreign import CALLCONV "dynamic" dyn_glutBitmapHeight + :: FunPtr (Ptr a -> IO CInt) + -> Ptr a -> IO CInt + +{-# NOINLINE ptr_glutBitmapHeight #-} +ptr_glutBitmapHeight :: FunPtr a +ptr_glutBitmapHeight = unsafePerformIO $ getAPIEntry "glutBitmapHeight" + +-- glutBitmapLength ------------------------------------------------------------ + +glutBitmapLength :: MonadIO m => Ptr a -> Ptr CUChar -> m CInt +glutBitmapLength v1 v2 = liftIO $ dyn_glutBitmapLength ptr_glutBitmapLength v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutBitmapLength + :: FunPtr (Ptr a -> Ptr CUChar -> IO CInt) + -> Ptr a -> Ptr CUChar -> IO CInt + +{-# NOINLINE ptr_glutBitmapLength #-} +ptr_glutBitmapLength :: FunPtr a +ptr_glutBitmapLength = unsafePerformIO $ getAPIEntry "glutBitmapLength" + +-- glutBitmapString ------------------------------------------------------------ + +glutBitmapString :: MonadIO m => Ptr a -> Ptr CUChar -> m () +glutBitmapString v1 v2 = liftIO $ dyn_glutBitmapString ptr_glutBitmapString v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutBitmapString + :: FunPtr (Ptr a -> Ptr CUChar -> IO ()) + -> Ptr a -> Ptr CUChar -> IO () + +{-# NOINLINE ptr_glutBitmapString #-} +ptr_glutBitmapString :: FunPtr a +ptr_glutBitmapString = unsafePerformIO $ getAPIEntry "glutBitmapString" + +-- glutBitmapWidth ------------------------------------------------------------- + +glutBitmapWidth :: MonadIO m => Ptr a -> CInt -> m CInt +glutBitmapWidth v1 v2 = liftIO $ dyn_glutBitmapWidth ptr_glutBitmapWidth v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutBitmapWidth + :: FunPtr (Ptr a -> CInt -> IO CInt) + -> Ptr a -> CInt -> IO CInt + +{-# NOINLINE ptr_glutBitmapWidth #-} +ptr_glutBitmapWidth :: FunPtr a +ptr_glutBitmapWidth = unsafePerformIO $ getAPIEntry "glutBitmapWidth" + +-- glutButtonBoxFunc ----------------------------------------------------------- + +glutButtonBoxFunc :: MonadIO m => FunPtr ButtonBoxFunc -> m () +glutButtonBoxFunc v1 = liftIO $ dyn_glutButtonBoxFunc ptr_glutButtonBoxFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutButtonBoxFunc + :: FunPtr (FunPtr ButtonBoxFunc -> IO ()) + -> FunPtr ButtonBoxFunc -> IO () + +{-# NOINLINE ptr_glutButtonBoxFunc #-} +ptr_glutButtonBoxFunc :: FunPtr a +ptr_glutButtonBoxFunc = unsafePerformIO $ getAPIEntry "glutButtonBoxFunc" + +-- glutChangeToMenuEntry ------------------------------------------------------- + +glutChangeToMenuEntry :: MonadIO m => CInt -> Ptr CChar -> CInt -> m () +glutChangeToMenuEntry v1 v2 v3 = liftIO $ dyn_glutChangeToMenuEntry ptr_glutChangeToMenuEntry v1 v2 v3 + +foreign import CALLCONV "dynamic" dyn_glutChangeToMenuEntry + :: FunPtr (CInt -> Ptr CChar -> CInt -> IO ()) + -> CInt -> Ptr CChar -> CInt -> IO () + +{-# NOINLINE ptr_glutChangeToMenuEntry #-} +ptr_glutChangeToMenuEntry :: FunPtr a +ptr_glutChangeToMenuEntry = unsafePerformIO $ getAPIEntry "glutChangeToMenuEntry" + +-- glutChangeToSubMenu --------------------------------------------------------- + +glutChangeToSubMenu :: MonadIO m => CInt -> Ptr CChar -> CInt -> m () +glutChangeToSubMenu v1 v2 v3 = liftIO $ dyn_glutChangeToSubMenu ptr_glutChangeToSubMenu v1 v2 v3 + +foreign import CALLCONV "dynamic" dyn_glutChangeToSubMenu + :: FunPtr (CInt -> Ptr CChar -> CInt -> IO ()) + -> CInt -> Ptr CChar -> CInt -> IO () + +{-# NOINLINE ptr_glutChangeToSubMenu #-} +ptr_glutChangeToSubMenu :: FunPtr a +ptr_glutChangeToSubMenu = unsafePerformIO $ getAPIEntry "glutChangeToSubMenu" + +-- glutCloseFunc --------------------------------------------------------------- + +glutCloseFunc :: MonadIO m => FunPtr CloseFunc -> m () +glutCloseFunc v1 = liftIO $ dyn_glutCloseFunc ptr_glutCloseFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutCloseFunc + :: FunPtr (FunPtr CloseFunc -> IO ()) + -> FunPtr CloseFunc -> IO () + +{-# NOINLINE ptr_glutCloseFunc #-} +ptr_glutCloseFunc :: FunPtr a +ptr_glutCloseFunc = unsafePerformIO $ getAPIEntry "glutCloseFunc" + +-- glutCopyColormap ------------------------------------------------------------ + +glutCopyColormap :: MonadIO m => CInt -> m () +glutCopyColormap v1 = liftIO $ dyn_glutCopyColormap ptr_glutCopyColormap v1 + +foreign import CALLCONV "dynamic" dyn_glutCopyColormap + :: FunPtr (CInt -> IO ()) + -> CInt -> IO () + +{-# NOINLINE ptr_glutCopyColormap #-} +ptr_glutCopyColormap :: FunPtr a +ptr_glutCopyColormap = unsafePerformIO $ getAPIEntry "glutCopyColormap" + +-- glutCreateMenu -------------------------------------------------------------- + +glutCreateMenu :: MonadIO m => FunPtr MenuFunc -> m CInt +glutCreateMenu v1 = liftIO $ dyn_glutCreateMenu ptr_glutCreateMenu v1 + +foreign import CALLCONV "dynamic" dyn_glutCreateMenu + :: FunPtr (FunPtr MenuFunc -> IO CInt) + -> FunPtr MenuFunc -> IO CInt + +{-# NOINLINE ptr_glutCreateMenu #-} +ptr_glutCreateMenu :: FunPtr a +ptr_glutCreateMenu = unsafePerformIO $ getAPIEntry "glutCreateMenu" + +-- glutCreateSubWindow --------------------------------------------------------- + +glutCreateSubWindow :: MonadIO m => CInt -> CInt -> CInt -> CInt -> CInt -> m CInt +glutCreateSubWindow v1 v2 v3 v4 v5 = liftIO $ dyn_glutCreateSubWindow ptr_glutCreateSubWindow v1 v2 v3 v4 v5 + +foreign import CALLCONV "dynamic" dyn_glutCreateSubWindow + :: FunPtr (CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt) + -> CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt + +{-# NOINLINE ptr_glutCreateSubWindow #-} +ptr_glutCreateSubWindow :: FunPtr a +ptr_glutCreateSubWindow = unsafePerformIO $ getAPIEntry "glutCreateSubWindow" + +-- glutCreateWindow ------------------------------------------------------------ + +glutCreateWindow :: MonadIO m => Ptr CChar -> m CInt +glutCreateWindow v1 = liftIO $ dyn_glutCreateWindow ptr_glutCreateWindow v1 + +foreign import CALLCONV "dynamic" dyn_glutCreateWindow + :: FunPtr (Ptr CChar -> IO CInt) + -> Ptr CChar -> IO CInt + +{-# NOINLINE ptr_glutCreateWindow #-} +ptr_glutCreateWindow :: FunPtr a +ptr_glutCreateWindow = unsafePerformIO $ getAPIEntry "glutCreateWindow" + +-- glutDestroyMenu ------------------------------------------------------------- + +glutDestroyMenu :: MonadIO m => CInt -> m () +glutDestroyMenu v1 = liftIO $ dyn_glutDestroyMenu ptr_glutDestroyMenu v1 + +foreign import CALLCONV "dynamic" dyn_glutDestroyMenu + :: FunPtr (CInt -> IO ()) + -> CInt -> IO () + +{-# NOINLINE ptr_glutDestroyMenu #-} +ptr_glutDestroyMenu :: FunPtr a +ptr_glutDestroyMenu = unsafePerformIO $ getAPIEntry "glutDestroyMenu" + +-- glutDestroyWindow ----------------------------------------------------------- + +glutDestroyWindow :: MonadIO m => CInt -> m () +glutDestroyWindow v1 = liftIO $ dyn_glutDestroyWindow ptr_glutDestroyWindow v1 + +foreign import CALLCONV "dynamic" dyn_glutDestroyWindow + :: FunPtr (CInt -> IO ()) + -> CInt -> IO () + +{-# NOINLINE ptr_glutDestroyWindow #-} +ptr_glutDestroyWindow :: FunPtr a +ptr_glutDestroyWindow = unsafePerformIO $ getAPIEntry "glutDestroyWindow" + +-- glutDetachMenu -------------------------------------------------------------- + +glutDetachMenu :: MonadIO m => CInt -> m () +glutDetachMenu v1 = liftIO $ dyn_glutDetachMenu ptr_glutDetachMenu v1 + +foreign import CALLCONV "dynamic" dyn_glutDetachMenu + :: FunPtr (CInt -> IO ()) + -> CInt -> IO () + +{-# NOINLINE ptr_glutDetachMenu #-} +ptr_glutDetachMenu :: FunPtr a +ptr_glutDetachMenu = unsafePerformIO $ getAPIEntry "glutDetachMenu" + +-- glutDeviceGet --------------------------------------------------------------- + +glutDeviceGet :: MonadIO m => GLenum -> m CInt +glutDeviceGet v1 = liftIO $ dyn_glutDeviceGet ptr_glutDeviceGet v1 + +foreign import CALLCONV "dynamic" dyn_glutDeviceGet + :: FunPtr (GLenum -> IO CInt) + -> GLenum -> IO CInt + +{-# NOINLINE ptr_glutDeviceGet #-} +ptr_glutDeviceGet :: FunPtr a +ptr_glutDeviceGet = unsafePerformIO $ getAPIEntry "glutDeviceGet" + +-- glutDialsFunc --------------------------------------------------------------- + +glutDialsFunc :: MonadIO m => FunPtr DialsFunc -> m () +glutDialsFunc v1 = liftIO $ dyn_glutDialsFunc ptr_glutDialsFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutDialsFunc + :: FunPtr (FunPtr DialsFunc -> IO ()) + -> FunPtr DialsFunc -> IO () + +{-# NOINLINE ptr_glutDialsFunc #-} +ptr_glutDialsFunc :: FunPtr a +ptr_glutDialsFunc = unsafePerformIO $ getAPIEntry "glutDialsFunc" + +-- glutDisplayFunc ------------------------------------------------------------- + +glutDisplayFunc :: MonadIO m => FunPtr DisplayFunc -> m () +glutDisplayFunc v1 = liftIO $ dyn_glutDisplayFunc ptr_glutDisplayFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutDisplayFunc + :: FunPtr (FunPtr DisplayFunc -> IO ()) + -> FunPtr DisplayFunc -> IO () + +{-# NOINLINE ptr_glutDisplayFunc #-} +ptr_glutDisplayFunc :: FunPtr a +ptr_glutDisplayFunc = unsafePerformIO $ getAPIEntry "glutDisplayFunc" + +-- glutEnterGameMode ----------------------------------------------------------- + +glutEnterGameMode :: MonadIO m => m CInt +glutEnterGameMode = liftIO $ dyn_glutEnterGameMode ptr_glutEnterGameMode + +foreign import CALLCONV "dynamic" dyn_glutEnterGameMode + :: FunPtr (IO CInt) + -> IO CInt + +{-# NOINLINE ptr_glutEnterGameMode #-} +ptr_glutEnterGameMode :: FunPtr a +ptr_glutEnterGameMode = unsafePerformIO $ getAPIEntry "glutEnterGameMode" + +-- glutEntryFunc --------------------------------------------------------------- + +glutEntryFunc :: MonadIO m => FunPtr EntryFunc -> m () +glutEntryFunc v1 = liftIO $ dyn_glutEntryFunc ptr_glutEntryFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutEntryFunc + :: FunPtr (FunPtr EntryFunc -> IO ()) + -> FunPtr EntryFunc -> IO () + +{-# NOINLINE ptr_glutEntryFunc #-} +ptr_glutEntryFunc :: FunPtr a +ptr_glutEntryFunc = unsafePerformIO $ getAPIEntry "glutEntryFunc" + +-- glutEstablishOverlay -------------------------------------------------------- + +glutEstablishOverlay :: MonadIO m => m () +glutEstablishOverlay = liftIO $ dyn_glutEstablishOverlay ptr_glutEstablishOverlay + +foreign import CALLCONV "dynamic" dyn_glutEstablishOverlay + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutEstablishOverlay #-} +ptr_glutEstablishOverlay :: FunPtr a +ptr_glutEstablishOverlay = unsafePerformIO $ getAPIEntry "glutEstablishOverlay" + +-- glutExit -------------------------------------------------------------------- + +glutExit :: MonadIO m => m () +glutExit = liftIO $ dyn_glutExit ptr_glutExit + +foreign import CALLCONV "dynamic" dyn_glutExit + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutExit #-} +ptr_glutExit :: FunPtr a +ptr_glutExit = unsafePerformIO $ getAPIEntry "glutExit" + +-- glutExtensionSupported ------------------------------------------------------ + +glutExtensionSupported :: MonadIO m => Ptr CChar -> m CInt +glutExtensionSupported v1 = liftIO $ dyn_glutExtensionSupported ptr_glutExtensionSupported v1 + +foreign import CALLCONV "dynamic" dyn_glutExtensionSupported + :: FunPtr (Ptr CChar -> IO CInt) + -> Ptr CChar -> IO CInt + +{-# NOINLINE ptr_glutExtensionSupported #-} +ptr_glutExtensionSupported :: FunPtr a +ptr_glutExtensionSupported = unsafePerformIO $ getAPIEntry "glutExtensionSupported" + +-- glutForceJoystickFunc ------------------------------------------------------- + +glutForceJoystickFunc :: MonadIO m => m () +glutForceJoystickFunc = liftIO $ dyn_glutForceJoystickFunc ptr_glutForceJoystickFunc + +foreign import CALLCONV "dynamic" dyn_glutForceJoystickFunc + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutForceJoystickFunc #-} +ptr_glutForceJoystickFunc :: FunPtr a +ptr_glutForceJoystickFunc = unsafePerformIO $ getAPIEntry "glutForceJoystickFunc" + +-- glutFullScreen -------------------------------------------------------------- + +glutFullScreen :: MonadIO m => m () +glutFullScreen = liftIO $ dyn_glutFullScreen ptr_glutFullScreen + +foreign import CALLCONV "dynamic" dyn_glutFullScreen + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutFullScreen #-} +ptr_glutFullScreen :: FunPtr a +ptr_glutFullScreen = unsafePerformIO $ getAPIEntry "glutFullScreen" + +-- glutFullScreenToggle -------------------------------------------------------- + +glutFullScreenToggle :: MonadIO m => m () +glutFullScreenToggle = liftIO $ dyn_glutFullScreenToggle ptr_glutFullScreenToggle + +foreign import CALLCONV "dynamic" dyn_glutFullScreenToggle + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutFullScreenToggle #-} +ptr_glutFullScreenToggle :: FunPtr a +ptr_glutFullScreenToggle = unsafePerformIO $ getAPIEntry "glutFullScreenToggle" + +-- glutGameModeGet ------------------------------------------------------------- + +glutGameModeGet :: MonadIO m => GLenum -> m CInt +glutGameModeGet v1 = liftIO $ dyn_glutGameModeGet ptr_glutGameModeGet v1 + +foreign import CALLCONV "dynamic" dyn_glutGameModeGet + :: FunPtr (GLenum -> IO CInt) + -> GLenum -> IO CInt + +{-# NOINLINE ptr_glutGameModeGet #-} +ptr_glutGameModeGet :: FunPtr a +ptr_glutGameModeGet = unsafePerformIO $ getAPIEntry "glutGameModeGet" + +-- glutGameModeString ---------------------------------------------------------- + +glutGameModeString :: MonadIO m => Ptr CChar -> m () +glutGameModeString v1 = liftIO $ dyn_glutGameModeString ptr_glutGameModeString v1 + +foreign import CALLCONV "dynamic" dyn_glutGameModeString + :: FunPtr (Ptr CChar -> IO ()) + -> Ptr CChar -> IO () + +{-# NOINLINE ptr_glutGameModeString #-} +ptr_glutGameModeString :: FunPtr a +ptr_glutGameModeString = unsafePerformIO $ getAPIEntry "glutGameModeString" + +-- glutGet --------------------------------------------------------------------- + +glutGet :: MonadIO m => GLenum -> m CInt +glutGet v1 = liftIO $ dyn_glutGet ptr_glutGet v1 + +foreign import CALLCONV "dynamic" dyn_glutGet + :: FunPtr (GLenum -> IO CInt) + -> GLenum -> IO CInt + +{-# NOINLINE ptr_glutGet #-} +ptr_glutGet :: FunPtr a +ptr_glutGet = unsafePerformIO $ getAPIEntry "glutGet" + +-- glutGetColor ---------------------------------------------------------------- + +glutGetColor :: MonadIO m => CInt -> CInt -> m GLfloat +glutGetColor v1 v2 = liftIO $ dyn_glutGetColor ptr_glutGetColor v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutGetColor + :: FunPtr (CInt -> CInt -> IO GLfloat) + -> CInt -> CInt -> IO GLfloat + +{-# NOINLINE ptr_glutGetColor #-} +ptr_glutGetColor :: FunPtr a +ptr_glutGetColor = unsafePerformIO $ getAPIEntry "glutGetColor" + +-- glutGetMenu ----------------------------------------------------------------- + +glutGetMenu :: MonadIO m => m CInt +glutGetMenu = liftIO $ dyn_glutGetMenu ptr_glutGetMenu + +foreign import CALLCONV "dynamic" dyn_glutGetMenu + :: FunPtr (IO CInt) + -> IO CInt + +{-# NOINLINE ptr_glutGetMenu #-} +ptr_glutGetMenu :: FunPtr a +ptr_glutGetMenu = unsafePerformIO $ getAPIEntry "glutGetMenu" + +-- glutGetMenuData ------------------------------------------------------------- + +glutGetMenuData :: MonadIO m => m (Ptr a) +glutGetMenuData = liftIO $ dyn_glutGetMenuData ptr_glutGetMenuData + +foreign import CALLCONV "dynamic" dyn_glutGetMenuData + :: FunPtr (IO (Ptr a)) + -> IO (Ptr a) + +{-# NOINLINE ptr_glutGetMenuData #-} +ptr_glutGetMenuData :: FunPtr a +ptr_glutGetMenuData = unsafePerformIO $ getAPIEntry "glutGetMenuData" + +-- glutGetModeValues ----------------------------------------------------------- + +glutGetModeValues :: MonadIO m => GLenum -> Ptr CInt -> m (Ptr CInt) +glutGetModeValues v1 v2 = liftIO $ dyn_glutGetModeValues ptr_glutGetModeValues v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutGetModeValues + :: FunPtr (GLenum -> Ptr CInt -> IO (Ptr CInt)) + -> GLenum -> Ptr CInt -> IO (Ptr CInt) + +{-# NOINLINE ptr_glutGetModeValues #-} +ptr_glutGetModeValues :: FunPtr a +ptr_glutGetModeValues = unsafePerformIO $ getAPIEntry "glutGetModeValues" + +-- glutGetModifiers ------------------------------------------------------------ + +glutGetModifiers :: MonadIO m => m CInt +glutGetModifiers = liftIO $ dyn_glutGetModifiers ptr_glutGetModifiers + +foreign import CALLCONV "dynamic" dyn_glutGetModifiers + :: FunPtr (IO CInt) + -> IO CInt + +{-# NOINLINE ptr_glutGetModifiers #-} +ptr_glutGetModifiers :: FunPtr a +ptr_glutGetModifiers = unsafePerformIO $ getAPIEntry "glutGetModifiers" + +-- glutGetProcAddress ---------------------------------------------------------- + +glutGetProcAddress :: MonadIO m => Ptr CChar -> m (FunPtr a) +glutGetProcAddress v1 = liftIO $ dyn_glutGetProcAddress ptr_glutGetProcAddress v1 + +foreign import CALLCONV "dynamic" dyn_glutGetProcAddress + :: FunPtr (Ptr CChar -> IO (FunPtr a)) + -> Ptr CChar -> IO (FunPtr a) + +{-# NOINLINE ptr_glutGetProcAddress #-} +ptr_glutGetProcAddress :: FunPtr a +ptr_glutGetProcAddress = unsafePerformIO $ getAPIEntry "glutGetProcAddress" + +-- glutGetWindow --------------------------------------------------------------- + +glutGetWindow :: MonadIO m => m CInt +glutGetWindow = liftIO $ dyn_glutGetWindow ptr_glutGetWindow + +foreign import CALLCONV "dynamic" dyn_glutGetWindow + :: FunPtr (IO CInt) + -> IO CInt + +{-# NOINLINE ptr_glutGetWindow #-} +ptr_glutGetWindow :: FunPtr a +ptr_glutGetWindow = unsafePerformIO $ getAPIEntry "glutGetWindow" + +-- glutGetWindowData ----------------------------------------------------------- + +glutGetWindowData :: MonadIO m => m (Ptr a) +glutGetWindowData = liftIO $ dyn_glutGetWindowData ptr_glutGetWindowData + +foreign import CALLCONV "dynamic" dyn_glutGetWindowData + :: FunPtr (IO (Ptr a)) + -> IO (Ptr a) + +{-# NOINLINE ptr_glutGetWindowData #-} +ptr_glutGetWindowData :: FunPtr a +ptr_glutGetWindowData = unsafePerformIO $ getAPIEntry "glutGetWindowData" + +-- glutHideOverlay ------------------------------------------------------------- + +glutHideOverlay :: MonadIO m => m () +glutHideOverlay = liftIO $ dyn_glutHideOverlay ptr_glutHideOverlay + +foreign import CALLCONV "dynamic" dyn_glutHideOverlay + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutHideOverlay #-} +ptr_glutHideOverlay :: FunPtr a +ptr_glutHideOverlay = unsafePerformIO $ getAPIEntry "glutHideOverlay" + +-- glutHideWindow -------------------------------------------------------------- + +glutHideWindow :: MonadIO m => m () +glutHideWindow = liftIO $ dyn_glutHideWindow ptr_glutHideWindow + +foreign import CALLCONV "dynamic" dyn_glutHideWindow + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutHideWindow #-} +ptr_glutHideWindow :: FunPtr a +ptr_glutHideWindow = unsafePerformIO $ getAPIEntry "glutHideWindow" + +-- glutIconifyWindow ----------------------------------------------------------- + +glutIconifyWindow :: MonadIO m => m () +glutIconifyWindow = liftIO $ dyn_glutIconifyWindow ptr_glutIconifyWindow + +foreign import CALLCONV "dynamic" dyn_glutIconifyWindow + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutIconifyWindow #-} +ptr_glutIconifyWindow :: FunPtr a +ptr_glutIconifyWindow = unsafePerformIO $ getAPIEntry "glutIconifyWindow" + +-- glutIdleFunc ---------------------------------------------------------------- + +glutIdleFunc :: MonadIO m => FunPtr IdleFunc -> m () +glutIdleFunc v1 = liftIO $ dyn_glutIdleFunc ptr_glutIdleFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutIdleFunc + :: FunPtr (FunPtr IdleFunc -> IO ()) + -> FunPtr IdleFunc -> IO () + +{-# NOINLINE ptr_glutIdleFunc #-} +ptr_glutIdleFunc :: FunPtr a +ptr_glutIdleFunc = unsafePerformIO $ getAPIEntry "glutIdleFunc" + +-- glutIgnoreKeyRepeat --------------------------------------------------------- + +glutIgnoreKeyRepeat :: MonadIO m => CInt -> m () +glutIgnoreKeyRepeat v1 = liftIO $ dyn_glutIgnoreKeyRepeat ptr_glutIgnoreKeyRepeat v1 + +foreign import CALLCONV "dynamic" dyn_glutIgnoreKeyRepeat + :: FunPtr (CInt -> IO ()) + -> CInt -> IO () + +{-# NOINLINE ptr_glutIgnoreKeyRepeat #-} +ptr_glutIgnoreKeyRepeat :: FunPtr a +ptr_glutIgnoreKeyRepeat = unsafePerformIO $ getAPIEntry "glutIgnoreKeyRepeat" + +-- glutInit -------------------------------------------------------------------- + +glutInit :: MonadIO m => Ptr CInt -> Ptr (Ptr CChar) -> m () +glutInit v1 v2 = liftIO $ dyn_glutInit ptr_glutInit v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutInit + :: FunPtr (Ptr CInt -> Ptr (Ptr CChar) -> IO ()) + -> Ptr CInt -> Ptr (Ptr CChar) -> IO () + +{-# NOINLINE ptr_glutInit #-} +ptr_glutInit :: FunPtr a +ptr_glutInit = unsafePerformIO $ getAPIEntry "glutInit" + +-- glutInitContextFlags -------------------------------------------------------- + +glutInitContextFlags :: MonadIO m => CInt -> m () +glutInitContextFlags v1 = liftIO $ dyn_glutInitContextFlags ptr_glutInitContextFlags v1 + +foreign import CALLCONV "dynamic" dyn_glutInitContextFlags + :: FunPtr (CInt -> IO ()) + -> CInt -> IO () + +{-# NOINLINE ptr_glutInitContextFlags #-} +ptr_glutInitContextFlags :: FunPtr a +ptr_glutInitContextFlags = unsafePerformIO $ getAPIEntry "glutInitContextFlags" + +-- glutInitContextFunc --------------------------------------------------------- + +glutInitContextFunc :: MonadIO m => FunPtr InitContextFunc -> m () +glutInitContextFunc v1 = liftIO $ dyn_glutInitContextFunc ptr_glutInitContextFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutInitContextFunc + :: FunPtr (FunPtr InitContextFunc -> IO ()) + -> FunPtr InitContextFunc -> IO () + +{-# NOINLINE ptr_glutInitContextFunc #-} +ptr_glutInitContextFunc :: FunPtr a +ptr_glutInitContextFunc = unsafePerformIO $ getAPIEntry "glutInitContextFunc" + +-- glutInitContextProfile ------------------------------------------------------ + +glutInitContextProfile :: MonadIO m => CInt -> m () +glutInitContextProfile v1 = liftIO $ dyn_glutInitContextProfile ptr_glutInitContextProfile v1 + +foreign import CALLCONV "dynamic" dyn_glutInitContextProfile + :: FunPtr (CInt -> IO ()) + -> CInt -> IO () + +{-# NOINLINE ptr_glutInitContextProfile #-} +ptr_glutInitContextProfile :: FunPtr a +ptr_glutInitContextProfile = unsafePerformIO $ getAPIEntry "glutInitContextProfile" + +-- glutInitContextVersion ------------------------------------------------------ + +glutInitContextVersion :: MonadIO m => CInt -> CInt -> m () +glutInitContextVersion v1 v2 = liftIO $ dyn_glutInitContextVersion ptr_glutInitContextVersion v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutInitContextVersion + :: FunPtr (CInt -> CInt -> IO ()) + -> CInt -> CInt -> IO () + +{-# NOINLINE ptr_glutInitContextVersion #-} +ptr_glutInitContextVersion :: FunPtr a +ptr_glutInitContextVersion = unsafePerformIO $ getAPIEntry "glutInitContextVersion" + +-- glutInitDisplayMode --------------------------------------------------------- + +glutInitDisplayMode :: MonadIO m => CUInt -> m () +glutInitDisplayMode v1 = liftIO $ dyn_glutInitDisplayMode ptr_glutInitDisplayMode v1 + +foreign import CALLCONV "dynamic" dyn_glutInitDisplayMode + :: FunPtr (CUInt -> IO ()) + -> CUInt -> IO () + +{-# NOINLINE ptr_glutInitDisplayMode #-} +ptr_glutInitDisplayMode :: FunPtr a +ptr_glutInitDisplayMode = unsafePerformIO $ getAPIEntry "glutInitDisplayMode" + +-- glutInitDisplayString ------------------------------------------------------- + +glutInitDisplayString :: MonadIO m => Ptr CChar -> m () +glutInitDisplayString v1 = liftIO $ dyn_glutInitDisplayString ptr_glutInitDisplayString v1 + +foreign import CALLCONV "dynamic" dyn_glutInitDisplayString + :: FunPtr (Ptr CChar -> IO ()) + -> Ptr CChar -> IO () + +{-# NOINLINE ptr_glutInitDisplayString #-} +ptr_glutInitDisplayString :: FunPtr a +ptr_glutInitDisplayString = unsafePerformIO $ getAPIEntry "glutInitDisplayString" + +-- glutInitWindowPosition ------------------------------------------------------ + +glutInitWindowPosition :: MonadIO m => CInt -> CInt -> m () +glutInitWindowPosition v1 v2 = liftIO $ dyn_glutInitWindowPosition ptr_glutInitWindowPosition v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutInitWindowPosition + :: FunPtr (CInt -> CInt -> IO ()) + -> CInt -> CInt -> IO () + +{-# NOINLINE ptr_glutInitWindowPosition #-} +ptr_glutInitWindowPosition :: FunPtr a +ptr_glutInitWindowPosition = unsafePerformIO $ getAPIEntry "glutInitWindowPosition" + +-- glutInitWindowSize ---------------------------------------------------------- + +glutInitWindowSize :: MonadIO m => CInt -> CInt -> m () +glutInitWindowSize v1 v2 = liftIO $ dyn_glutInitWindowSize ptr_glutInitWindowSize v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutInitWindowSize + :: FunPtr (CInt -> CInt -> IO ()) + -> CInt -> CInt -> IO () + +{-# NOINLINE ptr_glutInitWindowSize #-} +ptr_glutInitWindowSize :: FunPtr a +ptr_glutInitWindowSize = unsafePerformIO $ getAPIEntry "glutInitWindowSize" + +-- glutJoystickFunc ------------------------------------------------------------ + +glutJoystickFunc :: MonadIO m => FunPtr JoystickFunc -> CInt -> m () +glutJoystickFunc v1 v2 = liftIO $ dyn_glutJoystickFunc ptr_glutJoystickFunc v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutJoystickFunc + :: FunPtr (FunPtr JoystickFunc -> CInt -> IO ()) + -> FunPtr JoystickFunc -> CInt -> IO () + +{-# NOINLINE ptr_glutJoystickFunc #-} +ptr_glutJoystickFunc :: FunPtr a +ptr_glutJoystickFunc = unsafePerformIO $ getAPIEntry "glutJoystickFunc" + +-- glutKeyboardFunc ------------------------------------------------------------ + +glutKeyboardFunc :: MonadIO m => FunPtr KeyboardFunc -> m () +glutKeyboardFunc v1 = liftIO $ dyn_glutKeyboardFunc ptr_glutKeyboardFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutKeyboardFunc + :: FunPtr (FunPtr KeyboardFunc -> IO ()) + -> FunPtr KeyboardFunc -> IO () + +{-# NOINLINE ptr_glutKeyboardFunc #-} +ptr_glutKeyboardFunc :: FunPtr a +ptr_glutKeyboardFunc = unsafePerformIO $ getAPIEntry "glutKeyboardFunc" + +-- glutKeyboardUpFunc ---------------------------------------------------------- + +glutKeyboardUpFunc :: MonadIO m => FunPtr KeyboardUpFunc -> m () +glutKeyboardUpFunc v1 = liftIO $ dyn_glutKeyboardUpFunc ptr_glutKeyboardUpFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutKeyboardUpFunc + :: FunPtr (FunPtr KeyboardUpFunc -> IO ()) + -> FunPtr KeyboardUpFunc -> IO () + +{-# NOINLINE ptr_glutKeyboardUpFunc #-} +ptr_glutKeyboardUpFunc :: FunPtr a +ptr_glutKeyboardUpFunc = unsafePerformIO $ getAPIEntry "glutKeyboardUpFunc" + +-- glutLayerGet ---------------------------------------------------------------- + +glutLayerGet :: MonadIO m => GLenum -> m CInt +glutLayerGet v1 = liftIO $ dyn_glutLayerGet ptr_glutLayerGet v1 + +foreign import CALLCONV "dynamic" dyn_glutLayerGet + :: FunPtr (GLenum -> IO CInt) + -> GLenum -> IO CInt + +{-# NOINLINE ptr_glutLayerGet #-} +ptr_glutLayerGet :: FunPtr a +ptr_glutLayerGet = unsafePerformIO $ getAPIEntry "glutLayerGet" + +-- glutLeaveFullScreen --------------------------------------------------------- + +glutLeaveFullScreen :: MonadIO m => m () +glutLeaveFullScreen = liftIO $ dyn_glutLeaveFullScreen ptr_glutLeaveFullScreen + +foreign import CALLCONV "dynamic" dyn_glutLeaveFullScreen + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutLeaveFullScreen #-} +ptr_glutLeaveFullScreen :: FunPtr a +ptr_glutLeaveFullScreen = unsafePerformIO $ getAPIEntry "glutLeaveFullScreen" + +-- glutLeaveGameMode ----------------------------------------------------------- + +glutLeaveGameMode :: MonadIO m => m () +glutLeaveGameMode = liftIO $ dyn_glutLeaveGameMode ptr_glutLeaveGameMode + +foreign import CALLCONV "dynamic" dyn_glutLeaveGameMode + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutLeaveGameMode #-} +ptr_glutLeaveGameMode :: FunPtr a +ptr_glutLeaveGameMode = unsafePerformIO $ getAPIEntry "glutLeaveGameMode" + +-- glutLeaveMainLoop ----------------------------------------------------------- + +glutLeaveMainLoop :: MonadIO m => m () +glutLeaveMainLoop = liftIO $ dyn_glutLeaveMainLoop ptr_glutLeaveMainLoop + +foreign import CALLCONV "dynamic" dyn_glutLeaveMainLoop + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutLeaveMainLoop #-} +ptr_glutLeaveMainLoop :: FunPtr a +ptr_glutLeaveMainLoop = unsafePerformIO $ getAPIEntry "glutLeaveMainLoop" + +-- glutMainLoop ---------------------------------------------------------------- + +glutMainLoop :: MonadIO m => m () +glutMainLoop = liftIO $ dyn_glutMainLoop ptr_glutMainLoop + +foreign import CALLCONV "dynamic" dyn_glutMainLoop + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutMainLoop #-} +ptr_glutMainLoop :: FunPtr a +ptr_glutMainLoop = unsafePerformIO $ getAPIEntry "glutMainLoop" + +-- glutMainLoopEvent ----------------------------------------------------------- + +glutMainLoopEvent :: MonadIO m => m () +glutMainLoopEvent = liftIO $ dyn_glutMainLoopEvent ptr_glutMainLoopEvent + +foreign import CALLCONV "dynamic" dyn_glutMainLoopEvent + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutMainLoopEvent #-} +ptr_glutMainLoopEvent :: FunPtr a +ptr_glutMainLoopEvent = unsafePerformIO $ getAPIEntry "glutMainLoopEvent" + +-- glutMenuDestroyFunc --------------------------------------------------------- + +glutMenuDestroyFunc :: MonadIO m => FunPtr MenuDestroyFunc -> m () +glutMenuDestroyFunc v1 = liftIO $ dyn_glutMenuDestroyFunc ptr_glutMenuDestroyFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutMenuDestroyFunc + :: FunPtr (FunPtr MenuDestroyFunc -> IO ()) + -> FunPtr MenuDestroyFunc -> IO () + +{-# NOINLINE ptr_glutMenuDestroyFunc #-} +ptr_glutMenuDestroyFunc :: FunPtr a +ptr_glutMenuDestroyFunc = unsafePerformIO $ getAPIEntry "glutMenuDestroyFunc" + +-- glutMenuStateFunc ----------------------------------------------------------- + +glutMenuStateFunc :: MonadIO m => FunPtr MenuStateFunc -> m () +glutMenuStateFunc v1 = liftIO $ dyn_glutMenuStateFunc ptr_glutMenuStateFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutMenuStateFunc + :: FunPtr (FunPtr MenuStateFunc -> IO ()) + -> FunPtr MenuStateFunc -> IO () + +{-# NOINLINE ptr_glutMenuStateFunc #-} +ptr_glutMenuStateFunc :: FunPtr a +ptr_glutMenuStateFunc = unsafePerformIO $ getAPIEntry "glutMenuStateFunc" + +-- glutMenuStatusFunc ---------------------------------------------------------- + +glutMenuStatusFunc :: MonadIO m => FunPtr MenuStatusFunc -> m () +glutMenuStatusFunc v1 = liftIO $ dyn_glutMenuStatusFunc ptr_glutMenuStatusFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutMenuStatusFunc + :: FunPtr (FunPtr MenuStatusFunc -> IO ()) + -> FunPtr MenuStatusFunc -> IO () + +{-# NOINLINE ptr_glutMenuStatusFunc #-} +ptr_glutMenuStatusFunc :: FunPtr a +ptr_glutMenuStatusFunc = unsafePerformIO $ getAPIEntry "glutMenuStatusFunc" + +-- glutMotionFunc -------------------------------------------------------------- + +glutMotionFunc :: MonadIO m => FunPtr MotionFunc -> m () +glutMotionFunc v1 = liftIO $ dyn_glutMotionFunc ptr_glutMotionFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutMotionFunc + :: FunPtr (FunPtr MotionFunc -> IO ()) + -> FunPtr MotionFunc -> IO () + +{-# NOINLINE ptr_glutMotionFunc #-} +ptr_glutMotionFunc :: FunPtr a +ptr_glutMotionFunc = unsafePerformIO $ getAPIEntry "glutMotionFunc" + +-- glutMouseFunc --------------------------------------------------------------- + +glutMouseFunc :: MonadIO m => FunPtr MouseFunc -> m () +glutMouseFunc v1 = liftIO $ dyn_glutMouseFunc ptr_glutMouseFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutMouseFunc + :: FunPtr (FunPtr MouseFunc -> IO ()) + -> FunPtr MouseFunc -> IO () + +{-# NOINLINE ptr_glutMouseFunc #-} +ptr_glutMouseFunc :: FunPtr a +ptr_glutMouseFunc = unsafePerformIO $ getAPIEntry "glutMouseFunc" + +-- glutMouseWheelFunc ---------------------------------------------------------- + +glutMouseWheelFunc :: MonadIO m => FunPtr MouseWheelFunc -> m () +glutMouseWheelFunc v1 = liftIO $ dyn_glutMouseWheelFunc ptr_glutMouseWheelFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutMouseWheelFunc + :: FunPtr (FunPtr MouseWheelFunc -> IO ()) + -> FunPtr MouseWheelFunc -> IO () + +{-# NOINLINE ptr_glutMouseWheelFunc #-} +ptr_glutMouseWheelFunc :: FunPtr a +ptr_glutMouseWheelFunc = unsafePerformIO $ getAPIEntry "glutMouseWheelFunc" + +-- glutMultiButtonFunc --------------------------------------------------------- + +glutMultiButtonFunc :: MonadIO m => FunPtr MultiButtonFunc -> m () +glutMultiButtonFunc v1 = liftIO $ dyn_glutMultiButtonFunc ptr_glutMultiButtonFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutMultiButtonFunc + :: FunPtr (FunPtr MultiButtonFunc -> IO ()) + -> FunPtr MultiButtonFunc -> IO () + +{-# NOINLINE ptr_glutMultiButtonFunc #-} +ptr_glutMultiButtonFunc :: FunPtr a +ptr_glutMultiButtonFunc = unsafePerformIO $ getAPIEntry "glutMultiButtonFunc" + +-- glutMultiEntryFunc ---------------------------------------------------------- + +glutMultiEntryFunc :: MonadIO m => FunPtr MultiEntryFunc -> m () +glutMultiEntryFunc v1 = liftIO $ dyn_glutMultiEntryFunc ptr_glutMultiEntryFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutMultiEntryFunc + :: FunPtr (FunPtr MultiEntryFunc -> IO ()) + -> FunPtr MultiEntryFunc -> IO () + +{-# NOINLINE ptr_glutMultiEntryFunc #-} +ptr_glutMultiEntryFunc :: FunPtr a +ptr_glutMultiEntryFunc = unsafePerformIO $ getAPIEntry "glutMultiEntryFunc" + +-- glutMultiMotionFunc --------------------------------------------------------- + +glutMultiMotionFunc :: MonadIO m => FunPtr MultiMotionFunc -> m () +glutMultiMotionFunc v1 = liftIO $ dyn_glutMultiMotionFunc ptr_glutMultiMotionFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutMultiMotionFunc + :: FunPtr (FunPtr MultiMotionFunc -> IO ()) + -> FunPtr MultiMotionFunc -> IO () + +{-# NOINLINE ptr_glutMultiMotionFunc #-} +ptr_glutMultiMotionFunc :: FunPtr a +ptr_glutMultiMotionFunc = unsafePerformIO $ getAPIEntry "glutMultiMotionFunc" + +-- glutMultiPassiveFunc -------------------------------------------------------- + +glutMultiPassiveFunc :: MonadIO m => FunPtr MultiPassiveFunc -> m () +glutMultiPassiveFunc v1 = liftIO $ dyn_glutMultiPassiveFunc ptr_glutMultiPassiveFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutMultiPassiveFunc + :: FunPtr (FunPtr MultiPassiveFunc -> IO ()) + -> FunPtr MultiPassiveFunc -> IO () + +{-# NOINLINE ptr_glutMultiPassiveFunc #-} +ptr_glutMultiPassiveFunc :: FunPtr a +ptr_glutMultiPassiveFunc = unsafePerformIO $ getAPIEntry "glutMultiPassiveFunc" + +-- glutOverlayDisplayFunc ------------------------------------------------------ + +glutOverlayDisplayFunc :: MonadIO m => FunPtr OverlayDisplayFunc -> m () +glutOverlayDisplayFunc v1 = liftIO $ dyn_glutOverlayDisplayFunc ptr_glutOverlayDisplayFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutOverlayDisplayFunc + :: FunPtr (FunPtr OverlayDisplayFunc -> IO ()) + -> FunPtr OverlayDisplayFunc -> IO () + +{-# NOINLINE ptr_glutOverlayDisplayFunc #-} +ptr_glutOverlayDisplayFunc :: FunPtr a +ptr_glutOverlayDisplayFunc = unsafePerformIO $ getAPIEntry "glutOverlayDisplayFunc" + +-- glutPassiveMotionFunc ------------------------------------------------------- + +glutPassiveMotionFunc :: MonadIO m => FunPtr PassiveMotionFunc -> m () +glutPassiveMotionFunc v1 = liftIO $ dyn_glutPassiveMotionFunc ptr_glutPassiveMotionFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutPassiveMotionFunc + :: FunPtr (FunPtr PassiveMotionFunc -> IO ()) + -> FunPtr PassiveMotionFunc -> IO () + +{-# NOINLINE ptr_glutPassiveMotionFunc #-} +ptr_glutPassiveMotionFunc :: FunPtr a +ptr_glutPassiveMotionFunc = unsafePerformIO $ getAPIEntry "glutPassiveMotionFunc" + +-- glutPopWindow --------------------------------------------------------------- + +glutPopWindow :: MonadIO m => m () +glutPopWindow = liftIO $ dyn_glutPopWindow ptr_glutPopWindow + +foreign import CALLCONV "dynamic" dyn_glutPopWindow + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutPopWindow #-} +ptr_glutPopWindow :: FunPtr a +ptr_glutPopWindow = unsafePerformIO $ getAPIEntry "glutPopWindow" + +-- glutPositionFunc ------------------------------------------------------------ + +glutPositionFunc :: MonadIO m => FunPtr PositionFunc -> m () +glutPositionFunc v1 = liftIO $ dyn_glutPositionFunc ptr_glutPositionFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutPositionFunc + :: FunPtr (FunPtr PositionFunc -> IO ()) + -> FunPtr PositionFunc -> IO () + +{-# NOINLINE ptr_glutPositionFunc #-} +ptr_glutPositionFunc :: FunPtr a +ptr_glutPositionFunc = unsafePerformIO $ getAPIEntry "glutPositionFunc" + +-- glutPositionWindow ---------------------------------------------------------- + +glutPositionWindow :: MonadIO m => CInt -> CInt -> m () +glutPositionWindow v1 v2 = liftIO $ dyn_glutPositionWindow ptr_glutPositionWindow v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutPositionWindow + :: FunPtr (CInt -> CInt -> IO ()) + -> CInt -> CInt -> IO () + +{-# NOINLINE ptr_glutPositionWindow #-} +ptr_glutPositionWindow :: FunPtr a +ptr_glutPositionWindow = unsafePerformIO $ getAPIEntry "glutPositionWindow" + +-- glutPostOverlayRedisplay ---------------------------------------------------- + +glutPostOverlayRedisplay :: MonadIO m => m () +glutPostOverlayRedisplay = liftIO $ dyn_glutPostOverlayRedisplay ptr_glutPostOverlayRedisplay + +foreign import CALLCONV "dynamic" dyn_glutPostOverlayRedisplay + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutPostOverlayRedisplay #-} +ptr_glutPostOverlayRedisplay :: FunPtr a +ptr_glutPostOverlayRedisplay = unsafePerformIO $ getAPIEntry "glutPostOverlayRedisplay" + +-- glutPostRedisplay ----------------------------------------------------------- + +glutPostRedisplay :: MonadIO m => m () +glutPostRedisplay = liftIO $ dyn_glutPostRedisplay ptr_glutPostRedisplay + +foreign import CALLCONV "dynamic" dyn_glutPostRedisplay + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutPostRedisplay #-} +ptr_glutPostRedisplay :: FunPtr a +ptr_glutPostRedisplay = unsafePerformIO $ getAPIEntry "glutPostRedisplay" + +-- glutPostWindowOverlayRedisplay ---------------------------------------------- + +glutPostWindowOverlayRedisplay :: MonadIO m => CInt -> m () +glutPostWindowOverlayRedisplay v1 = liftIO $ dyn_glutPostWindowOverlayRedisplay ptr_glutPostWindowOverlayRedisplay v1 + +foreign import CALLCONV "dynamic" dyn_glutPostWindowOverlayRedisplay + :: FunPtr (CInt -> IO ()) + -> CInt -> IO () + +{-# NOINLINE ptr_glutPostWindowOverlayRedisplay #-} +ptr_glutPostWindowOverlayRedisplay :: FunPtr a +ptr_glutPostWindowOverlayRedisplay = unsafePerformIO $ getAPIEntry "glutPostWindowOverlayRedisplay" + +-- glutPostWindowRedisplay ----------------------------------------------------- + +glutPostWindowRedisplay :: MonadIO m => CInt -> m () +glutPostWindowRedisplay v1 = liftIO $ dyn_glutPostWindowRedisplay ptr_glutPostWindowRedisplay v1 + +foreign import CALLCONV "dynamic" dyn_glutPostWindowRedisplay + :: FunPtr (CInt -> IO ()) + -> CInt -> IO () + +{-# NOINLINE ptr_glutPostWindowRedisplay #-} +ptr_glutPostWindowRedisplay :: FunPtr a +ptr_glutPostWindowRedisplay = unsafePerformIO $ getAPIEntry "glutPostWindowRedisplay" + +-- glutPushWindow -------------------------------------------------------------- + +glutPushWindow :: MonadIO m => m () +glutPushWindow = liftIO $ dyn_glutPushWindow ptr_glutPushWindow + +foreign import CALLCONV "dynamic" dyn_glutPushWindow + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutPushWindow #-} +ptr_glutPushWindow :: FunPtr a +ptr_glutPushWindow = unsafePerformIO $ getAPIEntry "glutPushWindow" + +-- glutRemoveMenuItem ---------------------------------------------------------- + +glutRemoveMenuItem :: MonadIO m => CInt -> m () +glutRemoveMenuItem v1 = liftIO $ dyn_glutRemoveMenuItem ptr_glutRemoveMenuItem v1 + +foreign import CALLCONV "dynamic" dyn_glutRemoveMenuItem + :: FunPtr (CInt -> IO ()) + -> CInt -> IO () + +{-# NOINLINE ptr_glutRemoveMenuItem #-} +ptr_glutRemoveMenuItem :: FunPtr a +ptr_glutRemoveMenuItem = unsafePerformIO $ getAPIEntry "glutRemoveMenuItem" + +-- glutRemoveOverlay ----------------------------------------------------------- + +glutRemoveOverlay :: MonadIO m => m () +glutRemoveOverlay = liftIO $ dyn_glutRemoveOverlay ptr_glutRemoveOverlay + +foreign import CALLCONV "dynamic" dyn_glutRemoveOverlay + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutRemoveOverlay #-} +ptr_glutRemoveOverlay :: FunPtr a +ptr_glutRemoveOverlay = unsafePerformIO $ getAPIEntry "glutRemoveOverlay" + +-- glutReportErrors ------------------------------------------------------------ + +glutReportErrors :: MonadIO m => m () +glutReportErrors = liftIO $ dyn_glutReportErrors ptr_glutReportErrors + +foreign import CALLCONV "dynamic" dyn_glutReportErrors + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutReportErrors #-} +ptr_glutReportErrors :: FunPtr a +ptr_glutReportErrors = unsafePerformIO $ getAPIEntry "glutReportErrors" + +-- glutReshapeFunc ------------------------------------------------------------- + +glutReshapeFunc :: MonadIO m => FunPtr ReshapeFunc -> m () +glutReshapeFunc v1 = liftIO $ dyn_glutReshapeFunc ptr_glutReshapeFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutReshapeFunc + :: FunPtr (FunPtr ReshapeFunc -> IO ()) + -> FunPtr ReshapeFunc -> IO () + +{-# NOINLINE ptr_glutReshapeFunc #-} +ptr_glutReshapeFunc :: FunPtr a +ptr_glutReshapeFunc = unsafePerformIO $ getAPIEntry "glutReshapeFunc" + +-- glutReshapeWindow ----------------------------------------------------------- + +glutReshapeWindow :: MonadIO m => CInt -> CInt -> m () +glutReshapeWindow v1 v2 = liftIO $ dyn_glutReshapeWindow ptr_glutReshapeWindow v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutReshapeWindow + :: FunPtr (CInt -> CInt -> IO ()) + -> CInt -> CInt -> IO () + +{-# NOINLINE ptr_glutReshapeWindow #-} +ptr_glutReshapeWindow :: FunPtr a +ptr_glutReshapeWindow = unsafePerformIO $ getAPIEntry "glutReshapeWindow" + +-- glutSetColor ---------------------------------------------------------------- + +glutSetColor :: MonadIO m => CInt -> GLfloat -> GLfloat -> GLfloat -> m () +glutSetColor v1 v2 v3 v4 = liftIO $ dyn_glutSetColor ptr_glutSetColor v1 v2 v3 v4 + +foreign import CALLCONV "dynamic" dyn_glutSetColor + :: FunPtr (CInt -> GLfloat -> GLfloat -> GLfloat -> IO ()) + -> CInt -> GLfloat -> GLfloat -> GLfloat -> IO () + +{-# NOINLINE ptr_glutSetColor #-} +ptr_glutSetColor :: FunPtr a +ptr_glutSetColor = unsafePerformIO $ getAPIEntry "glutSetColor" + +-- glutSetCursor --------------------------------------------------------------- + +glutSetCursor :: MonadIO m => CInt -> m () +glutSetCursor v1 = liftIO $ dyn_glutSetCursor ptr_glutSetCursor v1 + +foreign import CALLCONV "dynamic" dyn_glutSetCursor + :: FunPtr (CInt -> IO ()) + -> CInt -> IO () + +{-# NOINLINE ptr_glutSetCursor #-} +ptr_glutSetCursor :: FunPtr a +ptr_glutSetCursor = unsafePerformIO $ getAPIEntry "glutSetCursor" + +-- glutSetIconTitle ------------------------------------------------------------ + +glutSetIconTitle :: MonadIO m => Ptr CChar -> m () +glutSetIconTitle v1 = liftIO $ dyn_glutSetIconTitle ptr_glutSetIconTitle v1 + +foreign import CALLCONV "dynamic" dyn_glutSetIconTitle + :: FunPtr (Ptr CChar -> IO ()) + -> Ptr CChar -> IO () + +{-# NOINLINE ptr_glutSetIconTitle #-} +ptr_glutSetIconTitle :: FunPtr a +ptr_glutSetIconTitle = unsafePerformIO $ getAPIEntry "glutSetIconTitle" + +-- glutSetKeyRepeat ------------------------------------------------------------ + +glutSetKeyRepeat :: MonadIO m => CInt -> m () +glutSetKeyRepeat v1 = liftIO $ dyn_glutSetKeyRepeat ptr_glutSetKeyRepeat v1 + +foreign import CALLCONV "dynamic" dyn_glutSetKeyRepeat + :: FunPtr (CInt -> IO ()) + -> CInt -> IO () + +{-# NOINLINE ptr_glutSetKeyRepeat #-} +ptr_glutSetKeyRepeat :: FunPtr a +ptr_glutSetKeyRepeat = unsafePerformIO $ getAPIEntry "glutSetKeyRepeat" + +-- glutSetMenu ----------------------------------------------------------------- + +glutSetMenu :: MonadIO m => CInt -> m () +glutSetMenu v1 = liftIO $ dyn_glutSetMenu ptr_glutSetMenu v1 + +foreign import CALLCONV "dynamic" dyn_glutSetMenu + :: FunPtr (CInt -> IO ()) + -> CInt -> IO () + +{-# NOINLINE ptr_glutSetMenu #-} +ptr_glutSetMenu :: FunPtr a +ptr_glutSetMenu = unsafePerformIO $ getAPIEntry "glutSetMenu" + +-- glutSetMenuData ------------------------------------------------------------- + +glutSetMenuData :: MonadIO m => Ptr a -> m () +glutSetMenuData v1 = liftIO $ dyn_glutSetMenuData ptr_glutSetMenuData v1 + +foreign import CALLCONV "dynamic" dyn_glutSetMenuData + :: FunPtr (Ptr a -> IO ()) + -> Ptr a -> IO () + +{-# NOINLINE ptr_glutSetMenuData #-} +ptr_glutSetMenuData :: FunPtr a +ptr_glutSetMenuData = unsafePerformIO $ getAPIEntry "glutSetMenuData" + +-- glutSetMenuFont ------------------------------------------------------------- + +glutSetMenuFont :: MonadIO m => CInt -> Ptr a -> m () +glutSetMenuFont v1 v2 = liftIO $ dyn_glutSetMenuFont ptr_glutSetMenuFont v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutSetMenuFont + :: FunPtr (CInt -> Ptr a -> IO ()) + -> CInt -> Ptr a -> IO () + +{-# NOINLINE ptr_glutSetMenuFont #-} +ptr_glutSetMenuFont :: FunPtr a +ptr_glutSetMenuFont = unsafePerformIO $ getAPIEntry "glutSetMenuFont" + +-- glutSetOption --------------------------------------------------------------- + +glutSetOption :: MonadIO m => GLenum -> CInt -> m () +glutSetOption v1 v2 = liftIO $ dyn_glutSetOption ptr_glutSetOption v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutSetOption + :: FunPtr (GLenum -> CInt -> IO ()) + -> GLenum -> CInt -> IO () + +{-# NOINLINE ptr_glutSetOption #-} +ptr_glutSetOption :: FunPtr a +ptr_glutSetOption = unsafePerformIO $ getAPIEntry "glutSetOption" + +-- glutSetVertexAttribCoord3 --------------------------------------------------- + +glutSetVertexAttribCoord3 :: MonadIO m => GLint -> m () +glutSetVertexAttribCoord3 v1 = liftIO $ dyn_glutSetVertexAttribCoord3 ptr_glutSetVertexAttribCoord3 v1 + +foreign import CALLCONV "dynamic" dyn_glutSetVertexAttribCoord3 + :: FunPtr (GLint -> IO ()) + -> GLint -> IO () + +{-# NOINLINE ptr_glutSetVertexAttribCoord3 #-} +ptr_glutSetVertexAttribCoord3 :: FunPtr a +ptr_glutSetVertexAttribCoord3 = unsafePerformIO $ getAPIEntry "glutSetVertexAttribCoord3" + +-- glutSetVertexAttribNormal --------------------------------------------------- + +glutSetVertexAttribNormal :: MonadIO m => GLint -> m () +glutSetVertexAttribNormal v1 = liftIO $ dyn_glutSetVertexAttribNormal ptr_glutSetVertexAttribNormal v1 + +foreign import CALLCONV "dynamic" dyn_glutSetVertexAttribNormal + :: FunPtr (GLint -> IO ()) + -> GLint -> IO () + +{-# NOINLINE ptr_glutSetVertexAttribNormal #-} +ptr_glutSetVertexAttribNormal :: FunPtr a +ptr_glutSetVertexAttribNormal = unsafePerformIO $ getAPIEntry "glutSetVertexAttribNormal" + +-- glutSetVertexAttribTexCoord2 ------------------------------------------------ + +glutSetVertexAttribTexCoord2 :: MonadIO m => GLint -> m () +glutSetVertexAttribTexCoord2 v1 = liftIO $ dyn_glutSetVertexAttribTexCoord2 ptr_glutSetVertexAttribTexCoord2 v1 + +foreign import CALLCONV "dynamic" dyn_glutSetVertexAttribTexCoord2 + :: FunPtr (GLint -> IO ()) + -> GLint -> IO () + +{-# NOINLINE ptr_glutSetVertexAttribTexCoord2 #-} +ptr_glutSetVertexAttribTexCoord2 :: FunPtr a +ptr_glutSetVertexAttribTexCoord2 = unsafePerformIO $ getAPIEntry "glutSetVertexAttribTexCoord2" + +-- glutSetWindow --------------------------------------------------------------- + +glutSetWindow :: MonadIO m => CInt -> m () +glutSetWindow v1 = liftIO $ dyn_glutSetWindow ptr_glutSetWindow v1 + +foreign import CALLCONV "dynamic" dyn_glutSetWindow + :: FunPtr (CInt -> IO ()) + -> CInt -> IO () + +{-# NOINLINE ptr_glutSetWindow #-} +ptr_glutSetWindow :: FunPtr a +ptr_glutSetWindow = unsafePerformIO $ getAPIEntry "glutSetWindow" + +-- glutSetWindowData ----------------------------------------------------------- + +glutSetWindowData :: MonadIO m => Ptr a -> m () +glutSetWindowData v1 = liftIO $ dyn_glutSetWindowData ptr_glutSetWindowData v1 + +foreign import CALLCONV "dynamic" dyn_glutSetWindowData + :: FunPtr (Ptr a -> IO ()) + -> Ptr a -> IO () + +{-# NOINLINE ptr_glutSetWindowData #-} +ptr_glutSetWindowData :: FunPtr a +ptr_glutSetWindowData = unsafePerformIO $ getAPIEntry "glutSetWindowData" + +-- glutSetWindowTitle ---------------------------------------------------------- + +glutSetWindowTitle :: MonadIO m => Ptr CChar -> m () +glutSetWindowTitle v1 = liftIO $ dyn_glutSetWindowTitle ptr_glutSetWindowTitle v1 + +foreign import CALLCONV "dynamic" dyn_glutSetWindowTitle + :: FunPtr (Ptr CChar -> IO ()) + -> Ptr CChar -> IO () + +{-# NOINLINE ptr_glutSetWindowTitle #-} +ptr_glutSetWindowTitle :: FunPtr a +ptr_glutSetWindowTitle = unsafePerformIO $ getAPIEntry "glutSetWindowTitle" + +-- glutSetupVideoResizing ------------------------------------------------------ + +glutSetupVideoResizing :: MonadIO m => m () +glutSetupVideoResizing = liftIO $ dyn_glutSetupVideoResizing ptr_glutSetupVideoResizing + +foreign import CALLCONV "dynamic" dyn_glutSetupVideoResizing + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutSetupVideoResizing #-} +ptr_glutSetupVideoResizing :: FunPtr a +ptr_glutSetupVideoResizing = unsafePerformIO $ getAPIEntry "glutSetupVideoResizing" + +-- glutShowOverlay ------------------------------------------------------------- + +glutShowOverlay :: MonadIO m => m () +glutShowOverlay = liftIO $ dyn_glutShowOverlay ptr_glutShowOverlay + +foreign import CALLCONV "dynamic" dyn_glutShowOverlay + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutShowOverlay #-} +ptr_glutShowOverlay :: FunPtr a +ptr_glutShowOverlay = unsafePerformIO $ getAPIEntry "glutShowOverlay" + +-- glutShowWindow -------------------------------------------------------------- + +glutShowWindow :: MonadIO m => m () +glutShowWindow = liftIO $ dyn_glutShowWindow ptr_glutShowWindow + +foreign import CALLCONV "dynamic" dyn_glutShowWindow + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutShowWindow #-} +ptr_glutShowWindow :: FunPtr a +ptr_glutShowWindow = unsafePerformIO $ getAPIEntry "glutShowWindow" + +-- glutSolidCone --------------------------------------------------------------- + +glutSolidCone :: MonadIO m => GLdouble -> GLdouble -> GLint -> GLint -> m () +glutSolidCone v1 v2 v3 v4 = liftIO $ dyn_glutSolidCone ptr_glutSolidCone v1 v2 v3 v4 + +foreign import CALLCONV "dynamic" dyn_glutSolidCone + :: FunPtr (GLdouble -> GLdouble -> GLint -> GLint -> IO ()) + -> GLdouble -> GLdouble -> GLint -> GLint -> IO () + +{-# NOINLINE ptr_glutSolidCone #-} +ptr_glutSolidCone :: FunPtr a +ptr_glutSolidCone = unsafePerformIO $ getAPIEntry "glutSolidCone" + +-- glutSolidCube --------------------------------------------------------------- + +glutSolidCube :: MonadIO m => GLdouble -> m () +glutSolidCube v1 = liftIO $ dyn_glutSolidCube ptr_glutSolidCube v1 + +foreign import CALLCONV "dynamic" dyn_glutSolidCube + :: FunPtr (GLdouble -> IO ()) + -> GLdouble -> IO () + +{-# NOINLINE ptr_glutSolidCube #-} +ptr_glutSolidCube :: FunPtr a +ptr_glutSolidCube = unsafePerformIO $ getAPIEntry "glutSolidCube" + +-- glutSolidCylinder ----------------------------------------------------------- + +glutSolidCylinder :: MonadIO m => GLdouble -> GLdouble -> GLint -> GLint -> m () +glutSolidCylinder v1 v2 v3 v4 = liftIO $ dyn_glutSolidCylinder ptr_glutSolidCylinder v1 v2 v3 v4 + +foreign import CALLCONV "dynamic" dyn_glutSolidCylinder + :: FunPtr (GLdouble -> GLdouble -> GLint -> GLint -> IO ()) + -> GLdouble -> GLdouble -> GLint -> GLint -> IO () + +{-# NOINLINE ptr_glutSolidCylinder #-} +ptr_glutSolidCylinder :: FunPtr a +ptr_glutSolidCylinder = unsafePerformIO $ getAPIEntry "glutSolidCylinder" + +-- glutSolidDodecahedron ------------------------------------------------------- + +glutSolidDodecahedron :: MonadIO m => m () +glutSolidDodecahedron = liftIO $ dyn_glutSolidDodecahedron ptr_glutSolidDodecahedron + +foreign import CALLCONV "dynamic" dyn_glutSolidDodecahedron + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutSolidDodecahedron #-} +ptr_glutSolidDodecahedron :: FunPtr a +ptr_glutSolidDodecahedron = unsafePerformIO $ getAPIEntry "glutSolidDodecahedron" + +-- glutSolidIcosahedron -------------------------------------------------------- + +glutSolidIcosahedron :: MonadIO m => m () +glutSolidIcosahedron = liftIO $ dyn_glutSolidIcosahedron ptr_glutSolidIcosahedron + +foreign import CALLCONV "dynamic" dyn_glutSolidIcosahedron + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutSolidIcosahedron #-} +ptr_glutSolidIcosahedron :: FunPtr a +ptr_glutSolidIcosahedron = unsafePerformIO $ getAPIEntry "glutSolidIcosahedron" + +-- glutSolidOctahedron --------------------------------------------------------- + +glutSolidOctahedron :: MonadIO m => m () +glutSolidOctahedron = liftIO $ dyn_glutSolidOctahedron ptr_glutSolidOctahedron + +foreign import CALLCONV "dynamic" dyn_glutSolidOctahedron + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutSolidOctahedron #-} +ptr_glutSolidOctahedron :: FunPtr a +ptr_glutSolidOctahedron = unsafePerformIO $ getAPIEntry "glutSolidOctahedron" + +-- glutSolidRhombicDodecahedron ------------------------------------------------ + +glutSolidRhombicDodecahedron :: MonadIO m => m () +glutSolidRhombicDodecahedron = liftIO $ dyn_glutSolidRhombicDodecahedron ptr_glutSolidRhombicDodecahedron + +foreign import CALLCONV "dynamic" dyn_glutSolidRhombicDodecahedron + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutSolidRhombicDodecahedron #-} +ptr_glutSolidRhombicDodecahedron :: FunPtr a +ptr_glutSolidRhombicDodecahedron = unsafePerformIO $ getAPIEntry "glutSolidRhombicDodecahedron" + +-- glutSolidSierpinskiSponge --------------------------------------------------- + +glutSolidSierpinskiSponge :: MonadIO m => CInt -> Ptr GLdouble -> GLdouble -> m () +glutSolidSierpinskiSponge v1 v2 v3 = liftIO $ dyn_glutSolidSierpinskiSponge ptr_glutSolidSierpinskiSponge v1 v2 v3 + +foreign import CALLCONV "dynamic" dyn_glutSolidSierpinskiSponge + :: FunPtr (CInt -> Ptr GLdouble -> GLdouble -> IO ()) + -> CInt -> Ptr GLdouble -> GLdouble -> IO () + +{-# NOINLINE ptr_glutSolidSierpinskiSponge #-} +ptr_glutSolidSierpinskiSponge :: FunPtr a +ptr_glutSolidSierpinskiSponge = unsafePerformIO $ getAPIEntry "glutSolidSierpinskiSponge" + +-- glutSolidSphere ------------------------------------------------------------- + +glutSolidSphere :: MonadIO m => GLdouble -> GLint -> GLint -> m () +glutSolidSphere v1 v2 v3 = liftIO $ dyn_glutSolidSphere ptr_glutSolidSphere v1 v2 v3 + +foreign import CALLCONV "dynamic" dyn_glutSolidSphere + :: FunPtr (GLdouble -> GLint -> GLint -> IO ()) + -> GLdouble -> GLint -> GLint -> IO () + +{-# NOINLINE ptr_glutSolidSphere #-} +ptr_glutSolidSphere :: FunPtr a +ptr_glutSolidSphere = unsafePerformIO $ getAPIEntry "glutSolidSphere" + +-- glutSolidTeacup ------------------------------------------------------------- + +glutSolidTeacup :: MonadIO m => GLdouble -> m () +glutSolidTeacup v1 = liftIO $ dyn_glutSolidTeacup ptr_glutSolidTeacup v1 + +foreign import CALLCONV "dynamic" dyn_glutSolidTeacup + :: FunPtr (GLdouble -> IO ()) + -> GLdouble -> IO () + +{-# NOINLINE ptr_glutSolidTeacup #-} +ptr_glutSolidTeacup :: FunPtr a +ptr_glutSolidTeacup = unsafePerformIO $ getAPIEntry "glutSolidTeacup" + +-- glutSolidTeapot ------------------------------------------------------------- + +glutSolidTeapot :: MonadIO m => GLdouble -> m () +glutSolidTeapot v1 = liftIO $ dyn_glutSolidTeapot ptr_glutSolidTeapot v1 + +foreign import CALLCONV "dynamic" dyn_glutSolidTeapot + :: FunPtr (GLdouble -> IO ()) + -> GLdouble -> IO () + +{-# NOINLINE ptr_glutSolidTeapot #-} +ptr_glutSolidTeapot :: FunPtr a +ptr_glutSolidTeapot = unsafePerformIO $ getAPIEntry "glutSolidTeapot" + +-- glutSolidTeaspoon ----------------------------------------------------------- + +glutSolidTeaspoon :: MonadIO m => GLdouble -> m () +glutSolidTeaspoon v1 = liftIO $ dyn_glutSolidTeaspoon ptr_glutSolidTeaspoon v1 + +foreign import CALLCONV "dynamic" dyn_glutSolidTeaspoon + :: FunPtr (GLdouble -> IO ()) + -> GLdouble -> IO () + +{-# NOINLINE ptr_glutSolidTeaspoon #-} +ptr_glutSolidTeaspoon :: FunPtr a +ptr_glutSolidTeaspoon = unsafePerformIO $ getAPIEntry "glutSolidTeaspoon" + +-- glutSolidTetrahedron -------------------------------------------------------- + +glutSolidTetrahedron :: MonadIO m => m () +glutSolidTetrahedron = liftIO $ dyn_glutSolidTetrahedron ptr_glutSolidTetrahedron + +foreign import CALLCONV "dynamic" dyn_glutSolidTetrahedron + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutSolidTetrahedron #-} +ptr_glutSolidTetrahedron :: FunPtr a +ptr_glutSolidTetrahedron = unsafePerformIO $ getAPIEntry "glutSolidTetrahedron" + +-- glutSolidTorus -------------------------------------------------------------- + +glutSolidTorus :: MonadIO m => GLdouble -> GLdouble -> GLint -> GLint -> m () +glutSolidTorus v1 v2 v3 v4 = liftIO $ dyn_glutSolidTorus ptr_glutSolidTorus v1 v2 v3 v4 + +foreign import CALLCONV "dynamic" dyn_glutSolidTorus + :: FunPtr (GLdouble -> GLdouble -> GLint -> GLint -> IO ()) + -> GLdouble -> GLdouble -> GLint -> GLint -> IO () + +{-# NOINLINE ptr_glutSolidTorus #-} +ptr_glutSolidTorus :: FunPtr a +ptr_glutSolidTorus = unsafePerformIO $ getAPIEntry "glutSolidTorus" + +-- glutSpaceballButtonFunc ----------------------------------------------------- + +glutSpaceballButtonFunc :: MonadIO m => FunPtr SpaceballButtonFunc -> m () +glutSpaceballButtonFunc v1 = liftIO $ dyn_glutSpaceballButtonFunc ptr_glutSpaceballButtonFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutSpaceballButtonFunc + :: FunPtr (FunPtr SpaceballButtonFunc -> IO ()) + -> FunPtr SpaceballButtonFunc -> IO () + +{-# NOINLINE ptr_glutSpaceballButtonFunc #-} +ptr_glutSpaceballButtonFunc :: FunPtr a +ptr_glutSpaceballButtonFunc = unsafePerformIO $ getAPIEntry "glutSpaceballButtonFunc" + +-- glutSpaceballMotionFunc ----------------------------------------------------- + +glutSpaceballMotionFunc :: MonadIO m => FunPtr SpaceballMotionFunc -> m () +glutSpaceballMotionFunc v1 = liftIO $ dyn_glutSpaceballMotionFunc ptr_glutSpaceballMotionFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutSpaceballMotionFunc + :: FunPtr (FunPtr SpaceballMotionFunc -> IO ()) + -> FunPtr SpaceballMotionFunc -> IO () + +{-# NOINLINE ptr_glutSpaceballMotionFunc #-} +ptr_glutSpaceballMotionFunc :: FunPtr a +ptr_glutSpaceballMotionFunc = unsafePerformIO $ getAPIEntry "glutSpaceballMotionFunc" + +-- glutSpaceballRotateFunc ----------------------------------------------------- + +glutSpaceballRotateFunc :: MonadIO m => FunPtr SpaceballRotateFunc -> m () +glutSpaceballRotateFunc v1 = liftIO $ dyn_glutSpaceballRotateFunc ptr_glutSpaceballRotateFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutSpaceballRotateFunc + :: FunPtr (FunPtr SpaceballRotateFunc -> IO ()) + -> FunPtr SpaceballRotateFunc -> IO () + +{-# NOINLINE ptr_glutSpaceballRotateFunc #-} +ptr_glutSpaceballRotateFunc :: FunPtr a +ptr_glutSpaceballRotateFunc = unsafePerformIO $ getAPIEntry "glutSpaceballRotateFunc" + +-- glutSpecialFunc ------------------------------------------------------------- + +glutSpecialFunc :: MonadIO m => FunPtr SpecialFunc -> m () +glutSpecialFunc v1 = liftIO $ dyn_glutSpecialFunc ptr_glutSpecialFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutSpecialFunc + :: FunPtr (FunPtr SpecialFunc -> IO ()) + -> FunPtr SpecialFunc -> IO () + +{-# NOINLINE ptr_glutSpecialFunc #-} +ptr_glutSpecialFunc :: FunPtr a +ptr_glutSpecialFunc = unsafePerformIO $ getAPIEntry "glutSpecialFunc" + +-- glutSpecialUpFunc ----------------------------------------------------------- + +glutSpecialUpFunc :: MonadIO m => FunPtr SpecialUpFunc -> m () +glutSpecialUpFunc v1 = liftIO $ dyn_glutSpecialUpFunc ptr_glutSpecialUpFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutSpecialUpFunc + :: FunPtr (FunPtr SpecialUpFunc -> IO ()) + -> FunPtr SpecialUpFunc -> IO () + +{-# NOINLINE ptr_glutSpecialUpFunc #-} +ptr_glutSpecialUpFunc :: FunPtr a +ptr_glutSpecialUpFunc = unsafePerformIO $ getAPIEntry "glutSpecialUpFunc" + +-- glutStopVideoResizing ------------------------------------------------------- + +glutStopVideoResizing :: MonadIO m => m () +glutStopVideoResizing = liftIO $ dyn_glutStopVideoResizing ptr_glutStopVideoResizing + +foreign import CALLCONV "dynamic" dyn_glutStopVideoResizing + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutStopVideoResizing #-} +ptr_glutStopVideoResizing :: FunPtr a +ptr_glutStopVideoResizing = unsafePerformIO $ getAPIEntry "glutStopVideoResizing" + +-- glutStrokeCharacter --------------------------------------------------------- + +glutStrokeCharacter :: MonadIO m => Ptr a -> CInt -> m () +glutStrokeCharacter v1 v2 = liftIO $ dyn_glutStrokeCharacter ptr_glutStrokeCharacter v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutStrokeCharacter + :: FunPtr (Ptr a -> CInt -> IO ()) + -> Ptr a -> CInt -> IO () + +{-# NOINLINE ptr_glutStrokeCharacter #-} +ptr_glutStrokeCharacter :: FunPtr a +ptr_glutStrokeCharacter = unsafePerformIO $ getAPIEntry "glutStrokeCharacter" + +-- glutStrokeHeight ------------------------------------------------------------ + +glutStrokeHeight :: MonadIO m => Ptr a -> m GLfloat +glutStrokeHeight v1 = liftIO $ dyn_glutStrokeHeight ptr_glutStrokeHeight v1 + +foreign import CALLCONV "dynamic" dyn_glutStrokeHeight + :: FunPtr (Ptr a -> IO GLfloat) + -> Ptr a -> IO GLfloat + +{-# NOINLINE ptr_glutStrokeHeight #-} +ptr_glutStrokeHeight :: FunPtr a +ptr_glutStrokeHeight = unsafePerformIO $ getAPIEntry "glutStrokeHeight" + +-- glutStrokeLength ------------------------------------------------------------ + +glutStrokeLength :: MonadIO m => Ptr a -> Ptr CUChar -> m CInt +glutStrokeLength v1 v2 = liftIO $ dyn_glutStrokeLength ptr_glutStrokeLength v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutStrokeLength + :: FunPtr (Ptr a -> Ptr CUChar -> IO CInt) + -> Ptr a -> Ptr CUChar -> IO CInt + +{-# NOINLINE ptr_glutStrokeLength #-} +ptr_glutStrokeLength :: FunPtr a +ptr_glutStrokeLength = unsafePerformIO $ getAPIEntry "glutStrokeLength" + +-- glutStrokeString ------------------------------------------------------------ + +glutStrokeString :: MonadIO m => Ptr a -> Ptr CUChar -> m () +glutStrokeString v1 v2 = liftIO $ dyn_glutStrokeString ptr_glutStrokeString v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutStrokeString + :: FunPtr (Ptr a -> Ptr CUChar -> IO ()) + -> Ptr a -> Ptr CUChar -> IO () + +{-# NOINLINE ptr_glutStrokeString #-} +ptr_glutStrokeString :: FunPtr a +ptr_glutStrokeString = unsafePerformIO $ getAPIEntry "glutStrokeString" + +-- glutStrokeWidth ------------------------------------------------------------- + +glutStrokeWidth :: MonadIO m => Ptr a -> CInt -> m CInt +glutStrokeWidth v1 v2 = liftIO $ dyn_glutStrokeWidth ptr_glutStrokeWidth v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutStrokeWidth + :: FunPtr (Ptr a -> CInt -> IO CInt) + -> Ptr a -> CInt -> IO CInt + +{-# NOINLINE ptr_glutStrokeWidth #-} +ptr_glutStrokeWidth :: FunPtr a +ptr_glutStrokeWidth = unsafePerformIO $ getAPIEntry "glutStrokeWidth" + +-- glutSwapBuffers ------------------------------------------------------------- + +glutSwapBuffers :: MonadIO m => m () +glutSwapBuffers = liftIO $ dyn_glutSwapBuffers ptr_glutSwapBuffers + +foreign import CALLCONV "dynamic" dyn_glutSwapBuffers + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutSwapBuffers #-} +ptr_glutSwapBuffers :: FunPtr a +ptr_glutSwapBuffers = unsafePerformIO $ getAPIEntry "glutSwapBuffers" + +-- glutTabletButtonFunc -------------------------------------------------------- + +glutTabletButtonFunc :: MonadIO m => FunPtr TabletButtonFunc -> m () +glutTabletButtonFunc v1 = liftIO $ dyn_glutTabletButtonFunc ptr_glutTabletButtonFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutTabletButtonFunc + :: FunPtr (FunPtr TabletButtonFunc -> IO ()) + -> FunPtr TabletButtonFunc -> IO () + +{-# NOINLINE ptr_glutTabletButtonFunc #-} +ptr_glutTabletButtonFunc :: FunPtr a +ptr_glutTabletButtonFunc = unsafePerformIO $ getAPIEntry "glutTabletButtonFunc" + +-- glutTabletMotionFunc -------------------------------------------------------- + +glutTabletMotionFunc :: MonadIO m => FunPtr TabletMotionFunc -> m () +glutTabletMotionFunc v1 = liftIO $ dyn_glutTabletMotionFunc ptr_glutTabletMotionFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutTabletMotionFunc + :: FunPtr (FunPtr TabletMotionFunc -> IO ()) + -> FunPtr TabletMotionFunc -> IO () + +{-# NOINLINE ptr_glutTabletMotionFunc #-} +ptr_glutTabletMotionFunc :: FunPtr a +ptr_glutTabletMotionFunc = unsafePerformIO $ getAPIEntry "glutTabletMotionFunc" + +-- glutTimerFunc --------------------------------------------------------------- + +glutTimerFunc :: MonadIO m => CUInt -> FunPtr TimerFunc -> CInt -> m () +glutTimerFunc v1 v2 v3 = liftIO $ dyn_glutTimerFunc ptr_glutTimerFunc v1 v2 v3 + +foreign import CALLCONV "dynamic" dyn_glutTimerFunc + :: FunPtr (CUInt -> FunPtr TimerFunc -> CInt -> IO ()) + -> CUInt -> FunPtr TimerFunc -> CInt -> IO () + +{-# NOINLINE ptr_glutTimerFunc #-} +ptr_glutTimerFunc :: FunPtr a +ptr_glutTimerFunc = unsafePerformIO $ getAPIEntry "glutTimerFunc" + +-- glutUseLayer ---------------------------------------------------------------- + +glutUseLayer :: MonadIO m => GLenum -> m () +glutUseLayer v1 = liftIO $ dyn_glutUseLayer ptr_glutUseLayer v1 + +foreign import CALLCONV "dynamic" dyn_glutUseLayer + :: FunPtr (GLenum -> IO ()) + -> GLenum -> IO () + +{-# NOINLINE ptr_glutUseLayer #-} +ptr_glutUseLayer :: FunPtr a +ptr_glutUseLayer = unsafePerformIO $ getAPIEntry "glutUseLayer" + +-- glutVideoPan ---------------------------------------------------------------- + +glutVideoPan :: MonadIO m => CInt -> CInt -> CInt -> CInt -> m () +glutVideoPan v1 v2 v3 v4 = liftIO $ dyn_glutVideoPan ptr_glutVideoPan v1 v2 v3 v4 + +foreign import CALLCONV "dynamic" dyn_glutVideoPan + :: FunPtr (CInt -> CInt -> CInt -> CInt -> IO ()) + -> CInt -> CInt -> CInt -> CInt -> IO () + +{-# NOINLINE ptr_glutVideoPan #-} +ptr_glutVideoPan :: FunPtr a +ptr_glutVideoPan = unsafePerformIO $ getAPIEntry "glutVideoPan" + +-- glutVideoResize ------------------------------------------------------------- + +glutVideoResize :: MonadIO m => CInt -> CInt -> CInt -> CInt -> m () +glutVideoResize v1 v2 v3 v4 = liftIO $ dyn_glutVideoResize ptr_glutVideoResize v1 v2 v3 v4 + +foreign import CALLCONV "dynamic" dyn_glutVideoResize + :: FunPtr (CInt -> CInt -> CInt -> CInt -> IO ()) + -> CInt -> CInt -> CInt -> CInt -> IO () + +{-# NOINLINE ptr_glutVideoResize #-} +ptr_glutVideoResize :: FunPtr a +ptr_glutVideoResize = unsafePerformIO $ getAPIEntry "glutVideoResize" + +-- glutVideoResizeGet ---------------------------------------------------------- + +glutVideoResizeGet :: MonadIO m => GLenum -> m CInt +glutVideoResizeGet v1 = liftIO $ dyn_glutVideoResizeGet ptr_glutVideoResizeGet v1 + +foreign import CALLCONV "dynamic" dyn_glutVideoResizeGet + :: FunPtr (GLenum -> IO CInt) + -> GLenum -> IO CInt + +{-# NOINLINE ptr_glutVideoResizeGet #-} +ptr_glutVideoResizeGet :: FunPtr a +ptr_glutVideoResizeGet = unsafePerformIO $ getAPIEntry "glutVideoResizeGet" + +-- glutVisibilityFunc ---------------------------------------------------------- + +glutVisibilityFunc :: MonadIO m => FunPtr VisibilityFunc -> m () +glutVisibilityFunc v1 = liftIO $ dyn_glutVisibilityFunc ptr_glutVisibilityFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutVisibilityFunc + :: FunPtr (FunPtr VisibilityFunc -> IO ()) + -> FunPtr VisibilityFunc -> IO () + +{-# NOINLINE ptr_glutVisibilityFunc #-} +ptr_glutVisibilityFunc :: FunPtr a +ptr_glutVisibilityFunc = unsafePerformIO $ getAPIEntry "glutVisibilityFunc" + +-- glutWMCloseFunc ------------------------------------------------------------- + +glutWMCloseFunc :: MonadIO m => FunPtr WMCloseFunc -> m () +glutWMCloseFunc v1 = liftIO $ dyn_glutWMCloseFunc ptr_glutWMCloseFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutWMCloseFunc + :: FunPtr (FunPtr WMCloseFunc -> IO ()) + -> FunPtr WMCloseFunc -> IO () + +{-# NOINLINE ptr_glutWMCloseFunc #-} +ptr_glutWMCloseFunc :: FunPtr a +ptr_glutWMCloseFunc = unsafePerformIO $ getAPIEntry "glutWMCloseFunc" + +-- glutWarpPointer ------------------------------------------------------------- + +glutWarpPointer :: MonadIO m => CInt -> CInt -> m () +glutWarpPointer v1 v2 = liftIO $ dyn_glutWarpPointer ptr_glutWarpPointer v1 v2 + +foreign import CALLCONV "dynamic" dyn_glutWarpPointer + :: FunPtr (CInt -> CInt -> IO ()) + -> CInt -> CInt -> IO () + +{-# NOINLINE ptr_glutWarpPointer #-} +ptr_glutWarpPointer :: FunPtr a +ptr_glutWarpPointer = unsafePerformIO $ getAPIEntry "glutWarpPointer" + +-- glutWindowStatusFunc -------------------------------------------------------- + +glutWindowStatusFunc :: MonadIO m => FunPtr WindowStatusFunc -> m () +glutWindowStatusFunc v1 = liftIO $ dyn_glutWindowStatusFunc ptr_glutWindowStatusFunc v1 + +foreign import CALLCONV "dynamic" dyn_glutWindowStatusFunc + :: FunPtr (FunPtr WindowStatusFunc -> IO ()) + -> FunPtr WindowStatusFunc -> IO () + +{-# NOINLINE ptr_glutWindowStatusFunc #-} +ptr_glutWindowStatusFunc :: FunPtr a +ptr_glutWindowStatusFunc = unsafePerformIO $ getAPIEntry "glutWindowStatusFunc" + +-- glutWireCone ---------------------------------------------------------------- + +glutWireCone :: MonadIO m => GLdouble -> GLdouble -> GLint -> GLint -> m () +glutWireCone v1 v2 v3 v4 = liftIO $ dyn_glutWireCone ptr_glutWireCone v1 v2 v3 v4 + +foreign import CALLCONV "dynamic" dyn_glutWireCone + :: FunPtr (GLdouble -> GLdouble -> GLint -> GLint -> IO ()) + -> GLdouble -> GLdouble -> GLint -> GLint -> IO () + +{-# NOINLINE ptr_glutWireCone #-} +ptr_glutWireCone :: FunPtr a +ptr_glutWireCone = unsafePerformIO $ getAPIEntry "glutWireCone" + +-- glutWireCube ---------------------------------------------------------------- + +glutWireCube :: MonadIO m => GLdouble -> m () +glutWireCube v1 = liftIO $ dyn_glutWireCube ptr_glutWireCube v1 + +foreign import CALLCONV "dynamic" dyn_glutWireCube + :: FunPtr (GLdouble -> IO ()) + -> GLdouble -> IO () + +{-# NOINLINE ptr_glutWireCube #-} +ptr_glutWireCube :: FunPtr a +ptr_glutWireCube = unsafePerformIO $ getAPIEntry "glutWireCube" + +-- glutWireCylinder ------------------------------------------------------------ + +glutWireCylinder :: MonadIO m => GLdouble -> GLdouble -> GLint -> GLint -> m () +glutWireCylinder v1 v2 v3 v4 = liftIO $ dyn_glutWireCylinder ptr_glutWireCylinder v1 v2 v3 v4 + +foreign import CALLCONV "dynamic" dyn_glutWireCylinder + :: FunPtr (GLdouble -> GLdouble -> GLint -> GLint -> IO ()) + -> GLdouble -> GLdouble -> GLint -> GLint -> IO () + +{-# NOINLINE ptr_glutWireCylinder #-} +ptr_glutWireCylinder :: FunPtr a +ptr_glutWireCylinder = unsafePerformIO $ getAPIEntry "glutWireCylinder" + +-- glutWireDodecahedron -------------------------------------------------------- + +glutWireDodecahedron :: MonadIO m => m () +glutWireDodecahedron = liftIO $ dyn_glutWireDodecahedron ptr_glutWireDodecahedron + +foreign import CALLCONV "dynamic" dyn_glutWireDodecahedron + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutWireDodecahedron #-} +ptr_glutWireDodecahedron :: FunPtr a +ptr_glutWireDodecahedron = unsafePerformIO $ getAPIEntry "glutWireDodecahedron" + +-- glutWireIcosahedron --------------------------------------------------------- + +glutWireIcosahedron :: MonadIO m => m () +glutWireIcosahedron = liftIO $ dyn_glutWireIcosahedron ptr_glutWireIcosahedron + +foreign import CALLCONV "dynamic" dyn_glutWireIcosahedron + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutWireIcosahedron #-} +ptr_glutWireIcosahedron :: FunPtr a +ptr_glutWireIcosahedron = unsafePerformIO $ getAPIEntry "glutWireIcosahedron" + +-- glutWireOctahedron ---------------------------------------------------------- + +glutWireOctahedron :: MonadIO m => m () +glutWireOctahedron = liftIO $ dyn_glutWireOctahedron ptr_glutWireOctahedron + +foreign import CALLCONV "dynamic" dyn_glutWireOctahedron + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutWireOctahedron #-} +ptr_glutWireOctahedron :: FunPtr a +ptr_glutWireOctahedron = unsafePerformIO $ getAPIEntry "glutWireOctahedron" + +-- glutWireRhombicDodecahedron ------------------------------------------------- + +glutWireRhombicDodecahedron :: MonadIO m => m () +glutWireRhombicDodecahedron = liftIO $ dyn_glutWireRhombicDodecahedron ptr_glutWireRhombicDodecahedron + +foreign import CALLCONV "dynamic" dyn_glutWireRhombicDodecahedron + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutWireRhombicDodecahedron #-} +ptr_glutWireRhombicDodecahedron :: FunPtr a +ptr_glutWireRhombicDodecahedron = unsafePerformIO $ getAPIEntry "glutWireRhombicDodecahedron" + +-- glutWireSierpinskiSponge ---------------------------------------------------- + +glutWireSierpinskiSponge :: MonadIO m => CInt -> Ptr GLdouble -> GLdouble -> m () +glutWireSierpinskiSponge v1 v2 v3 = liftIO $ dyn_glutWireSierpinskiSponge ptr_glutWireSierpinskiSponge v1 v2 v3 + +foreign import CALLCONV "dynamic" dyn_glutWireSierpinskiSponge + :: FunPtr (CInt -> Ptr GLdouble -> GLdouble -> IO ()) + -> CInt -> Ptr GLdouble -> GLdouble -> IO () + +{-# NOINLINE ptr_glutWireSierpinskiSponge #-} +ptr_glutWireSierpinskiSponge :: FunPtr a +ptr_glutWireSierpinskiSponge = unsafePerformIO $ getAPIEntry "glutWireSierpinskiSponge" + +-- glutWireSphere -------------------------------------------------------------- + +glutWireSphere :: MonadIO m => GLdouble -> GLint -> GLint -> m () +glutWireSphere v1 v2 v3 = liftIO $ dyn_glutWireSphere ptr_glutWireSphere v1 v2 v3 + +foreign import CALLCONV "dynamic" dyn_glutWireSphere + :: FunPtr (GLdouble -> GLint -> GLint -> IO ()) + -> GLdouble -> GLint -> GLint -> IO () + +{-# NOINLINE ptr_glutWireSphere #-} +ptr_glutWireSphere :: FunPtr a +ptr_glutWireSphere = unsafePerformIO $ getAPIEntry "glutWireSphere" + +-- glutWireTeacup -------------------------------------------------------------- + +glutWireTeacup :: MonadIO m => GLdouble -> m () +glutWireTeacup v1 = liftIO $ dyn_glutWireTeacup ptr_glutWireTeacup v1 + +foreign import CALLCONV "dynamic" dyn_glutWireTeacup + :: FunPtr (GLdouble -> IO ()) + -> GLdouble -> IO () + +{-# NOINLINE ptr_glutWireTeacup #-} +ptr_glutWireTeacup :: FunPtr a +ptr_glutWireTeacup = unsafePerformIO $ getAPIEntry "glutWireTeacup" + +-- glutWireTeapot -------------------------------------------------------------- + +glutWireTeapot :: MonadIO m => GLdouble -> m () +glutWireTeapot v1 = liftIO $ dyn_glutWireTeapot ptr_glutWireTeapot v1 + +foreign import CALLCONV "dynamic" dyn_glutWireTeapot + :: FunPtr (GLdouble -> IO ()) + -> GLdouble -> IO () + +{-# NOINLINE ptr_glutWireTeapot #-} +ptr_glutWireTeapot :: FunPtr a +ptr_glutWireTeapot = unsafePerformIO $ getAPIEntry "glutWireTeapot" + +-- glutWireTeaspoon ------------------------------------------------------------ + +glutWireTeaspoon :: MonadIO m => GLdouble -> m () +glutWireTeaspoon v1 = liftIO $ dyn_glutWireTeaspoon ptr_glutWireTeaspoon v1 + +foreign import CALLCONV "dynamic" dyn_glutWireTeaspoon + :: FunPtr (GLdouble -> IO ()) + -> GLdouble -> IO () + +{-# NOINLINE ptr_glutWireTeaspoon #-} +ptr_glutWireTeaspoon :: FunPtr a +ptr_glutWireTeaspoon = unsafePerformIO $ getAPIEntry "glutWireTeaspoon" + +-- glutWireTetrahedron --------------------------------------------------------- + +glutWireTetrahedron :: MonadIO m => m () +glutWireTetrahedron = liftIO $ dyn_glutWireTetrahedron ptr_glutWireTetrahedron + +foreign import CALLCONV "dynamic" dyn_glutWireTetrahedron + :: FunPtr (IO ()) + -> IO () + +{-# NOINLINE ptr_glutWireTetrahedron #-} +ptr_glutWireTetrahedron :: FunPtr a +ptr_glutWireTetrahedron = unsafePerformIO $ getAPIEntry "glutWireTetrahedron" + +-- glutWireTorus --------------------------------------------------------------- + +glutWireTorus :: MonadIO m => GLdouble -> GLdouble -> GLint -> GLint -> m () +glutWireTorus v1 v2 v3 v4 = liftIO $ dyn_glutWireTorus ptr_glutWireTorus v1 v2 v3 v4 + +foreign import CALLCONV "dynamic" dyn_glutWireTorus + :: FunPtr (GLdouble -> GLdouble -> GLint -> GLint -> IO ()) + -> GLdouble -> GLdouble -> GLint -> GLint -> IO () + +{-# NOINLINE ptr_glutWireTorus #-} +ptr_glutWireTorus :: FunPtr a +ptr_glutWireTorus = unsafePerformIO $ getAPIEntry "glutWireTorus" + diff --git a/src/Graphics/UI/GLUT/Raw/Tokens.hs b/src/Graphics/UI/GLUT/Raw/Tokens.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Raw/Tokens.hs @@ -0,0 +1,643 @@ +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Raw.Tokens +-- Copyright : (c) Sven Panne 2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- All tokens from GLUT and freeglut. +-- +----------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Raw.Tokens where + +import Foreign.C.Types ( CInt, CUInt ) +import Graphics.Rendering.OpenGL ( GLenum ) + +glut_ACCUM :: CUInt +glut_ACCUM = 0x0004 + +glut_ACTION_CONTINUE_EXECUTION :: CInt +glut_ACTION_CONTINUE_EXECUTION = 2 + +glut_ACTION_EXIT :: CInt +glut_ACTION_EXIT = 0 + +glut_ACTION_GLUTMAINLOOP_RETURNS :: CInt +glut_ACTION_GLUTMAINLOOP_RETURNS = 1 + +glut_ACTION_ON_WINDOW_CLOSE :: GLenum +glut_ACTION_ON_WINDOW_CLOSE = 0x01F9 + +glut_ACTIVE_ALT :: CInt +glut_ACTIVE_ALT = 0x0004 + +glut_ACTIVE_CTRL :: CInt +glut_ACTIVE_CTRL = 0x0002 + +glut_ACTIVE_SHIFT :: CInt +glut_ACTIVE_SHIFT = 0x0001 + +glut_ALLOW_DIRECT_CONTEXT :: CInt +glut_ALLOW_DIRECT_CONTEXT = 1 + +glut_ALPHA :: CUInt +glut_ALPHA = 0x0008 + +glut_APPSTATUS_PAUSE :: CInt +glut_APPSTATUS_PAUSE = 0x0001 + +glut_APPSTATUS_RESUME :: CInt +glut_APPSTATUS_RESUME = 0x0002 + +glut_AUX :: GLenum +glut_AUX = 0x1000 + +glut_AUX1 :: CUInt +glut_AUX1 = 0x1000 + +glut_AUX2 :: CUInt +glut_AUX2 = 0x2000 + +glut_AUX3 :: CUInt +glut_AUX3 = 0x4000 + +glut_AUX4 :: CUInt +glut_AUX4 = 0x8000 + +glut_BLUE :: CInt +glut_BLUE = 0x0002 + +glut_BORDERLESS :: CUInt +glut_BORDERLESS = 0x0800 + +glut_CAPTIONLESS :: CUInt +glut_CAPTIONLESS = 0x0400 + +glut_CORE_PROFILE :: CInt +glut_CORE_PROFILE = 0x0001 + +glut_COMPATIBILITY_PROFILE :: CInt +glut_COMPATIBILITY_PROFILE = 0x0002 + +glut_CREATE_NEW_CONTEXT :: CInt +glut_CREATE_NEW_CONTEXT = 0 + +glut_CURSOR_BOTTOM_LEFT_CORNER :: CInt +glut_CURSOR_BOTTOM_LEFT_CORNER = 0x0013 + +glut_CURSOR_BOTTOM_RIGHT_CORNER :: CInt +glut_CURSOR_BOTTOM_RIGHT_CORNER = 0x0012 + +glut_CURSOR_BOTTOM_SIDE :: CInt +glut_CURSOR_BOTTOM_SIDE = 0x000D + +glut_CURSOR_CROSSHAIR :: CInt +glut_CURSOR_CROSSHAIR = 0x0009 + +glut_CURSOR_CYCLE :: CInt +glut_CURSOR_CYCLE = 0x0005 + +glut_CURSOR_DESTROY :: CInt +glut_CURSOR_DESTROY = 0x0003 + +glut_CURSOR_FULL_CROSSHAIR :: CInt +glut_CURSOR_FULL_CROSSHAIR = 0x0066 + +glut_CURSOR_HELP :: CInt +glut_CURSOR_HELP = 0x0004 + +glut_CURSOR_INFO :: CInt +glut_CURSOR_INFO = 0x0002 + +glut_CURSOR_INHERIT :: CInt +glut_CURSOR_INHERIT = 0x0064 + +glut_CURSOR_LEFT_ARROW :: CInt +glut_CURSOR_LEFT_ARROW = 0x0001 + +glut_CURSOR_LEFT_RIGHT :: CInt +glut_CURSOR_LEFT_RIGHT = 0x000B + +glut_CURSOR_LEFT_SIDE :: CInt +glut_CURSOR_LEFT_SIDE = 0x000E + +glut_CURSOR_NONE :: CInt +glut_CURSOR_NONE = 0x0065 + +glut_CURSOR_RIGHT_ARROW :: CInt +glut_CURSOR_RIGHT_ARROW = 0x0000 + +glut_CURSOR_RIGHT_SIDE :: CInt +glut_CURSOR_RIGHT_SIDE = 0x000F + +glut_CURSOR_SPRAY :: CInt +glut_CURSOR_SPRAY = 0x0006 + +glut_CURSOR_TEXT :: CInt +glut_CURSOR_TEXT = 0x0008 + +glut_CURSOR_TOP_LEFT_CORNER :: CInt +glut_CURSOR_TOP_LEFT_CORNER = 0x0010 + +glut_CURSOR_TOP_RIGHT_CORNER :: CInt +glut_CURSOR_TOP_RIGHT_CORNER = 0x0011 + +glut_CURSOR_TOP_SIDE :: CInt +glut_CURSOR_TOP_SIDE = 0x000C + +glut_CURSOR_UP_DOWN :: CInt +glut_CURSOR_UP_DOWN = 0x000A + +glut_CURSOR_WAIT :: CInt +glut_CURSOR_WAIT = 0x0007 + +glut_DEBUG :: CInt +glut_DEBUG = 0x0001 + +glut_DEPTH :: CUInt +glut_DEPTH = 0x0010 + +glut_DEVICE_IGNORE_KEY_REPEAT :: GLenum +glut_DEVICE_IGNORE_KEY_REPEAT = 0x0262 + +glut_DEVICE_KEY_REPEAT :: GLenum +glut_DEVICE_KEY_REPEAT = 0x0263 + +glut_DIRECT_RENDERING :: GLenum +glut_DIRECT_RENDERING = 0x01FE + +glut_DISPLAY_MODE_POSSIBLE :: GLenum +glut_DISPLAY_MODE_POSSIBLE = 0x0190 + +glut_DOUBLE :: CUInt +glut_DOUBLE = 0x0002 + +glut_DOWN :: CInt +glut_DOWN = 0x0000 + +glut_ELAPSED_TIME :: GLenum +glut_ELAPSED_TIME = 0x02BC + +glut_ENTERED :: CInt +glut_ENTERED = 0x0001 + +glut_FORCE_DIRECT_CONTEXT :: CInt +glut_FORCE_DIRECT_CONTEXT = 3 + +glut_FORCE_INDIRECT_CONTEXT :: CInt +glut_FORCE_INDIRECT_CONTEXT = 0 + +glut_FORWARD_COMPATIBLE :: CInt +glut_FORWARD_COMPATIBLE = 0x0002 + +glut_FULLY_COVERED :: CInt +glut_FULLY_COVERED = 0x0003 + +glut_FULLY_RETAINED :: CInt +glut_FULLY_RETAINED = 0x0001 + +glut_FULL_SCREEN :: GLenum +glut_FULL_SCREEN = 0x01FF + +glut_GAME_MODE_ACTIVE :: GLenum +glut_GAME_MODE_ACTIVE = 0x0000 + +glut_GAME_MODE_DISPLAY_CHANGED :: GLenum +glut_GAME_MODE_DISPLAY_CHANGED = 0x0006 + +glut_GAME_MODE_HEIGHT :: GLenum +glut_GAME_MODE_HEIGHT = 0x0003 + +glut_GAME_MODE_PIXEL_DEPTH :: GLenum +glut_GAME_MODE_PIXEL_DEPTH = 0x0004 + +glut_GAME_MODE_POSSIBLE :: GLenum +glut_GAME_MODE_POSSIBLE = 0x0001 + +glut_GAME_MODE_REFRESH_RATE :: GLenum +glut_GAME_MODE_REFRESH_RATE = 0x0005 + +glut_GAME_MODE_WIDTH :: GLenum +glut_GAME_MODE_WIDTH = 0x0002 + +glut_GEOMETRY_VISUALIZE_NORMALS :: GLenum +glut_GEOMETRY_VISUALIZE_NORMALS = 0x0205 + +glut_GREEN :: CInt +glut_GREEN = 0x0001 + +glut_HAS_DIAL_AND_BUTTON_BOX :: GLenum +glut_HAS_DIAL_AND_BUTTON_BOX = 0x025B + +glut_HAS_JOYSTICK :: GLenum +glut_HAS_JOYSTICK = 0x0264 + +glut_HAS_KEYBOARD :: GLenum +glut_HAS_KEYBOARD = 0x0258 + +glut_HAS_MOUSE :: GLenum +glut_HAS_MOUSE = 0x0259 + +glut_HAS_OVERLAY :: GLenum +glut_HAS_OVERLAY = 0x0322 + +glut_HAS_SPACEBALL :: GLenum +glut_HAS_SPACEBALL = 0x025A + +glut_HAS_TABLET :: GLenum +glut_HAS_TABLET = 0x025C + +glut_HIDDEN :: CInt +glut_HIDDEN = 0x0000 + +glut_INDEX :: CUInt +glut_INDEX = 0x0001 + +glut_INIT_DISPLAY_MODE :: GLenum +glut_INIT_DISPLAY_MODE = 0x01F8 + +glut_INIT_FLAGS :: GLenum +glut_INIT_FLAGS = 0x0202 + +glut_INIT_MAJOR_VERSION :: GLenum +glut_INIT_MAJOR_VERSION = 0x0200 + +glut_INIT_MINOR_VERSION :: GLenum +glut_INIT_MINOR_VERSION = 0x0201 + +glut_INIT_PROFILE :: GLenum +glut_INIT_PROFILE = 0x0203 + +glut_INIT_STATE :: GLenum +glut_INIT_STATE = 0x007C + +glut_INIT_WINDOW_HEIGHT :: GLenum +glut_INIT_WINDOW_HEIGHT = 0x01F7 + +glut_INIT_WINDOW_WIDTH :: GLenum +glut_INIT_WINDOW_WIDTH = 0x01F6 + +glut_INIT_WINDOW_X :: GLenum +glut_INIT_WINDOW_X = 0x01F4 + +glut_INIT_WINDOW_Y :: GLenum +glut_INIT_WINDOW_Y = 0x01F5 + +glut_JOYSTICK_AXES :: GLenum +glut_JOYSTICK_AXES = 0x0267 + +glut_JOYSTICK_BUTTONS :: GLenum +glut_JOYSTICK_BUTTONS = 0x0266 + +glut_JOYSTICK_BUTTON_A :: CUInt +glut_JOYSTICK_BUTTON_A = 0x0001 + +glut_JOYSTICK_BUTTON_B :: CUInt +glut_JOYSTICK_BUTTON_B = 0x0002 + +glut_JOYSTICK_BUTTON_C :: CUInt +glut_JOYSTICK_BUTTON_C = 0x0004 + +glut_JOYSTICK_BUTTON_D :: CUInt +glut_JOYSTICK_BUTTON_D = 0x0008 + +glut_JOYSTICK_POLL_RATE :: GLenum +glut_JOYSTICK_POLL_RATE = 0x0268 + +glut_KEY_ALT_L :: CInt +glut_KEY_ALT_L = 0x0074 + +glut_KEY_ALT_R :: CInt +glut_KEY_ALT_R = 0x0075 + +glut_KEY_BEGIN :: CInt +glut_KEY_BEGIN = 0x006E + +glut_KEY_CTRL_L :: CInt +glut_KEY_CTRL_L = 0x0072 + +glut_KEY_CTRL_R :: CInt +glut_KEY_CTRL_R = 0x0073 + +glut_KEY_DELETE :: CInt +glut_KEY_DELETE = 0x006F + +glut_KEY_DOWN :: CInt +glut_KEY_DOWN = 0x0067 + +glut_KEY_END :: CInt +glut_KEY_END = 0x006B + +glut_KEY_F1 :: CInt +glut_KEY_F1 = 0x0001 + +glut_KEY_F10 :: CInt +glut_KEY_F10 = 0x000A + +glut_KEY_F11 :: CInt +glut_KEY_F11 = 0x000B + +glut_KEY_F12 :: CInt +glut_KEY_F12 = 0x000C + +glut_KEY_F2 :: CInt +glut_KEY_F2 = 0x0002 + +glut_KEY_F3 :: CInt +glut_KEY_F3 = 0x0003 + +glut_KEY_F4 :: CInt +glut_KEY_F4 = 0x0004 + +glut_KEY_F5 :: CInt +glut_KEY_F5 = 0x0005 + +glut_KEY_F6 :: CInt +glut_KEY_F6 = 0x0006 + +glut_KEY_F7 :: CInt +glut_KEY_F7 = 0x0007 + +glut_KEY_F8 :: CInt +glut_KEY_F8 = 0x0008 + +glut_KEY_F9 :: CInt +glut_KEY_F9 = 0x0009 + +glut_KEY_HOME :: CInt +glut_KEY_HOME = 0x006A + +glut_KEY_INSERT :: CInt +glut_KEY_INSERT = 0x006C + +glut_KEY_LEFT :: CInt +glut_KEY_LEFT = 0x0064 + +glut_KEY_NUM_LOCK :: CInt +glut_KEY_NUM_LOCK = 0x006D + +glut_KEY_PAGE_DOWN :: CInt +glut_KEY_PAGE_DOWN = 0x0069 + +glut_KEY_PAGE_UP :: CInt +glut_KEY_PAGE_UP = 0x0068 + +glut_KEY_REPEAT_DEFAULT :: CInt +glut_KEY_REPEAT_DEFAULT = 0x0002 + +glut_KEY_REPEAT_OFF :: CInt +glut_KEY_REPEAT_OFF = 0x0000 + +glut_KEY_REPEAT_ON :: CInt +glut_KEY_REPEAT_ON = 0x0001 + +glut_KEY_RIGHT :: CInt +glut_KEY_RIGHT = 0x0066 + +glut_KEY_SHIFT_L :: CInt +glut_KEY_SHIFT_L = 0x0070 + +glut_KEY_SHIFT_R :: CInt +glut_KEY_SHIFT_R = 0x0071 + +glut_KEY_UP :: CInt +glut_KEY_UP = 0x0065 + +glut_LAYER_IN_USE :: GLenum +glut_LAYER_IN_USE = 0x0321 + +glut_LEFT :: CInt +glut_LEFT = 0x0000 + +glut_LEFT_BUTTON :: CInt +glut_LEFT_BUTTON = 0x0000 + +glut_LUMINANCE :: CUInt +glut_LUMINANCE = 0x0200 + +glut_MENU_IN_USE :: CInt +glut_MENU_IN_USE = 0x0001 + +glut_MENU_NOT_IN_USE :: CInt +glut_MENU_NOT_IN_USE = 0x0000 + +glut_MENU_NUM_ITEMS :: GLenum +glut_MENU_NUM_ITEMS = 0x012C + +glut_MIDDLE_BUTTON :: CInt +glut_MIDDLE_BUTTON = 0x0001 + +glut_MULTISAMPLE :: CUInt +glut_MULTISAMPLE = 0x0080 + +glut_NORMAL :: GLenum +glut_NORMAL = 0x0000 + +glut_NORMAL_DAMAGED :: GLenum +glut_NORMAL_DAMAGED = 0x0324 + +glut_NOT_VISIBLE :: CInt +glut_NOT_VISIBLE = 0x0000 + +glut_NUM_BUTTON_BOX_BUTTONS :: GLenum +glut_NUM_BUTTON_BOX_BUTTONS = 0x025F + +glut_NUM_DIALS :: GLenum +glut_NUM_DIALS = 0x0260 + +glut_NUM_MOUSE_BUTTONS :: GLenum +glut_NUM_MOUSE_BUTTONS = 0x025D + +glut_NUM_SPACEBALL_BUTTONS :: GLenum +glut_NUM_SPACEBALL_BUTTONS = 0x025E + +glut_NUM_TABLET_BUTTONS :: GLenum +glut_NUM_TABLET_BUTTONS = 0x0261 + +glut_OVERLAY :: GLenum +glut_OVERLAY = 0x0001 + +glut_OVERLAY_DAMAGED :: GLenum +glut_OVERLAY_DAMAGED = 0x0325 + +glut_OVERLAY_POSSIBLE :: GLenum +glut_OVERLAY_POSSIBLE = 0x0320 + +glut_OWNS_JOYSTICK :: GLenum +glut_OWNS_JOYSTICK = 0x0265 + +glut_PARTIALLY_RETAINED :: CInt +glut_PARTIALLY_RETAINED = 0x0002 + +glut_RED :: CInt +glut_RED = 0x0000 + +glut_RENDERING_CONTEXT :: GLenum +glut_RENDERING_CONTEXT = 0x01FD + +glut_RGB :: CUInt +glut_RGB = 0x0000 + +glut_RGBA :: CUInt +glut_RGBA = 0x0000 + +glut_RIGHT_BUTTON :: CInt +glut_RIGHT_BUTTON = 0x0002 + +glut_SCREEN_HEIGHT :: GLenum +glut_SCREEN_HEIGHT = 0x00C9 + +glut_SCREEN_HEIGHT_MM :: GLenum +glut_SCREEN_HEIGHT_MM = 0x00CB + +glut_SCREEN_WIDTH :: GLenum +glut_SCREEN_WIDTH = 0x00C8 + +glut_SCREEN_WIDTH_MM :: GLenum +glut_SCREEN_WIDTH_MM = 0x00CA + +glut_SINGLE :: CUInt +glut_SINGLE = 0x0000 + +glut_SKIP_STALE_MOTION_EVENTS :: GLenum +glut_SKIP_STALE_MOTION_EVENTS = 0x0204 + +glut_SRGB :: CUInt +glut_SRGB = 0x1000 + +glut_STENCIL :: CUInt +glut_STENCIL = 0x0020 + +glut_STEREO :: CUInt +glut_STEREO = 0x0100 + +glut_TRANSPARENT_INDEX :: GLenum +glut_TRANSPARENT_INDEX = 0x0323 + +glut_TRY_DIRECT_CONTEXT :: CInt +glut_TRY_DIRECT_CONTEXT = 2 + +glut_UP :: CInt +glut_UP = 0x0001 + +glut_USE_CURRENT_CONTEXT :: CInt +glut_USE_CURRENT_CONTEXT = 1 + +glut_VERSION :: GLenum +glut_VERSION = 0x01FC + +glut_VIDEO_RESIZE_HEIGHT :: GLenum +glut_VIDEO_RESIZE_HEIGHT = 0x038D + +glut_VIDEO_RESIZE_HEIGHT_DELTA :: GLenum +glut_VIDEO_RESIZE_HEIGHT_DELTA = 0x0389 + +glut_VIDEO_RESIZE_IN_USE :: GLenum +glut_VIDEO_RESIZE_IN_USE = 0x0385 + +glut_VIDEO_RESIZE_POSSIBLE :: GLenum +glut_VIDEO_RESIZE_POSSIBLE = 0x0384 + +glut_VIDEO_RESIZE_WIDTH :: GLenum +glut_VIDEO_RESIZE_WIDTH = 0x038C + +glut_VIDEO_RESIZE_WIDTH_DELTA :: GLenum +glut_VIDEO_RESIZE_WIDTH_DELTA = 0x0388 + +glut_VIDEO_RESIZE_X :: GLenum +glut_VIDEO_RESIZE_X = 0x038A + +glut_VIDEO_RESIZE_X_DELTA :: GLenum +glut_VIDEO_RESIZE_X_DELTA = 0x0386 + +glut_VIDEO_RESIZE_Y :: GLenum +glut_VIDEO_RESIZE_Y = 0x038B + +glut_VIDEO_RESIZE_Y_DELTA :: GLenum +glut_VIDEO_RESIZE_Y_DELTA = 0x0387 + +glut_VISIBLE :: CInt +glut_VISIBLE = 0x0001 + +glut_WINDOW_ACCUM_ALPHA_SIZE :: GLenum +glut_WINDOW_ACCUM_ALPHA_SIZE = 0x0072 + +glut_WINDOW_ACCUM_BLUE_SIZE :: GLenum +glut_WINDOW_ACCUM_BLUE_SIZE = 0x0071 + +glut_WINDOW_ACCUM_GREEN_SIZE :: GLenum +glut_WINDOW_ACCUM_GREEN_SIZE = 0x0070 + +glut_WINDOW_ACCUM_RED_SIZE :: GLenum +glut_WINDOW_ACCUM_RED_SIZE = 0x006F + +glut_WINDOW_ALPHA_SIZE :: GLenum +glut_WINDOW_ALPHA_SIZE = 0x006E + +glut_WINDOW_BLUE_SIZE :: GLenum +glut_WINDOW_BLUE_SIZE = 0x006D + +glut_WINDOW_BORDER_WIDTH :: GLenum +glut_WINDOW_BORDER_WIDTH = 0x01FA + +glut_WINDOW_BUFFER_SIZE :: GLenum +glut_WINDOW_BUFFER_SIZE = 0x0068 + +glut_WINDOW_COLORMAP_SIZE :: GLenum +glut_WINDOW_COLORMAP_SIZE = 0x0077 + +glut_WINDOW_CURSOR :: GLenum +glut_WINDOW_CURSOR = 0x007A + +glut_WINDOW_DEPTH_SIZE :: GLenum +glut_WINDOW_DEPTH_SIZE = 0x006A + +glut_WINDOW_DOUBLEBUFFER :: GLenum +glut_WINDOW_DOUBLEBUFFER = 0x0073 + +glut_WINDOW_FORMAT_ID :: GLenum +glut_WINDOW_FORMAT_ID = 0x007B + +glut_WINDOW_GREEN_SIZE :: GLenum +glut_WINDOW_GREEN_SIZE = 0x006C + +glut_WINDOW_HEADER_HEIGHT :: GLenum +glut_WINDOW_HEADER_HEIGHT = 0x01FB + +glut_WINDOW_HEIGHT :: GLenum +glut_WINDOW_HEIGHT = 0x0067 + +glut_WINDOW_NUM_CHILDREN :: GLenum +glut_WINDOW_NUM_CHILDREN = 0x0076 + +glut_WINDOW_NUM_SAMPLES :: GLenum +glut_WINDOW_NUM_SAMPLES = 0x0078 + +glut_WINDOW_PARENT :: GLenum +glut_WINDOW_PARENT = 0x0075 + +glut_WINDOW_RED_SIZE :: GLenum +glut_WINDOW_RED_SIZE = 0x006B + +glut_WINDOW_RGBA :: GLenum +glut_WINDOW_RGBA = 0x0074 + +glut_WINDOW_STENCIL_SIZE :: GLenum +glut_WINDOW_STENCIL_SIZE = 0x0069 + +glut_WINDOW_STEREO :: GLenum +glut_WINDOW_STEREO = 0x0079 + +glut_WINDOW_WIDTH :: GLenum +glut_WINDOW_WIDTH = 0x0066 + +glut_WINDOW_X :: GLenum +glut_WINDOW_X = 0x0064 + +glut_WINDOW_Y :: GLenum +glut_WINDOW_Y = 0x0065 diff --git a/src/Graphics/UI/GLUT/State.hs b/src/Graphics/UI/GLUT/State.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/State.hs @@ -0,0 +1,448 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.State +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- GLUT maintains a considerable amount of programmer visible state. Some (but +-- not all) of this state may be directly retrieved. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.State ( + -- * State of all windows + windowBorderWidth, windowHeaderHeight, skipStaleMotionEvents, + + -- * State of the /current window/ + + -- ** Framebuffer state + rgba, + BufferDepth, rgbaBufferDepths, colorBufferDepth, + doubleBuffered, stereo, + accumBufferDepths, depthBufferDepth, stencilBufferDepth, + SampleCount, sampleCount, formatID, + + -- ** Full screen state + fullScreenMode, + + -- ** Object rendering state + geometryVisualizeNormals, + + -- ** Vertex attribute state + vertexAttribCoord3, vertexAttribNormal, vertexAttribTexCoord2, + + -- ** Layer state + damaged, + + -- * Timing + elapsedTime, + + -- * Device information + + -- $DeviceInformation + screenSize, screenSizeMM, + hasKeyboard, + ButtonCount, numMouseButtons, + numSpaceballButtons, + DialCount, numDialsAndButtons, + numTabletButtons, + AxisCount, PollRate, joystickInfo, + supportedNumAuxBuffers, supportedSamplesPerPixel, + + -- * GLUT information + glutVersion, initState +) where + +import Control.Monad ( unless ) +import Data.StateVar ( GettableStateVar, makeGettableStateVar + , SettableStateVar, makeSettableStateVar + , StateVar, makeStateVar ) +import Foreign.C.Types ( CInt ) +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Array ( peekArray ) +import Foreign.Storable ( peek ) +import Graphics.Rendering.OpenGL ( AttribLocation(..), Size(..), GLenum, GLint ) + +import Graphics.UI.GLUT.Overlay +import Graphics.UI.GLUT.QueryUtils +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.Window + +-------------------------------------------------------------------------------- + +-- | Contains 'True' when the current layer of the /current window/ is in RGBA +-- mode, 'False' means color index mode. + +rgba :: GettableStateVar Bool +rgba = makeGettableStateVar$ simpleGet i2b glut_WINDOW_RGBA + +-- | Bit depth of a buffer + +type BufferDepth = Int + +-- | Contains the number of red, green, blue, and alpha bits in the color buffer +-- of the /current window\'s/ current layer (0 in color index mode). + +rgbaBufferDepths :: + GettableStateVar (BufferDepth, BufferDepth, BufferDepth, BufferDepth) +rgbaBufferDepths = makeGettableStateVar $ do + r <- simpleGet fromIntegral glut_WINDOW_RED_SIZE + g <- simpleGet fromIntegral glut_WINDOW_GREEN_SIZE + b <- simpleGet fromIntegral glut_WINDOW_BLUE_SIZE + a <- simpleGet fromIntegral glut_WINDOW_ALPHA_SIZE + return (r, g, b, a) + +-- | Contains the total number of bits in the color buffer of the /current +-- window\'s/ current layer. For an RGBA layer, this is the sum of the red, +-- green, blue, and alpha bits. For an color index layer, this is the number +-- of bits of the color indexes. + +colorBufferDepth :: GettableStateVar BufferDepth +colorBufferDepth = + makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_BUFFER_SIZE + +-- | Contains 'True' when the current layer of the /current window/ is double +-- buffered, 'False' otherwise. + +doubleBuffered :: GettableStateVar Bool +doubleBuffered = makeGettableStateVar $ simpleGet i2b glut_WINDOW_DOUBLEBUFFER + +-- | Contains 'True' when the current layer of the /current window/ is stereo, +-- 'False' otherwise. + +stereo :: GettableStateVar Bool +stereo = makeGettableStateVar $ simpleGet i2b glut_WINDOW_STEREO + +-- | Contains the number of red, green, blue, and alpha bits in the accumulation +-- buffer of the /current window\'s/ current layer (0 in color index mode). + +accumBufferDepths :: + GettableStateVar (BufferDepth, BufferDepth, BufferDepth, BufferDepth) +accumBufferDepths = makeGettableStateVar $ do + r <- simpleGet fromIntegral glut_WINDOW_ACCUM_RED_SIZE + g <- simpleGet fromIntegral glut_WINDOW_ACCUM_GREEN_SIZE + b <- simpleGet fromIntegral glut_WINDOW_ACCUM_BLUE_SIZE + a <- simpleGet fromIntegral glut_WINDOW_ACCUM_ALPHA_SIZE + return (r, g, b, a) + +-- | Contains the number of bits in the depth buffer of the /current window\'s/ +-- current layer. + +depthBufferDepth :: GettableStateVar BufferDepth +depthBufferDepth = + makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_DEPTH_SIZE + +-- | Contains the number of bits in the stencil buffer of the /current +-- window\'s/ current layer. + +stencilBufferDepth :: GettableStateVar BufferDepth +stencilBufferDepth = + makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_STENCIL_SIZE + +-- | Number of samples for multisampling + +type SampleCount = Int + +-- | Contains the number of samples for multisampling for the /current window./ + +sampleCount :: GettableStateVar SampleCount +sampleCount = + makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_NUM_SAMPLES + +-- | Contains the window system dependent format ID for the current layer of the +-- /current window/. On X11 GLUT implementations, this is the X visual ID. On +-- Win32 GLUT implementations, this is the Win32 Pixel Format Descriptor number. +-- This value is returned for debugging, benchmarking, and testing ease. + +formatID :: GettableStateVar Int +formatID = makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_FORMAT_ID + +-------------------------------------------------------------------------------- + +-- | (/freeglut only/) Contains 'True' if the /current window/ is in full screen +-- mode, 'False' otherwise. + +fullScreenMode :: StateVar Bool +fullScreenMode = makeStateVar getFullScreenMode setFullScreenMode + +getFullScreenMode :: IO Bool +getFullScreenMode = simpleGet i2b glut_FULL_SCREEN + +setFullScreenMode :: Bool -> IO () +setFullScreenMode newMode = do + oldMode <- getFullScreenMode + unless (newMode == oldMode) fullScreenToggle + +-------------------------------------------------------------------------------- + +-- | (/freeglut only/) Controls if vectors representing the normals should be +-- drawn, too, when objects are drawn. + +geometryVisualizeNormals :: StateVar Bool +geometryVisualizeNormals = + makeStateVar + (simpleGet i2b glut_GEOMETRY_VISUALIZE_NORMALS) + (glutSetOption glut_GEOMETRY_VISUALIZE_NORMALS . b2i) + + +-------------------------------------------------------------------------------- + +-- | (/freeglut only/) If 'vertexAttribCoord3' and 'vertexAttribNormal' both +-- contain 'Nothing', the fixed function pipeline is used to draw +-- objects. Otherwise VBOs are used and the coordinates are passed via 'Just' +-- this attribute location (for a vec3). + +vertexAttribCoord3 :: SettableStateVar (Maybe AttribLocation) +vertexAttribCoord3 = setVertexAttribWith glutSetVertexAttribCoord3 + +setVertexAttribWith :: (GLint -> IO ()) -> SettableStateVar (Maybe AttribLocation) +setVertexAttribWith f = makeSettableStateVar $ f . getLocation + where getLocation = maybe (-1) (\(AttribLocation l) -> fromIntegral l) + +-- | (/freeglut only/) If 'vertexAttribCoord3' and 'vertexAttribNormal' both +-- contain 'Nothing', the fixed function pipeline is used to draw +-- objects. Otherwise VBOs are used and the normals are passed via 'Just' this +-- attribute location (for a vec3). + +vertexAttribNormal :: SettableStateVar (Maybe AttribLocation) +vertexAttribNormal = setVertexAttribWith glutSetVertexAttribNormal + +-- | (/freeglut only/) If VBOs are used to draw objects (controlled via +-- 'vertexAttribCoord3' and 'vertexAttribNormal'), the texture coordinates are +-- passed via 'Just' this attribute location (for a vec2). + +vertexAttribTexCoord2 :: SettableStateVar (Maybe AttribLocation) +vertexAttribTexCoord2 = setVertexAttribWith glutSetVertexAttribTexCoord2 + +-------------------------------------------------------------------------------- + +-- | Contains the number of milliseconds since +-- 'Graphics.UI.GLUT.Initialization.initialize' was called. + +elapsedTime :: GettableStateVar Int +elapsedTime = makeGettableStateVar $ simpleGet fromIntegral glut_ELAPSED_TIME + +-------------------------------------------------------------------------------- + +-- | Contains 'True' if the given plane of the /current window/ has been +-- damaged (by window system activity) since the last display callback was +-- triggered. Calling 'Graphics.UI.GLUT.Window.postRedisplay' or +-- 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay' will not set this 'True'. + +damaged :: Layer -> GettableStateVar Bool +damaged l = makeGettableStateVar $ layerGet isDamaged (marshalDamagedLayer l) + where isDamaged d = d /= 0 && d /= -1 + marshalDamagedLayer x = case x of + Normal -> glut_NORMAL_DAMAGED + Overlay -> glut_OVERLAY_DAMAGED + +-------------------------------------------------------------------------------- + +-- $DeviceInformation +-- If a device is not available, the following state variables contain +-- 'Nothing', otherwise they return 'Just' the specific device information. +-- Only a screen is always assumed. + +-------------------------------------------------------------------------------- + +-- | The size of the screen in pixels. + +screenSize :: GettableStateVar Size +screenSize = + makeGettableStateVar $ do + wpx <- simpleGet fromIntegral glut_SCREEN_WIDTH + hpx <- simpleGet fromIntegral glut_SCREEN_HEIGHT + return $ Size wpx hpx + +-- | The size of the screen in millimeters. + +screenSizeMM :: GettableStateVar Size +screenSizeMM = + makeGettableStateVar $ do + wmm <- simpleGet fromIntegral glut_SCREEN_WIDTH_MM + hmm <- simpleGet fromIntegral glut_SCREEN_HEIGHT_MM + return $ Size wmm hmm + +-------------------------------------------------------------------------------- + +-- | Contains 'True' if a keyboard is present, 'False' otherwise. + +hasKeyboard :: GettableStateVar Bool +hasKeyboard = makeGettableStateVar $ deviceGet i2b glut_HAS_KEYBOARD + +-------------------------------------------------------------------------------- + +-- | Number of buttons of an input device + +type ButtonCount = Int + +-- | Contains 'Just' the number of buttons of an attached mouse or 'Nothing' if +-- there is none. + +numMouseButtons :: GettableStateVar (Maybe ButtonCount) +numMouseButtons = + getDeviceInfo glut_HAS_MOUSE $ + deviceGet fromIntegral glut_NUM_MOUSE_BUTTONS + +-------------------------------------------------------------------------------- + +-- | Contains 'Just' the number of buttons of the attached Spaceball or 'Nothing' +-- if there is none. + +numSpaceballButtons :: GettableStateVar (Maybe ButtonCount) +numSpaceballButtons = + getDeviceInfo glut_HAS_SPACEBALL $ + deviceGet fromIntegral glut_NUM_SPACEBALL_BUTTONS + +-------------------------------------------------------------------------------- + +-- | Number of dials of a dial and button box + +type DialCount = Int + +-- | Contains 'Just' the number of dials and buttons of an attached dial & +-- button box or 'Nothing' if there is none. + +numDialsAndButtons :: GettableStateVar (Maybe (DialCount, ButtonCount)) +numDialsAndButtons = + getDeviceInfo glut_HAS_DIAL_AND_BUTTON_BOX $ do + d <- deviceGet fromIntegral glut_NUM_DIALS + b <- deviceGet fromIntegral glut_NUM_BUTTON_BOX_BUTTONS + return (d, b) + +-------------------------------------------------------------------------------- + +-- | Contains 'Just' the number of buttons of an attached tablet or 'Nothing' if +-- there is none. + +numTabletButtons :: GettableStateVar (Maybe ButtonCount) +numTabletButtons = + getDeviceInfo glut_HAS_TABLET $ + deviceGet fromIntegral glut_NUM_TABLET_BUTTONS + +-------------------------------------------------------------------------------- + +-- | Number of axes of a joystick + +type AxisCount = Int + +-- | The a rate at which a joystick is polled (in milliseconds) + +type PollRate = Int + +-- | Contains 'Just' the number of buttons of an attached joystick, the number +-- of joystick axes, and the rate at which the joystick is polled. Contains +-- 'Nothing' if there is no joystick attached. + +joystickInfo :: GettableStateVar (Maybe (ButtonCount, PollRate, AxisCount)) +joystickInfo = + getDeviceInfo glut_HAS_JOYSTICK $ do + b <- deviceGet fromIntegral glut_JOYSTICK_BUTTONS + a <- deviceGet fromIntegral glut_JOYSTICK_AXES + r <- deviceGet fromIntegral glut_JOYSTICK_POLL_RATE + return (b, a, r) + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Contains a list of the number of auxiliary buffers +-- supported, in increasing order. + +supportedNumAuxBuffers :: GettableStateVar [Int] +supportedNumAuxBuffers = getModeValues glut_AUX + +-- | (/freeglut only/) Contains a list of the number of samples per pixel +-- supported for multisampling, in increasing order. + +supportedSamplesPerPixel :: GettableStateVar [SampleCount] +supportedSamplesPerPixel = getModeValues (fromIntegral glut_MULTISAMPLE) + +getModeValues :: Integral a => GLenum -> GettableStateVar [a] +getModeValues what = makeGettableStateVar $ + alloca $ \sizeBuffer -> do + valuesBuffer <- glutGetModeValues what sizeBuffer + size <- peek sizeBuffer + fmap (map fromIntegral) $ peekArray (fromIntegral size) valuesBuffer + +-------------------------------------------------------------------------------- +-- Convenience (un-)marshalers + +i2b :: CInt -> Bool +i2b = (/= 0) + +b2i :: Bool -> CInt +b2i False = 0 +b2i True = 1 + +-------------------------------------------------------------------------------- + +getDeviceInfo :: GLenum -> IO a -> GettableStateVar (Maybe a) +getDeviceInfo dev act = + makeGettableStateVar $ do + hasDevice <- deviceGet i2b dev + if hasDevice then fmap Just act else return Nothing + +----------------------------------------------------------------------------- + +-- | Contains version of GLUT in the form of +-- @/flavour/ /major/./minor/./patchlevel/@, where @/flavour/@ is one of +-- @GLUT@, @freeglut@ or @OpenGLUT@. + +glutVersion :: GettableStateVar String +glutVersion = makeGettableStateVar $ do + let isGLUT = not `fmap` isKnown "glutSetOption" + isFreeglut = not `fmap` isKnown "glutSetWindowStayOnTop" + showVersionPart x = shows (x `mod` 100) + showVersion v = showVersionPart (v `div` 10000) . showChar '.' . + showVersionPart (v `div` 100) . showChar '.' . + showVersionPart v + g <- isGLUT + if g + then return "GLUT 3.7" -- ToDo: just guessing + else do f <- isFreeglut + v <- simpleGet id glut_VERSION + let prefix = if f then "freeglut" else "OpenGLUT" + return $ showString prefix . showChar ' ' . showVersion v $ "" + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Contains the thickness of the sizing border around the +-- perimeter of a window that can be resized, in pixels. + +windowBorderWidth :: GettableStateVar Int +windowBorderWidth = + makeGettableStateVar (simpleGet fromIntegral glut_WINDOW_BORDER_WIDTH) + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Contains the height of the header\/caption area of a +-- window in pixels. + +windowHeaderHeight :: GettableStateVar Int +windowHeaderHeight = + makeGettableStateVar (simpleGet fromIntegral glut_WINDOW_HEADER_HEIGHT) + +----------------------------------------------------------------------------- + +-- | (/freeglut on X11 only/) Controls if all but the last motion event should +-- be discarded. + +skipStaleMotionEvents :: StateVar Bool +skipStaleMotionEvents = + makeStateVar + (simpleGet i2b glut_SKIP_STALE_MOTION_EVENTS) + (glutSetOption glut_SKIP_STALE_MOTION_EVENTS . b2i) + +----------------------------------------------------------------------------- + +-- | (/freeglut only/) Contains 'True' if GLUT has been initialized +-- with 'Graphics.UI.GLUT.Initialization.initialize' or +-- 'Graphics.UI.GLUT.Initialization.getArgsAndInitialize' has and not yet +-- been de-initialized with 'Graphics.UI.GLUT.Initialization.exit'. Contains +-- 'False' otherwise. + +initState :: GettableStateVar Bool +initState = makeGettableStateVar$ simpleGet i2b glut_INIT_STATE diff --git a/src/Graphics/UI/GLUT/Types.hs b/src/Graphics/UI/GLUT/Types.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Types.hs @@ -0,0 +1,104 @@ +{-# OPTIONS_HADDOCK hide #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Types +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- This is a purely internal module with miscellaneous types which don\'t really +-- have a good place elsewhere. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Types ( + Window(..), -- constructor used only internally + Relation(..), + relationToString, -- used only internally + MouseButton(..), + marshalMouseButton, unmarshalMouseButton -- used only internally +) where + +import Foreign.C.Types +import Graphics.UI.GLUT.Raw + +-------------------------------------------------------------------------------- + +-- | An opaque identifier for a top-level window or a subwindow. + +newtype Window = Window CInt + deriving ( Eq, Ord, Show ) + +-------------------------------------------------------------------------------- + +-- | A relation between a 'Graphics.UI.GLUT.Initialization.DisplayCapability' +-- and a numeric value. + +data Relation + = IsEqualTo -- ^ Equal. + | IsNotEqualTo -- ^ Not equal. + | IsLessThan -- ^ Less than and preferring larger difference (the least + -- is best). + | IsNotGreaterThan -- ^ Less than or equal and preferring larger difference + -- (the least is best). + | IsGreaterThan -- ^ Greater than and preferring larger differences (the + -- most is best). + | IsAtLeast -- ^ Greater than or equal and preferring more instead of + -- less. This relation is useful for allocating + -- resources like color precision or depth buffer + -- precision where the maximum precision is generally + -- preferred. Contrast with 'IsNotLessThan' relation. + | IsNotLessThan -- ^ Greater than or equal but preferring less instead of + -- more. This relation is useful for allocating + -- resources such as stencil bits or auxillary color + -- buffers where you would rather not over-allocate. + deriving ( Eq, Ord, Show ) + +relationToString :: Relation -> String +relationToString IsEqualTo = "=" +relationToString IsNotEqualTo = "!=" +relationToString IsLessThan = "<" +relationToString IsNotGreaterThan = "<=" +relationToString IsGreaterThan = ">" +relationToString IsAtLeast = ">=" +relationToString IsNotLessThan = "~" + +-------------------------------------------------------------------------------- + +-- | Mouse buttons, including a wheel + +data MouseButton + = LeftButton + | MiddleButton + | RightButton + | WheelUp + | WheelDown + | AdditionalButton Int + deriving ( Eq, Ord, Show ) + +marshalMouseButton :: MouseButton -> CInt +marshalMouseButton x = case x of + LeftButton -> glut_LEFT_BUTTON + MiddleButton -> glut_MIDDLE_BUTTON + RightButton -> glut_RIGHT_BUTTON + WheelUp -> glut_WHEEL_UP + WheelDown -> glut_WHEEL_DOWN + AdditionalButton b -> fromIntegral b + +unmarshalMouseButton :: CInt -> MouseButton +unmarshalMouseButton x + | x == glut_LEFT_BUTTON = LeftButton + | x == glut_MIDDLE_BUTTON = MiddleButton + | x == glut_RIGHT_BUTTON = RightButton + | x == glut_WHEEL_UP = WheelUp + | x == glut_WHEEL_DOWN = WheelDown + | otherwise = AdditionalButton (fromIntegral x) + +glut_WHEEL_UP :: CInt +glut_WHEEL_UP = 3 + +glut_WHEEL_DOWN :: CInt +glut_WHEEL_DOWN = 4 diff --git a/src/Graphics/UI/GLUT/Window.hs b/src/Graphics/UI/GLUT/Window.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Window.hs @@ -0,0 +1,506 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.GLUT.Window +-- Copyright : (c) Sven Panne 2002-2018 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- GLUT supports two types of windows: top-level windows and subwindows. Both +-- types support OpenGL rendering and GLUT callbacks. There is a single +-- identifier space for both types of windows. +-- +-------------------------------------------------------------------------------- + +module Graphics.UI.GLUT.Window ( + -- * Window identifiers + Window, + + -- * Creating and destroying (sub-)windows + + -- $CreatingAndDestroyingSubWindows + createWindow, createSubWindow, destroyWindow, + parentWindow, numSubWindows, + + -- * Manipulating the /current window/ + currentWindow, + + -- * Re-displaying and double buffer management + postRedisplay, swapBuffers, + + -- * Changing the window geometry + + -- $ChangingTheWindowGeometry + windowPosition, windowSize, fullScreen, fullScreenToggle, leaveFullScreen, + + -- * Manipulating the stacking order + + -- $ManipulatingTheStackingOrder + pushWindow, popWindow, + + -- * Managing a window\'s display status + WindowStatus(..), windowStatus, + + -- * Changing the window\/icon title + + -- $ChangingTheWindowIconTitle + windowTitle, iconTitle, + + -- * Cursor management + Cursor(..), cursor, pointerPosition +) where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.StateVar ( GettableStateVar, makeGettableStateVar + , SettableStateVar, makeSettableStateVar + , StateVar, makeStateVar ) +import Foreign.C.String ( withCString ) +import Foreign.C.Types ( CInt ) +import Graphics.Rendering.OpenGL ( Position(..), Size(..) ) + +import Graphics.UI.GLUT.QueryUtils +import Graphics.UI.GLUT.Raw +import Graphics.UI.GLUT.Types + +-------------------------------------------------------------------------------- + +-- $CreatingAndDestroyingSubWindows +-- Each created window has a unique associated OpenGL context. State changes to +-- a window\'s associated OpenGL context can be done immediately after the +-- window is created. +-- +-- The /display state/ of a window is initially for the window to be shown. But +-- the window\'s /display state/ is not actually acted upon until +-- 'Graphics.UI.GLUT.Begin.mainLoop' is entered. This means until +-- 'Graphics.UI.GLUT.Begin.mainLoop' is called, rendering to a created window is +-- ineffective because the window can not yet be displayed. +-- +-- The value returned by 'createWindow' and 'createSubWindow' is a unique +-- identifier for the window, which can be used with 'currentWindow'. + +-- | Create a top-level window. The given name will be provided to the window +-- system as the window\'s name. The intent is that the window system will label +-- the window with the name.Implicitly, the /current window/ is set to the newly +-- created window. +-- +-- /X Implementation Notes:/ The proper X Inter-Client Communication Conventions +-- Manual (ICCCM) top-level properties are established. The @WM_COMMAND@ +-- property that lists the command line used to invoke the GLUT program is only +-- established for the first window created. + +createWindow + :: MonadIO m + => String -- ^ The window name + -> m Window -- ^ The identifier for the newly created window +createWindow name = liftIO $ fmap Window $ withCString name glutCreateWindow + +-------------------------------------------------------------------------------- + +-- | Create a subwindow of the identified window with the given relative +-- position and size. Implicitly, the /current window/ is set to the +-- newly created subwindow. Subwindows can be nested arbitrarily deep. + +createSubWindow + :: MonadIO m + => Window -- ^ Identifier of the subwindow\'s parent window. + -> Position -- ^ Window position in pixels relative to parent window\'s + -- origin. + -> Size -- ^ Window size in pixels + -> m Window -- ^ The identifier for the newly created subwindow +createSubWindow (Window win) (Position x y) (Size w h) = do + s <- glutCreateSubWindow win + (fromIntegral x) (fromIntegral y) + (fromIntegral w) (fromIntegral h) + return $ Window s + +-------------------------------------------------------------------------------- + +-- | Contains the /current window\'s/ parent. If the /current window/ is a +-- top-level window, 'Nothing' is returned. + +parentWindow :: GettableStateVar (Maybe Window) +parentWindow = + makeGettableStateVar $ + getWindow (simpleGet Window glut_WINDOW_PARENT) + +-------------------------------------------------------------------------------- + +-- | Contains the number of subwindows the /current window/ has, not counting +-- children of children. + +numSubWindows :: GettableStateVar Int +numSubWindows = + makeGettableStateVar $ + simpleGet fromIntegral glut_WINDOW_NUM_CHILDREN + +-------------------------------------------------------------------------------- + +-- | Destroy the specified window and the window\'s associated OpenGL context, +-- logical colormap (if the window is color index), and overlay and related +-- state (if an overlay has been established). Any subwindows of the destroyed +-- window are also destroyed by 'destroyWindow'. If the specified window was the +-- /current window/, the /current window/ becomes invalid ('currentWindow' will +-- contain 'Nothing'). + +destroyWindow :: MonadIO m => Window -> m () +destroyWindow (Window win) = glutDestroyWindow win + +-------------------------------------------------------------------------------- + +-- | Controls the /current window/. It does /not/ affect the /layer in use/ for +-- the window; this is done using 'Graphics.UI.GLUT.Overlay.layerInUse'. +-- Contains 'Nothing' if no windows exist or the previously /current window/ was +-- destroyed. Setting the /current window/ to 'Nothing' is a no-op. + +currentWindow :: StateVar (Maybe Window) +currentWindow = + makeStateVar + (getWindow (fmap Window glutGetWindow)) + (maybe (return ()) (\(Window win) -> glutSetWindow win)) + +getWindow :: IO Window -> IO (Maybe Window) +getWindow act = do + win <- act + return $ if win == Window 0 then Nothing else Just win + +-------------------------------------------------------------------------------- + +-- | Mark the normal plane of given window (or the /current window/, if none +-- is supplied) as needing to be redisplayed. The next iteration through +-- 'Graphics.UI.GLUT.Begin.mainLoop', the window\'s display callback will be +-- called to redisplay the window\'s normal plane. Multiple calls to +-- 'postRedisplay' before the next display callback opportunity generates only a +-- single redisplay callback. 'postRedisplay' may be called within a window\'s +-- display or overlay display callback to re-mark that window for redisplay. +-- +-- Logically, normal plane damage notification for a window is treated as a +-- 'postRedisplay' on the damaged window. Unlike damage reported by the window +-- system, 'postRedisplay' will /not/ set to true the normal plane\'s damaged +-- status (see 'Graphics.UI.GLUT.State.damaged'). +-- +-- Also, see 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay'. + +postRedisplay :: MonadIO m => Maybe Window -> m () +postRedisplay = maybe glutPostRedisplay (\(Window win) -> glutPostWindowRedisplay win) + +-- | Mark the normal plane of the given window as needing to be redisplayed, +-- otherwise the same as 'postRedisplay'. +-- +-- The advantage of this routine is that it saves the cost of using +-- 'currentWindow' (entailing an expensive OpenGL context switch), which is +-- particularly useful when multiple windows need redisplays posted at the same +-- time. + +-------------------------------------------------------------------------------- + +-- | Perform a buffer swap on the /layer in use/ for the /current window/. +-- Specifically, 'swapBuffers' promotes the contents of the back buffer of the +-- /layer in use/ of the /current window/ to become the contents of the front +-- buffer. The contents of the back buffer then become undefined. The update +-- typically takes place during the vertical retrace of the monitor, rather than +-- immediately after 'swapBuffers' is called. +-- +-- An implicit 'Graphics.Rendering.OpenGL.GL.FlushFinish.flush' is done by +-- 'swapBuffers' before it returns. Subsequent OpenGL commands can be issued +-- immediately after calling 'swapBuffers', but are not executed until the +-- buffer exchange is completed. +-- +-- If the /layer in use/ is not double buffered, 'swapBuffers' has no effect. + +swapBuffers :: MonadIO m => m () +swapBuffers = glutSwapBuffers + +-------------------------------------------------------------------------------- + +-- $ChangingTheWindowGeometry +-- Note that the requests by 'windowPosition', 'windowSize', and 'fullScreen' +-- are not processed immediately. A request is executed after returning to the +-- main event loop. This allows multiple requests to the same window to be +-- coalesced. +-- +-- 'windowPosition' and 'windowSize' requests on a window will disable the full +-- screen status of the window. + +-------------------------------------------------------------------------------- + +-- | Controls the position of the /current window/. For top-level windows, +-- parameters of 'Position' are pixel offsets from the screen origin. For +-- subwindows, the parameters are pixel offsets from the window\'s parent window +-- origin. +-- +-- In the case of top-level windows, setting 'windowPosition' is considered only +-- a request for positioning the window. The window system is free to apply its +-- own policies to top-level window placement. The intent is that top-level +-- windows should be repositioned according to the value of 'windowPosition'. + +windowPosition :: StateVar Position +windowPosition = makeStateVar getWindowPosition setWindowPosition + +setWindowPosition :: Position -> IO () +setWindowPosition (Position x y) = + glutPositionWindow (fromIntegral x) (fromIntegral y) + +getWindowPosition :: IO Position +getWindowPosition = do + x <- simpleGet fromIntegral glut_WINDOW_X + y <- simpleGet fromIntegral glut_WINDOW_Y + return $ Position x y + +-------------------------------------------------------------------------------- + +-- | Controls the size of the /current window/. The parameters of 'Size' are +-- size extents in pixels. The width and height must be positive values. +-- +-- In the case of top-level windows, setting 'windowSize' is considered only a +-- request for sizing the window. The window system is free to apply its own +-- policies to top-level window sizing. The intent is that top-level windows +-- should be reshaped according to the value of 'windowSize'. Whether a reshape +-- actually takes effect and, if so, the reshaped dimensions are reported to the +-- program by a reshape callback. + +windowSize :: StateVar Size +windowSize = makeStateVar getWindowSize setWindowSize + +setWindowSize :: Size -> IO () +setWindowSize (Size w h) = + glutReshapeWindow (fromIntegral w) (fromIntegral h) + +getWindowSize :: IO Size +getWindowSize = do + w <- simpleGet fromIntegral glut_WINDOW_WIDTH + h <- simpleGet fromIntegral glut_WINDOW_HEIGHT + return $ Size w h + +-------------------------------------------------------------------------------- + +-- | Request that the /current window/ be made full screen. The exact semantics +-- of what full screen means may vary by window system. The intent is to make +-- the window as large as possible and disable any window decorations or borders +-- added the window system. The window width and height are not guaranteed to be +-- the same as the screen width and height, but that is the intent of making a +-- window full screen. +-- +-- 'fullScreen' is defined to work only on top-level windows. +-- +-- /X Implementation Notes:/ In the X implementation of GLUT, full screen is +-- implemented by sizing and positioning the window to cover the entire screen +-- and posting the @_MOTIF_WM_HINTS@ property on the window requesting +-- absolutely no decorations. Non-Motif window managers may not respond to +-- @_MOTIF_WM_HINTS@. + +fullScreen :: MonadIO m => m () +fullScreen = glutFullScreen + +-------------------------------------------------------------------------------- + +-- | (/freeglut only/) Toggle between windowed and full screen mode. + +fullScreenToggle :: MonadIO m => m () +fullScreenToggle = glutFullScreenToggle + +-------------------------------------------------------------------------------- + +-- | (/freeglut only/) If we are in full screen mode, resize the current window +-- back to its original size. + +leaveFullScreen :: MonadIO m => m () +leaveFullScreen = glutLeaveFullScreen + +-------------------------------------------------------------------------------- + +-- $ManipulatingTheStackingOrder +-- 'pushWindow' and 'popWindow' work on both top-level windows and subwindows. +-- The effect of pushing and popping windows does not take place immediately. +-- Instead the push or pop is saved for execution upon return to the GLUT event +-- loop. Subsequent pop or push requests on a window replace the previously +-- saved request for that window. The effect of pushing and popping top-level +-- windows is subject to the window system\'s policy for restacking windows. + +-- | Change the stacking order of the /current window/ relative to its siblings +-- (lowering it). + +pushWindow :: MonadIO m => m () +pushWindow = glutPushWindow + +-- | Change the stacking order of the /current window/ relative to its siblings, +-- bringing the /current window/ closer to the top. + +popWindow :: MonadIO m => m () +popWindow = glutPopWindow + +-------------------------------------------------------------------------------- + +-- | The display status of a window. + +data WindowStatus + = Shown + | Hidden + | Iconified + deriving ( Eq, Ord, Show ) + +-- | Controls the display status of the /current window/. +-- +-- Note that the effect of showing, hiding, and iconifying windows does not take +-- place immediately. Instead the requests are saved for execution upon return +-- to the GLUT event loop. Subsequent show, hide, or iconification requests on a +-- window replace the previously saved request for that window. The effect of +-- hiding, showing, or iconifying top-level windows is subject to the window +-- system\'s policy for displaying windows. Subwindows can\'t be iconified. + +windowStatus :: SettableStateVar WindowStatus +windowStatus = makeSettableStateVar setStatus + where setStatus Shown = glutShowWindow + setStatus Hidden = glutHideWindow + setStatus Iconified = glutIconifyWindow + +-------------------------------------------------------------------------------- + +-- $ChangingTheWindowIconTitle +-- 'windowTitle' and 'iconTitle' should be set only when the /current +-- window/ is a top-level window. Upon creation of a top-level window, the +-- window and icon names are determined by the name given to 'createWindow'. +-- Once created, setting 'windowTitle' and 'iconTitle' can change the window and +-- icon names respectively of top-level windows. Each call requests the window +-- system change the title appropriately. Requests are not buffered or +-- coalesced. The policy by which the window and icon name are displayed is +-- window system dependent. + +-- | Controls the window title of the /current top-level window/. + +windowTitle :: SettableStateVar String +windowTitle = + makeSettableStateVar $ \name -> + withCString name glutSetWindowTitle + +-- | Controls the icon title of the /current top-level window/. + +iconTitle :: SettableStateVar String +iconTitle = + makeSettableStateVar $ \name -> + withCString name glutSetIconTitle + +-------------------------------------------------------------------------------- + +-- | The different cursor images GLUT supports. + +data Cursor + = RightArrow -- ^ Arrow pointing up and to the right. + | LeftArrow -- ^ Arrow pointing up and to the left. + | Info -- ^ Pointing hand. + | Destroy -- ^ Skull & cross bones. + | Help -- ^ Question mark. + | Cycle -- ^ Arrows rotating in a circle. + | Spray -- ^ Spray can. + | Wait -- ^ Wrist watch. + | Text -- ^ Insertion point cursor for text. + | Crosshair -- ^ Simple cross-hair. + | UpDown -- ^ Bi-directional pointing up & down. + | LeftRight -- ^ Bi-directional pointing left & right. + | TopSide -- ^ Arrow pointing to top side. + | BottomSide -- ^ Arrow pointing to bottom side. + | LeftSide -- ^ Arrow pointing to left side. + | RightSide -- ^ Arrow pointing to right side. + | TopLeftCorner -- ^ Arrow pointing to top-left corner. + | TopRightCorner -- ^ Arrow pointing to top-right corner. + | BottomRightCorner -- ^ Arrow pointing to bottom-left corner. + | BottomLeftCorner -- ^ Arrow pointing to bottom-right corner. + | Inherit -- ^ Use parent\'s cursor. + | None -- ^ Invisible cursor. + | FullCrosshair -- ^ Full-screen cross-hair cursor (if possible, otherwise 'Crosshair'). + deriving ( Eq, Ord, Show ) + +marshalCursor :: Cursor -> CInt +marshalCursor x = case x of + RightArrow -> glut_CURSOR_RIGHT_ARROW + LeftArrow -> glut_CURSOR_LEFT_ARROW + Info -> glut_CURSOR_INFO + Destroy -> glut_CURSOR_DESTROY + Help -> glut_CURSOR_HELP + Cycle -> glut_CURSOR_CYCLE + Spray -> glut_CURSOR_SPRAY + Wait -> glut_CURSOR_WAIT + Text -> glut_CURSOR_TEXT + Crosshair -> glut_CURSOR_CROSSHAIR + UpDown -> glut_CURSOR_UP_DOWN + LeftRight -> glut_CURSOR_LEFT_RIGHT + TopSide -> glut_CURSOR_TOP_SIDE + BottomSide -> glut_CURSOR_BOTTOM_SIDE + LeftSide -> glut_CURSOR_LEFT_SIDE + RightSide -> glut_CURSOR_RIGHT_SIDE + TopLeftCorner -> glut_CURSOR_TOP_LEFT_CORNER + TopRightCorner -> glut_CURSOR_TOP_RIGHT_CORNER + BottomRightCorner -> glut_CURSOR_BOTTOM_RIGHT_CORNER + BottomLeftCorner -> glut_CURSOR_BOTTOM_LEFT_CORNER + Inherit -> glut_CURSOR_INHERIT + None -> glut_CURSOR_NONE + FullCrosshair -> glut_CURSOR_FULL_CROSSHAIR + +unmarshalCursor :: CInt -> Cursor +unmarshalCursor x + | x == glut_CURSOR_RIGHT_ARROW = RightArrow + | x == glut_CURSOR_LEFT_ARROW = LeftArrow + | x == glut_CURSOR_INFO = Info + | x == glut_CURSOR_DESTROY = Destroy + | x == glut_CURSOR_HELP = Help + | x == glut_CURSOR_CYCLE = Cycle + | x == glut_CURSOR_SPRAY = Spray + | x == glut_CURSOR_WAIT = Wait + | x == glut_CURSOR_TEXT = Text + | x == glut_CURSOR_CROSSHAIR = Crosshair + | x == glut_CURSOR_UP_DOWN = UpDown + | x == glut_CURSOR_LEFT_RIGHT = LeftRight + | x == glut_CURSOR_TOP_SIDE = TopSide + | x == glut_CURSOR_BOTTOM_SIDE = BottomSide + | x == glut_CURSOR_LEFT_SIDE = LeftSide + | x == glut_CURSOR_RIGHT_SIDE = RightSide + | x == glut_CURSOR_TOP_LEFT_CORNER = TopLeftCorner + | x == glut_CURSOR_TOP_RIGHT_CORNER = TopRightCorner + | x == glut_CURSOR_BOTTOM_RIGHT_CORNER = BottomRightCorner + | x == glut_CURSOR_BOTTOM_LEFT_CORNER = BottomLeftCorner + | x == glut_CURSOR_INHERIT = Inherit + | x == glut_CURSOR_NONE = None + | x == glut_CURSOR_FULL_CROSSHAIR = FullCrosshair + | otherwise = error ("unmarshalCursor: illegal value " ++ show x) + +-------------------------------------------------------------------------------- + +-- | Change the cursor image of the /current window/. Each call requests the +-- window system change the cursor appropriately. The cursor image when a window +-- is created is 'Inherit'. The exact cursor images used are implementation +-- dependent. The intent is for the image to convey the meaning of the cursor +-- name. For a top-level window, 'Inherit' uses the default window system +-- cursor. +-- +-- /X Implementation Notes:/ GLUT for X uses SGI\'s @_SGI_CROSSHAIR_CURSOR@ +-- convention to access a full-screen cross-hair cursor if possible. + +cursor :: StateVar Cursor +cursor = makeStateVar getCursor setCursor + +setCursor :: Cursor -> IO () +setCursor = glutSetCursor . marshalCursor + +getCursor :: IO Cursor +getCursor = simpleGet unmarshalCursor glut_WINDOW_CURSOR + +-------------------------------------------------------------------------------- + +-- | Setting 'pointerPosition' warps the window system\'s pointer to a new +-- location relative to the origin of the /current window/ by the specified +-- pixel offset, which may be negative. The warp is done immediately. +-- +-- If the pointer would be warped outside the screen\'s frame buffer region, the +-- location will be clamped to the nearest screen edge. The window system is +-- allowed to further constrain the pointer\'s location in window system +-- dependent ways. +-- +-- Good advice from Xlib\'s @XWarpPointer@ man page: \"There is seldom any +-- reason for calling this function. The pointer should normally be left to the +-- user.\" + +pointerPosition :: SettableStateVar Position +pointerPosition = + makeSettableStateVar $ \(Position x y) -> + glutWarpPointer (fromIntegral x) (fromIntegral y)