packages feed

GLUT 2.3.0.0 → 2.7.0.16

raw patch · 232 files changed

Files

+ CHANGELOG.md view
@@ -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.
GLUT.cabal view
@@ -1,172 +1,920 @@ name: GLUT-version: 2.3.0.0-license: BSD3-license-file: LICENSE-maintainer: Jason Dagit <dagitj@gmail.com>, Sven Panne <sven.panne@aedion.de>-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:-   <http://www.opengl.org/resources/libraries/glut/>.-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:+  <http://www.opengl.org/resources/libraries/glut/>.+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 <svenpanne@gmail.com>, Jason Dagit <dagitj@gmail.com>+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
− Graphics/UI/GLUT.hs 
@@ -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--- <http://freeglut.sourceforge.net/>) and OpenGLUT (see--- <http://openglut.sourceforge.net/>), 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 <http://www.opengl.org/> 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.
− Graphics/UI/GLUT/Begin.hs 
@@ -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)
− Graphics/UI/GLUT/Callbacks.hs 
@@ -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
− Graphics/UI/GLUT/Callbacks/Global.hs 
@@ -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
− Graphics/UI/GLUT/Callbacks/Registration.hs 
@@ -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
− Graphics/UI/GLUT/Callbacks/Window.hs 
@@ -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))
− Graphics/UI/GLUT/Colormap.hs 
@@ -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
− Graphics/UI/GLUT/Debugging.hs 
@@ -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)
− Graphics/UI/GLUT/DeviceControl.hs 
@@ -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
− Graphics/UI/GLUT/Fonts.hs 
@@ -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
− Graphics/UI/GLUT/GameMode.hs 
@@ -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 <http://freeglut.sourceforge.net/>) 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
− Graphics/UI/GLUT/Initialization.hs 
@@ -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
− Graphics/UI/GLUT/Menu.hs 
@@ -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
− Graphics/UI/GLUT/Objects.hs 
@@ -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---    <http://mathworld.wolfram.com/PlatonicSolid.html>.------ * A rhombic dodecahedron, see---   <http://mathworld.wolfram.com/RhombicDodecahedron.html>.------ * 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---   <http://mathworld.wolfram.com/Tetrix.html>.--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
− Graphics/UI/GLUT/Overlay.hs 
@@ -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)
− Graphics/UI/GLUT/QueryUtils.hs 
@@ -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
− Graphics/UI/GLUT/Raw.hs 
@@ -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
− Graphics/UI/GLUT/Raw/APIEntry.hs 
@@ -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)
− Graphics/UI/GLUT/Raw/Callbacks.hs 
@@ -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)
− Graphics/UI/GLUT/Raw/Fonts.hs 
@@ -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)
− Graphics/UI/GLUT/Raw/Functions.hs 
@@ -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))
− Graphics/UI/GLUT/Raw/Tokens.hs 
@@ -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
− Graphics/UI/GLUT/State.hs 
@@ -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
− Graphics/UI/GLUT/Types.hs 
@@ -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
− Graphics/UI/GLUT/Window.hs 
@@ -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)
LICENSE view
@@ -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
− README 
@@ -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.
+ README.md view
@@ -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)
cbits/HsGLUT.c view
@@ -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 <svenpanne@gmail.com>+ * 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 <windows.h> +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 <mach-o/dyld.h> #include <stdlib.h>-#include <string.h>+#include <dlfcn.h> +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 <stdlib.h>-#include <dlfcn.h>+/* 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;+}
+ examples/00-README view
@@ -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.
+ examples/BOGLGP/00-README view
@@ -0,0 +1,2 @@+This directory contains some examples from the book "Beginning OpenGL Game+Programming", 2nd ed., by Benstead/Astle/Hawkins.
examples/BOGLGP/Chapter01/OnYourOwn1.hs view
@@ -1,6 +1,6 @@ {-    OnYourOwn1.hs (adapted from Simple.cpp which is (c) 2004 Astle/Hawkins)-   Copyright (c) Sven Panne 2004-2005 <sven.panne@aedion.de>+   Copyright (c) Sven Panne 2004-2018 <svenpanne@gmail.com>    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
examples/BOGLGP/Chapter01/Simple.hs view
@@ -1,6 +1,6 @@ {-    Simple.hs (adapted from Simple.cpp which is (c) 2004 Astle/Hawkins)-   Copyright (c) Sven Panne 2004-2005 <sven.panne@aedion.de>+   Copyright (c) Sven Panne 2004-2018 <svenpanne@gmail.com>    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
examples/BOGLGP/Chapter02/OnYourOwn1.hs view
@@ -1,6 +1,6 @@ {-    OnYourOwn1.hs (adapted from OpenGLApplication which is (c) 2004 Astle/Hawkins)-   Copyright (c) Sven Panne 2004-2005 <sven.panne@aedion.de>+   Copyright (c) Sven Panne 2004-2018 <svenpanne@gmail.com>    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 ()  --------------------------------------------------------------------------------
examples/BOGLGP/Chapter02/OpenGLApplication.hs view
@@ -1,6 +1,6 @@ {-    OpenGLApplication.hs (adapted from OpenGLApplication which is (c) 2004 Astle/Hawkins)-   Copyright (c) Sven Panne 2004-2005 <sven.panne@aedion.de>+   Copyright (c) Sven Panne 2004-2018 <svenpanne@gmail.com>    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 ()  --------------------------------------------------------------------------------
examples/BOGLGP/Chapter03/Lines.hs view
@@ -1,6 +1,6 @@ {-    Lines.hs (adapted from Lines which is (c) 2004 Astle/Hawkins)-   Copyright (c) Sven Panne 2004-2005 <sven.panne@aedion.de>+   Copyright (c) Sven Panne 2004-2018 <svenpanne@gmail.com>    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 ()  --------------------------------------------------------------------------------
examples/BOGLGP/Chapter03/OnYourOwn1.hs view
@@ -1,6 +1,6 @@ {-    OnYourOwn1.hs (adapted from OnYourOwn1 which is (c) 2004 Astle/Hawkins)-   Copyright (c) Sven Panne 2005 <sven.panne@aedion.de>+   Copyright (c) Sven Panne 2018 <svenpanne@gmail.com>    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 ()  --------------------------------------------------------------------------------
examples/BOGLGP/Chapter03/Points.hs view
@@ -1,6 +1,6 @@ {-    Points.hs (adapted from Points which is (c) 2004 Astle/Hawkins)-   Copyright (c) Sven Panne 2004-2005 <sven.panne@aedion.de>+   Copyright (c) Sven Panne 2004-2018 <svenpanne@gmail.com>    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 ()  --------------------------------------------------------------------------------
examples/BOGLGP/Chapter03/Polygons.hs view
@@ -1,6 +1,6 @@ {-    Polygons.hs (adapted from Polygons which is (c) 2004 Astle/Hawkins)-   Copyright (c) Sven Panne 2004-2005 <sven.panne@aedion.de>+   Copyright (c) Sven Panne 2004-2018 <svenpanne@gmail.com>    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 ()  --------------------------------------------------------------------------------
examples/BOGLGP/Chapter03/TrianglesQuads.hs view
@@ -1,6 +1,6 @@ {-    TrianglesQuads.hs (adapted from TrianglesQuads which is (c) 2004 Astle/Hawkins)-   Copyright (c) Sven Panne 2004-2005 <sven.panne@aedion.de>+   Copyright (c) Sven Panne 2004-2018 <svenpanne@gmail.com>    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)
+ examples/Misc/00-README view
@@ -0,0 +1,1 @@+This directory contains a few random examples from e.g. the Mesa sources.
examples/Misc/ARBOcclude.hs view
@@ -1,6 +1,6 @@ {-    ARBOcclude.hs (adapted from arbocclude.c which is (c) Brian Paul)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>    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
+ examples/Misc/ColorTriangle/ColorTriangle.hs view
@@ -0,0 +1,101 @@+{-+   ColorTriangle.hs (adapted from triangles.cpp which is (c) The Red Book+   Authors.)+   Copyright (c) Sven Panne 2018 <svenpanne@gmail.com>+   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
+ examples/Misc/ColorTriangle/color_triangles.frag view
@@ -0,0 +1,10 @@+#version 430 core++in vec4 color;+out vec4 fColor;++void+main()+{+   fColor = color;+}
+ examples/Misc/ColorTriangle/color_triangles.vert view
@@ -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;+}
examples/Misc/ExtractContours.hs view
@@ -1,6 +1,6 @@ {-    ExtractContours.hs (adapted from tess.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>    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
examples/Misc/Gears.hs view
@@ -1,7 +1,7 @@ {-    Gears.hs (adapted from gears.c which is (c) Brian Paul)    Copyright (c) Shawn P. Garbett 2004 <shawn@garbett.org>-   Further hacked by Sven Panne <sven.panne@aedion.de>+   Further hacked by Sven Panne <svenpanne@gmail.com>    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
examples/Misc/Pitfall14.hs view
@@ -1,6 +1,6 @@ {-    Pitfall14-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>    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
examples/Misc/SmoothOpenGL3.hs view
@@ -1,22 +1,31 @@+{-# LANGUAGE CPP #-} {-    SmoothOpenGL3.hs (adapted from freeglut's smooth_opengl3.c example)-   Copyright (c) Sven Panne 2009 <sven.panne@aedion.de>+   Copyright (c) Sven Panne 2018 <svenpanne@gmail.com>    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
examples/Misc/Triangulate.hs view
@@ -1,6 +1,6 @@ {-    Triangulate.hs (adapted from tess.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>    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
+ examples/OrangeBook/00-README view
@@ -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.
examples/OrangeBook/ogl2brick/Brick.hs view
@@ -1,14 +1,19 @@+{-# LANGUAGE CPP #-} {-    Brick.hs (adapted from ogl2brick.c which is (c) 3Dlabs Inc. Ltd.)-   Copyright (c) Sven Panne 2006 <sven.panne@aedion.de>+   Copyright (c) Sven Panne 2018 <svenpanne@gmail.com>    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
− examples/RedBook/00-README 
@@ -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--        <No programs included>--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.
− examples/RedBook/AAIndex.hs 
@@ -1,104 +0,0 @@-{--   AAIndex.hs (adapted from aaindex.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>-   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
− examples/RedBook/AARGB.hs 
@@ -1,104 +0,0 @@-{--   AARGB.hs (adapted from aargb.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>-   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
− examples/RedBook/AccAnti.hs 
@@ -1,132 +0,0 @@-{--   AccAnti.hs (adapted from accanti.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>-   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
− examples/RedBook/AccPersp.hs 
@@ -1,166 +0,0 @@-{--   AccPersp.hs (adapted from accpersp.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>-   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
− examples/RedBook/Alpha.hs 
@@ -1,91 +0,0 @@-{--   Alpha.hs (adapted from alpha.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Alpha3D.hs 
@@ -1,124 +0,0 @@-{--   Alpha3D.hs (adapted from alpha3D.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>-   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
− examples/RedBook/BezCurve.hs 
@@ -1,67 +0,0 @@-{--   BezCurve.hs (adapted from bezcurve.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/BezMesh.hs 
@@ -1,84 +0,0 @@-{--   BezMesh.hs (adapted from bezmesh.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/BezSurf.hs 
@@ -1,79 +0,0 @@-{--   BezSurf.hs (adapted from bezsurf.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/BlendEqn.hs 
@@ -1,95 +0,0 @@-{--   BlendEqn.hs (adapted from blendeqn.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Checker.hs 
@@ -1,101 +0,0 @@-{--   Checker.hs  (adapted from checker.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Clip.hs 
@@ -1,63 +0,0 @@-{--   Clip.hs (adapted from clip.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/ColorMat.hs 
@@ -1,94 +0,0 @@-{--   Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/ColorMatrix.hs 
@@ -1,65 +0,0 @@-{--   ColorMatrix.hs (adapted from colormatrix.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/ColorTable.hs 
@@ -1,62 +0,0 @@-{--   ColorTable.hs (adapted from colortable.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Combiner.hs 
@@ -1,236 +0,0 @@-{--   Combiner.hs  (adapted from combiner.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Convolution.hs 
@@ -1,83 +0,0 @@-{--   Convolution.hs (adapted from convolution.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Cube.hs 
@@ -1,56 +0,0 @@-{--   Cube.hs (adapted from cube.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/CubeMap.hs 
@@ -1,118 +0,0 @@-{--   CubeMap.hs  (adapted from CubeMap.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/DList.hs 
@@ -1,85 +0,0 @@-{--   DList.hs (adapted from list.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/DOF.hs 
@@ -1,182 +0,0 @@-{--   DOF.hs (adapted from dof.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>-   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
− examples/RedBook/Data/leeds.bin

binary file changed (720605 → absent bytes)

− examples/RedBook/Double.hs 
@@ -1,76 +0,0 @@-{--   Double.hs (adapted from double.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/DrawF.hs 
@@ -1,62 +0,0 @@-{--   DrawF.hs  (adapted from drawf.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Feedback.hs 
@@ -1,77 +0,0 @@-{--   Feedback.hs (adapted from feedback.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Fog.hs 
@@ -1,90 +0,0 @@-{--   Fog.hs (adapted from fog.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/FogCoord.hs 
@@ -1,122 +0,0 @@-{--   FogCoord.hs (adapted from fogcoord.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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--
− examples/RedBook/FogIndex.hs 
@@ -1,76 +0,0 @@-{--   FogIndex.hs (adapted from fogindex.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Font.hs 
@@ -1,127 +0,0 @@-{--   Font.hs  (adapted from font.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Hello.hs 
@@ -1,55 +0,0 @@-{--   Hello.hs (adapted from hello.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Histogram.hs 
@@ -1,85 +0,0 @@-{--   Histogram.hs (adapted from histogram.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Image.hs 
@@ -1,116 +0,0 @@-{--   Image.hs  (adapted from image.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Light.hs 
@@ -1,62 +0,0 @@-{--   Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Lines.hs 
@@ -1,88 +0,0 @@-{--   Lines.hs (adapted from lines.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/MVArray.hs 
@@ -1,87 +0,0 @@-{--   MVArray.hs (adapted from mvarray.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Material.hs 
@@ -1,149 +0,0 @@-{--   Material.hs (adapted from material.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Minmax.hs 
@@ -1,64 +0,0 @@-{--   Minmax.hs (adapted from minmax.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Mipmap.hs 
@@ -1,97 +0,0 @@-{--   Mipmap.hs  (adapted from mipmap.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Model.hs 
@@ -1,86 +0,0 @@-{--   Model.hs (adapted from model.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/MoveLight.hs 
@@ -1,85 +0,0 @@-{--   MoveLight.hs (adapted from movelight.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/MultiTex.hs 
@@ -1,111 +0,0 @@-{--   MultiTex.hs  (adapted from multitex.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Multisamp.hs 
@@ -1,137 +0,0 @@-{--   Multisamp.hs (adapted from multisamp.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>-   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
− examples/RedBook/PickDepth.hs 
@@ -1,126 +0,0 @@-{--   PickDepth.hs (adapted from pickdepth.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/PickSquare.hs 
@@ -1,121 +0,0 @@-{--   PickSquare.hs (adapted from picksquare.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Planet.hs 
@@ -1,83 +0,0 @@-{--   Planet.hs (adapted from planet.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/PointP.hs 
@@ -1,152 +0,0 @@-{--   PointP.hs (adapted from pointp.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>-   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
− examples/RedBook/PolyOff.hs 
@@ -1,151 +0,0 @@-{--   PolyOff.hs (adapted from polyoff.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>-   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
− examples/RedBook/Polys.hs 
@@ -1,84 +0,0 @@-{--   Polys.hs (adapted from polys.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Quadric.hs 
@@ -1,106 +0,0 @@-{--   Quadric.hs (adapted from quadric.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/ReadImage.hs 
@@ -1,65 +0,0 @@-{--   ReadImage.hs (adapted from readImage.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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)
− examples/RedBook/Robot.hs 
@@ -1,89 +0,0 @@-{--   Robot.hs (adapted from robot.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Scene.hs 
@@ -1,73 +0,0 @@-{--   Scene.hs (adapted from scene.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Select.hs 
@@ -1,150 +0,0 @@-{--   Select.hs (adapted from select.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/ShadowMap.hs 
@@ -1,255 +0,0 @@-{--   ShadowMap.hs (adapted from shadowmap.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Smooth.hs 
@@ -1,65 +0,0 @@-{--   Smooth.hs (adapted from smooth.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Stencil.hs 
@@ -1,123 +0,0 @@-{--   Stencil.hs (adapted from stencil.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>-   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
− examples/RedBook/Stroke.hs 
@@ -1,127 +0,0 @@-{--   Stroke.hs (adapted from stroke.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>-   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
− examples/RedBook/SurfPoints.hs 
@@ -1,129 +0,0 @@-{--   SurfPoints.hs (adapted from surfpoints.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Surface.hs 
@@ -1,112 +0,0 @@-{--   Surface.hs (adapted from surface.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Teapots.hs 
@@ -1,226 +0,0 @@-{--   Teapots.hs (adapted from teapots.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Tess.hs 
@@ -1,117 +0,0 @@-{--   Tess.hs (adapted from tess.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/TessWind.hs 
@@ -1,195 +0,0 @@-{--   TessWind.hs (adapted from tesswind.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/TexBind.hs 
@@ -1,108 +0,0 @@-{--   TexBind.hs  (adapted from texbind.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/TexGen.hs 
@@ -1,132 +0,0 @@-{--   TexGen.hs  (adapted from texgen.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/TexProx.hs 
@@ -1,58 +0,0 @@-{--   TexProx.hs (adapted from texprox.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/TexSub.hs 
@@ -1,120 +0,0 @@-{--   TexSub.hs  (adapted from texsub.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Texture3D.hs 
@@ -1,94 +0,0 @@-{--   Texture3D.hs  (adapted from texture3d.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/TextureSurf.hs 
@@ -1,99 +0,0 @@-{--   TextureSurf.hs (adapted from texturesurf.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Torus.hs 
@@ -1,93 +0,0 @@-{--   Torus.hs (adapted from torus.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>-   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
− examples/RedBook/Trim.hs 
@@ -1,107 +0,0 @@-{--   Trim.hs (adapted from trim.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/UnProject.hs 
@@ -1,54 +0,0 @@-{--   UnProject.hs (adapted from unproject.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/VArray.hs 
@@ -1,141 +0,0 @@-{--   VArray.hs (adapted from varray.c which is (c) Silicon Graphics, Inc.)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
− examples/RedBook/Wrap.hs 
@@ -1,114 +0,0 @@-{--   Wrap.hs  (adapted from wrap.c which is (c) Silicon Graphics, Inc)-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>-   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
+ examples/RedBook4/00-README view
@@ -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++        <No programs included>++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.
+ examples/RedBook4/AAIndex.hs view
@@ -0,0 +1,104 @@+{-+   AAIndex.hs (adapted from aaindex.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/AARGB.hs view
@@ -0,0 +1,104 @@+{-+   AARGB.hs (adapted from aargb.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/AccAnti.hs view
@@ -0,0 +1,132 @@+{-+   AccAnti.hs (adapted from accanti.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/AccPersp.hs view
@@ -0,0 +1,166 @@+{-+   AccPersp.hs (adapted from accpersp.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Alpha.hs view
@@ -0,0 +1,91 @@+{-+   Alpha.hs (adapted from alpha.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Alpha3D.hs view
@@ -0,0 +1,124 @@+{-+   Alpha3D.hs (adapted from alpha3D.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/BezCurve.hs view
@@ -0,0 +1,67 @@+{-+   BezCurve.hs (adapted from bezcurve.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/BezMesh.hs view
@@ -0,0 +1,84 @@+{-+   BezMesh.hs (adapted from bezmesh.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/BezSurf.hs view
@@ -0,0 +1,79 @@+{-+   BezSurf.hs (adapted from bezsurf.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/BlendEqn.hs view
@@ -0,0 +1,95 @@+{-+   BlendEqn.hs (adapted from blendeqn.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Checker.hs view
@@ -0,0 +1,101 @@+{-+   Checker.hs  (adapted from checker.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Clip.hs view
@@ -0,0 +1,63 @@+{-+   Clip.hs (adapted from clip.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/ColorMat.hs view
@@ -0,0 +1,94 @@+{-+   Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/ColorMatrix.hs view
@@ -0,0 +1,65 @@+{-+   ColorMatrix.hs (adapted from colormatrix.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/ColorTable.hs view
@@ -0,0 +1,62 @@+{-+   ColorTable.hs (adapted from colortable.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Combiner.hs view
@@ -0,0 +1,236 @@+{-+   Combiner.hs  (adapted from combiner.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Convolution.hs view
@@ -0,0 +1,83 @@+{-+   Convolution.hs (adapted from convolution.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Cube.hs view
@@ -0,0 +1,56 @@+{-+   Cube.hs (adapted from cube.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/CubeMap.hs view
@@ -0,0 +1,118 @@+{-+   CubeMap.hs  (adapted from CubeMap.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/DList.hs view
@@ -0,0 +1,85 @@+{-+   DList.hs (adapted from list.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/DOF.hs view
@@ -0,0 +1,182 @@+{-+   DOF.hs (adapted from dof.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Data/leeds.bin view

binary file changed (absent → 720605 bytes)

+ examples/RedBook4/Double.hs view
@@ -0,0 +1,76 @@+{-+   Double.hs (adapted from double.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/DrawF.hs view
@@ -0,0 +1,62 @@+{-+   DrawF.hs  (adapted from drawf.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Feedback.hs view
@@ -0,0 +1,77 @@+{-+   Feedback.hs (adapted from feedback.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Fog.hs view
@@ -0,0 +1,90 @@+{-+   Fog.hs (adapted from fog.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/FogCoord.hs view
@@ -0,0 +1,122 @@+{-+   FogCoord.hs (adapted from fogcoord.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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++
+ examples/RedBook4/FogIndex.hs view
@@ -0,0 +1,76 @@+{-+   FogIndex.hs (adapted from fogindex.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Font.hs view
@@ -0,0 +1,127 @@+{-+   Font.hs  (adapted from font.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Hello.hs view
@@ -0,0 +1,55 @@+{-+   Hello.hs (adapted from hello.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Histogram.hs view
@@ -0,0 +1,85 @@+{-+   Histogram.hs (adapted from histogram.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Image.hs view
@@ -0,0 +1,116 @@+{-+   Image.hs  (adapted from image.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Light.hs view
@@ -0,0 +1,62 @@+{-+   Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Lines.hs view
@@ -0,0 +1,88 @@+{-+   Lines.hs (adapted from lines.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/MVArray.hs view
@@ -0,0 +1,87 @@+{-+   MVArray.hs (adapted from mvarray.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Material.hs view
@@ -0,0 +1,149 @@+{-+   Material.hs (adapted from material.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Minmax.hs view
@@ -0,0 +1,64 @@+{-+   Minmax.hs (adapted from minmax.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Mipmap.hs view
@@ -0,0 +1,97 @@+{-+   Mipmap.hs  (adapted from mipmap.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Model.hs view
@@ -0,0 +1,86 @@+{-+   Model.hs (adapted from model.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/MoveLight.hs view
@@ -0,0 +1,85 @@+{-+   MoveLight.hs (adapted from movelight.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/MultiTex.hs view
@@ -0,0 +1,111 @@+{-+   MultiTex.hs  (adapted from multitex.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Multisamp.hs view
@@ -0,0 +1,137 @@+{-+   Multisamp.hs (adapted from multisamp.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/PickDepth.hs view
@@ -0,0 +1,126 @@+{-+   PickDepth.hs (adapted from pickdepth.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/PickSquare.hs view
@@ -0,0 +1,121 @@+{-+   PickSquare.hs (adapted from picksquare.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Planet.hs view
@@ -0,0 +1,83 @@+{-+   Planet.hs (adapted from planet.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/PointP.hs view
@@ -0,0 +1,152 @@+{-+   PointP.hs (adapted from pointp.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/PolyOff.hs view
@@ -0,0 +1,151 @@+{-+   PolyOff.hs (adapted from polyoff.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Polys.hs view
@@ -0,0 +1,84 @@+{-+   Polys.hs (adapted from polys.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Quadric.hs view
@@ -0,0 +1,106 @@+{-+   Quadric.hs (adapted from quadric.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/ReadImage.hs view
@@ -0,0 +1,65 @@+{-+   ReadImage.hs (adapted from readImage.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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)
+ examples/RedBook4/Robot.hs view
@@ -0,0 +1,89 @@+{-+   Robot.hs (adapted from robot.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Scene.hs view
@@ -0,0 +1,73 @@+{-+   Scene.hs (adapted from scene.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Select.hs view
@@ -0,0 +1,150 @@+{-+   Select.hs (adapted from select.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/ShadowMap.hs view
@@ -0,0 +1,255 @@+{-+   ShadowMap.hs (adapted from shadowmap.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Smooth.hs view
@@ -0,0 +1,65 @@+{-+   Smooth.hs (adapted from smooth.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Stencil.hs view
@@ -0,0 +1,123 @@+{-+   Stencil.hs (adapted from stencil.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Stroke.hs view
@@ -0,0 +1,127 @@+{-+   Stroke.hs (adapted from stroke.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/SurfPoints.hs view
@@ -0,0 +1,129 @@+{-+   SurfPoints.hs (adapted from surfpoints.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Surface.hs view
@@ -0,0 +1,112 @@+{-+   Surface.hs (adapted from surface.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Teapots.hs view
@@ -0,0 +1,226 @@+{-+   Teapots.hs (adapted from teapots.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Tess.hs view
@@ -0,0 +1,117 @@+{-+   Tess.hs (adapted from tess.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/TessWind.hs view
@@ -0,0 +1,195 @@+{-+   TessWind.hs (adapted from tesswind.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/TexBind.hs view
@@ -0,0 +1,108 @@+{-+   TexBind.hs  (adapted from texbind.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/TexGen.hs view
@@ -0,0 +1,132 @@+{-+   TexGen.hs  (adapted from texgen.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/TexProx.hs view
@@ -0,0 +1,58 @@+{-+   TexProx.hs (adapted from texprox.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/TexSub.hs view
@@ -0,0 +1,120 @@+{-+   TexSub.hs  (adapted from texsub.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Texture3D.hs view
@@ -0,0 +1,94 @@+{-+   Texture3D.hs  (adapted from texture3d.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/TextureSurf.hs view
@@ -0,0 +1,99 @@+{-+   TextureSurf.hs (adapted from texturesurf.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Torus.hs view
@@ -0,0 +1,93 @@+{-+   Torus.hs (adapted from torus.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Trim.hs view
@@ -0,0 +1,107 @@+{-+   Trim.hs (adapted from trim.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/UnProject.hs view
@@ -0,0 +1,54 @@+{-+   UnProject.hs (adapted from unproject.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/VArray.hs view
@@ -0,0 +1,141 @@+{-+   VArray.hs (adapted from varray.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook4/Wrap.hs view
@@ -0,0 +1,114 @@+{-+   Wrap.hs  (adapted from wrap.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>+   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
+ examples/RedBook8/00-README view
@@ -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.
+ examples/RedBook8/Chapter01/Triangles.hs view
@@ -0,0 +1,76 @@+{-+   Triangles.hs (adapted from triangles.cpp which is (c) The Red Book Authors.)+   Copyright (c) Sven Panne 2018 <svenpanne@gmail.com>+   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
+ examples/RedBook8/Chapter01/triangles.frag view
@@ -0,0 +1,8 @@+#version 430 core++out vec4 fColor;+void+main()+{+   fColor = vec4(0.0, 0.0, 1.0, 1.0);+}
+ examples/RedBook8/Chapter01/triangles.vert view
@@ -0,0 +1,9 @@+#version 430 core++layout(location = 0) in vec4 vPosition;++void+main()+{+   gl_Position = vPosition;+}
+ examples/RedBook8/common/LoadShaders.hs view
@@ -0,0 +1,89 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  LoadShaders+-- Copyright   :  (c) Sven Panne 2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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)
− include/HsGLUTExt.h 
@@ -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
+ src/Graphics/UI/GLUT.hs view
@@ -0,0 +1,386 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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+-- <http://freeglut.sourceforge.net/>) and OpenGLUT (see+-- <http://openglut.sourceforge.net/>), 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 <http://www.opengl.org/> 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.
+ src/Graphics/UI/GLUT/Begin.hs view
@@ -0,0 +1,100 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Begin+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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)
+ src/Graphics/UI/GLUT/Callbacks.hs view
@@ -0,0 +1,47 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Callbacks+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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
+ src/Graphics/UI/GLUT/Callbacks/Global.hs view
@@ -0,0 +1,114 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Callbacks.Global+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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
+ src/Graphics/UI/GLUT/Callbacks/Registration.hs view
@@ -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 <svenpanne@gmail.com>+-- 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
+ src/Graphics/UI/GLUT/Callbacks/Window.hs view
@@ -0,0 +1,993 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Callbacks.Window+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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))
+ src/Graphics/UI/GLUT/Colormap.hs view
@@ -0,0 +1,112 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Colormap+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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
+ src/Graphics/UI/GLUT/Debugging.hs view
@@ -0,0 +1,39 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Debugging+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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)
+ src/Graphics/UI/GLUT/DeviceControl.hs view
@@ -0,0 +1,124 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.DeviceControl+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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
+ src/Graphics/UI/GLUT/Fonts.hs view
@@ -0,0 +1,128 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Fonts+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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
+ src/Graphics/UI/GLUT/GameMode.hs view
@@ -0,0 +1,193 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.GameMode+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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 <http://freeglut.sourceforge.net/>) 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
+ src/Graphics/UI/GLUT/Initialization.hs view
@@ -0,0 +1,773 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Initialization+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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
+ src/Graphics/UI/GLUT/Menu.hs view
@@ -0,0 +1,265 @@+{-# OPTIONS_GHC -fno-cse #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Menu+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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
+ src/Graphics/UI/GLUT/Objects.hs view
@@ -0,0 +1,183 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Objects+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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+--    <http://mathworld.wolfram.com/PlatonicSolid.html>.+--+-- * A rhombic dodecahedron, see+--   <http://mathworld.wolfram.com/RhombicDodecahedron.html>.+--+-- * 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+--   <http://mathworld.wolfram.com/Tetrix.html>.++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
+ src/Graphics/UI/GLUT/Overlay.hs view
@@ -0,0 +1,171 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Overlay+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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)
+ src/Graphics/UI/GLUT/QueryUtils.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_HADDOCK hide #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.QueryUtils+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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
+ src/Graphics/UI/GLUT/Raw.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Raw+-- Copyright   :  (c) Sven Panne 2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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
+ src/Graphics/UI/GLUT/Raw/Callbacks.hs view
@@ -0,0 +1,242 @@+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Raw.Callbacks+-- Copyright   :  (c) Sven Panne 2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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)
+ src/Graphics/UI/GLUT/Raw/Fonts.hs view
@@ -0,0 +1,92 @@+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Raw.Fonts+-- Copyright   :  (c) Sven Panne 2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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)
+ src/Graphics/UI/GLUT/Raw/Functions.hs view
@@ -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 <svenpanne@gmail.com>+-- 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"+
+ src/Graphics/UI/GLUT/Raw/Tokens.hs view
@@ -0,0 +1,643 @@+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Raw.Tokens+-- Copyright   :  (c) Sven Panne 2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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
+ src/Graphics/UI/GLUT/State.hs view
@@ -0,0 +1,448 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.State+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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
+ src/Graphics/UI/GLUT/Types.hs view
@@ -0,0 +1,104 @@+{-# OPTIONS_HADDOCK hide #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Types+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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
+ src/Graphics/UI/GLUT/Window.hs view
@@ -0,0 +1,506 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Window+-- Copyright   :  (c) Sven Panne 2002-2018+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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)