GLUT 2.5.0.0 → 2.5.0.1

raw patch · 139 files changed

+17687/−17438 lines, 139 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

GLUT.cabal +197/−185
Graphics/UI/GLUT.hs +386/−386
Graphics/UI/GLUT/Begin.hs +102/−102
Graphics/UI/GLUT/Callbacks.hs +47/−47
Graphics/UI/GLUT/Callbacks/Global.hs +114/−114
Graphics/UI/GLUT/Callbacks/Registration.hs +160/−160
Graphics/UI/GLUT/Callbacks/Window.hs +838/−838
Graphics/UI/GLUT/Colormap.hs +110/−110
Graphics/UI/GLUT/Debugging.hs +37/−37
Graphics/UI/GLUT/DeviceControl.hs +122/−122
Graphics/UI/GLUT/Fonts.hs +183/−183
Graphics/UI/GLUT/GameMode.hs +191/−191
Graphics/UI/GLUT/Initialization.hs +773/−773
Graphics/UI/GLUT/Menu.hs +248/−248
Graphics/UI/GLUT/Objects.hs +337/−337
Graphics/UI/GLUT/Overlay.hs +168/−168
Graphics/UI/GLUT/QueryUtils.hs +35/−35
Graphics/UI/GLUT/Raw.hs +28/−28
Graphics/UI/GLUT/Raw/APIEntry.hs +51/−51
Graphics/UI/GLUT/Raw/Callbacks.hs +201/−201
Graphics/UI/GLUT/Raw/Fonts.hs +29/−29
Graphics/UI/GLUT/Raw/Functions.hs +311/−311
Graphics/UI/GLUT/Raw/Tokens.hs +613/−613
Graphics/UI/GLUT/State.hs +382/−382
Graphics/UI/GLUT/Types.hs +104/−104
Graphics/UI/GLUT/Window.hs +494/−494
README.md +1/−1
cbits/HsGLUT.c +154/−154
examples/00-README +24/−0
examples/BOGLGP/00-README +2/−0
examples/BOGLGP/Chapter01/Makefile +1/−1
examples/BOGLGP/Chapter01/OnYourOwn1.hs +111/−111
examples/BOGLGP/Chapter01/Simple.hs +111/−111
examples/BOGLGP/Chapter02/Makefile +1/−1
examples/BOGLGP/Chapter02/OnYourOwn1.hs +230/−230
examples/BOGLGP/Chapter02/OpenGLApplication.hs +230/−230
examples/BOGLGP/Chapter03/Lines.hs +210/−210
examples/BOGLGP/Chapter03/Makefile +1/−1
examples/BOGLGP/Chapter03/OnYourOwn1.hs +217/−217
examples/BOGLGP/Chapter03/Points.hs +196/−196
examples/BOGLGP/Chapter03/Polygons.hs +230/−230
examples/BOGLGP/Chapter03/TrianglesQuads.hs +294/−294
examples/BOGLGP/Makefile +2/−2
examples/Makefile +2/−2
examples/Misc/00-README +1/−0
examples/Misc/ARBOcclude.hs +193/−193
examples/Misc/ExtractContours.hs +117/−117
examples/Misc/Gears.hs +301/−301
examples/Misc/Makefile +1/−1
examples/Misc/Pitfall14.hs +33/−33
examples/Misc/SmoothOpenGL3.hs +272/−272
examples/Misc/Triangulate.hs +122/−122
examples/OrangeBook/00-README +2/−0
examples/OrangeBook/Makefile +2/−2
examples/OrangeBook/ogl2brick/Brick.hs +370/−370
examples/OrangeBook/ogl2brick/Makefile +1/−1
examples/RedBook4/AAIndex.hs +104/−104
examples/RedBook4/AARGB.hs +104/−104
examples/RedBook4/AccAnti.hs +132/−132
examples/RedBook4/AccPersp.hs +166/−166
examples/RedBook4/Alpha.hs +91/−91
examples/RedBook4/Alpha3D.hs +124/−124
examples/RedBook4/BezCurve.hs +67/−67
examples/RedBook4/BezMesh.hs +84/−84
examples/RedBook4/BezSurf.hs +79/−79
examples/RedBook4/BlendEqn.hs +95/−95
examples/RedBook4/Checker.hs +101/−101
examples/RedBook4/Clip.hs +63/−63
examples/RedBook4/ColorMat.hs +94/−94
examples/RedBook4/ColorMatrix.hs +65/−65
examples/RedBook4/ColorTable.hs +62/−62
examples/RedBook4/Combiner.hs +236/−236
examples/RedBook4/Convolution.hs +83/−83
examples/RedBook4/Cube.hs +56/−56
examples/RedBook4/CubeMap.hs +118/−118
examples/RedBook4/DList.hs +85/−85
examples/RedBook4/DOF.hs +182/−182
examples/RedBook4/Double.hs +76/−76
examples/RedBook4/DrawF.hs +62/−62
examples/RedBook4/Feedback.hs +77/−77
examples/RedBook4/Fog.hs +90/−90
examples/RedBook4/FogCoord.hs +122/−122
examples/RedBook4/FogIndex.hs +76/−76
examples/RedBook4/Font.hs +127/−127
examples/RedBook4/Hello.hs +55/−55
examples/RedBook4/Histogram.hs +85/−85
examples/RedBook4/Image.hs +116/−116
examples/RedBook4/Light.hs +62/−62
examples/RedBook4/Lines.hs +88/−88
examples/RedBook4/MVArray.hs +87/−87
examples/RedBook4/Makefile +4/−4
examples/RedBook4/Material.hs +149/−149
examples/RedBook4/Minmax.hs +64/−64
examples/RedBook4/Mipmap.hs +97/−97
examples/RedBook4/Model.hs +86/−86
examples/RedBook4/MoveLight.hs +85/−85
examples/RedBook4/MultiTex.hs +111/−111
examples/RedBook4/Multisamp.hs +137/−137
examples/RedBook4/PickDepth.hs +126/−126
examples/RedBook4/PickSquare.hs +121/−121
examples/RedBook4/Planet.hs +83/−83
examples/RedBook4/PointP.hs +152/−152
examples/RedBook4/PolyOff.hs +151/−151
examples/RedBook4/Polys.hs +84/−84
examples/RedBook4/Quadric.hs +106/−106
examples/RedBook4/ReadImage.hs +65/−65
examples/RedBook4/Robot.hs +89/−89
examples/RedBook4/Scene.hs +73/−73
examples/RedBook4/Select.hs +150/−150
examples/RedBook4/ShadowMap.hs +255/−255
examples/RedBook4/Smooth.hs +65/−65
examples/RedBook4/Stencil.hs +123/−123
examples/RedBook4/Stroke.hs +127/−127
examples/RedBook4/SurfPoints.hs +129/−129
examples/RedBook4/Surface.hs +112/−112
examples/RedBook4/Teapots.hs +226/−226
examples/RedBook4/Tess.hs +117/−117
examples/RedBook4/TessWind.hs +195/−195
examples/RedBook4/TexBind.hs +108/−108
examples/RedBook4/TexGen.hs +132/−132
examples/RedBook4/TexProx.hs +58/−58
examples/RedBook4/TexSub.hs +120/−120
examples/RedBook4/Texture3D.hs +94/−94
examples/RedBook4/TextureSurf.hs +99/−99
examples/RedBook4/Torus.hs +93/−93
examples/RedBook4/Trim.hs +107/−107
examples/RedBook4/UnProject.hs +54/−54
examples/RedBook4/VArray.hs +141/−141
examples/RedBook4/Wrap.hs +114/−114
examples/RedBook8/00-README +3/−0
examples/RedBook8/Chapter01/Makefile +2/−0
examples/RedBook8/Chapter01/Triangles.hs +88/−0
examples/RedBook8/Chapter01/triangles.frac +8/−0
examples/RedBook8/Chapter01/triangles.vert +9/−0
examples/RedBook8/Makefile +2/−0
examples/RedBook8/common/LoadShaders.hs +94/−0
examples/RedBook8/common/Makefile +2/−0
examples/examples.mk +37/−37
include/HsGLUTExt.h +33/−33

GLUT.cabal view

@@ -1,185 +1,197 @@-name: GLUT
-version: 2.5.0.0
-license: BSD3
-license-file: LICENSE
-maintainer: Sven Panne <svenpanne@gmail.com>, Jason Dagit <dagitj@gmail.com>
-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.md
-   examples/BOGLGP/Chapter01/Makefile
-   examples/BOGLGP/Chapter01/OnYourOwn1.hs
-   examples/BOGLGP/Chapter01/Simple.hs
-   examples/BOGLGP/Chapter02/Makefile
-   examples/BOGLGP/Chapter02/OnYourOwn1.hs
-   examples/BOGLGP/Chapter02/OpenGLApplication.hs
-   examples/BOGLGP/Chapter03/Lines.hs
-   examples/BOGLGP/Chapter03/Makefile
-   examples/BOGLGP/Chapter03/OnYourOwn1.hs
-   examples/BOGLGP/Chapter03/Points.hs
-   examples/BOGLGP/Chapter03/Polygons.hs
-   examples/BOGLGP/Chapter03/TrianglesQuads.hs
-   examples/BOGLGP/Makefile
-   examples/Makefile
-   examples/Misc/ARBOcclude.hs
-   examples/Misc/ExtractContours.hs
-   examples/Misc/Gears.hs
-   examples/Misc/Makefile
-   examples/Misc/Pitfall14.hs
-   examples/Misc/SmoothOpenGL3.hs
-   examples/Misc/Triangulate.hs
-   examples/OrangeBook/3Dlabs-License.txt
-   examples/OrangeBook/Makefile
-   examples/OrangeBook/ogl2brick/Brick.frag
-   examples/OrangeBook/ogl2brick/Brick.hs
-   examples/OrangeBook/ogl2brick/Brick.vert
-   examples/OrangeBook/ogl2brick/Makefile
-   examples/RedBook4/00-README
-   examples/RedBook4/AAIndex.hs
-   examples/RedBook4/AARGB.hs
-   examples/RedBook4/AccAnti.hs
-   examples/RedBook4/AccPersp.hs
-   examples/RedBook4/Alpha.hs
-   examples/RedBook4/Alpha3D.hs
-   examples/RedBook4/BezCurve.hs
-   examples/RedBook4/BezMesh.hs
-   examples/RedBook4/BezSurf.hs
-   examples/RedBook4/BlendEqn.hs
-   examples/RedBook4/Checker.hs
-   examples/RedBook4/Clip.hs
-   examples/RedBook4/ColorMat.hs
-   examples/RedBook4/ColorMatrix.hs
-   examples/RedBook4/ColorTable.hs
-   examples/RedBook4/Combiner.hs
-   examples/RedBook4/Convolution.hs
-   examples/RedBook4/Cube.hs
-   examples/RedBook4/CubeMap.hs
-   examples/RedBook4/DList.hs
-   examples/RedBook4/DOF.hs
-   examples/RedBook4/Data/leeds.bin
-   examples/RedBook4/Double.hs
-   examples/RedBook4/DrawF.hs
-   examples/RedBook4/Feedback.hs
-   examples/RedBook4/Fog.hs
-   examples/RedBook4/FogCoord.hs
-   examples/RedBook4/FogIndex.hs
-   examples/RedBook4/Font.hs
-   examples/RedBook4/Hello.hs
-   examples/RedBook4/Histogram.hs
-   examples/RedBook4/Image.hs
-   examples/RedBook4/Light.hs
-   examples/RedBook4/Lines.hs
-   examples/RedBook4/MVArray.hs
-   examples/RedBook4/Makefile
-   examples/RedBook4/Material.hs
-   examples/RedBook4/Minmax.hs
-   examples/RedBook4/Mipmap.hs
-   examples/RedBook4/Model.hs
-   examples/RedBook4/MoveLight.hs
-   examples/RedBook4/MultiTex.hs
-   examples/RedBook4/Multisamp.hs
-   examples/RedBook4/PickDepth.hs
-   examples/RedBook4/PickSquare.hs
-   examples/RedBook4/Planet.hs
-   examples/RedBook4/PointP.hs
-   examples/RedBook4/PolyOff.hs
-   examples/RedBook4/Polys.hs
-   examples/RedBook4/Quadric.hs
-   examples/RedBook4/ReadImage.hs
-   examples/RedBook4/Robot.hs
-   examples/RedBook4/Scene.hs
-   examples/RedBook4/Select.hs
-   examples/RedBook4/ShadowMap.hs
-   examples/RedBook4/Smooth.hs
-   examples/RedBook4/Stencil.hs
-   examples/RedBook4/Stroke.hs
-   examples/RedBook4/SurfPoints.hs
-   examples/RedBook4/Surface.hs
-   examples/RedBook4/Teapots.hs
-   examples/RedBook4/Tess.hs
-   examples/RedBook4/TessWind.hs
-   examples/RedBook4/TexBind.hs
-   examples/RedBook4/TexGen.hs
-   examples/RedBook4/TexProx.hs
-   examples/RedBook4/TexSub.hs
-   examples/RedBook4/Texture3D.hs
-   examples/RedBook4/TextureSurf.hs
-   examples/RedBook4/Torus.hs
-   examples/RedBook4/Trim.hs
-   examples/RedBook4/UnProject.hs
-   examples/RedBook4/VArray.hs
-   examples/RedBook4/Wrap.hs
-   examples/examples.mk
-   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.6
-   else
-      build-depends: base < 3
-   build-depends: OpenGL >= 2.8.0.0, OpenGLRaw >= 1.3.0.0
-   ghc-options: -Wall -O2
-   if os(windows) && flag(UseNativeWindowsLibraries)
-      if arch(i386)
-         cpp-options: "-DCALLCONV=stdcall"
-      else
-         cpp-options: "-DCALLCONV=ccall"
-      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
+name: GLUT+version: 2.5.0.1+license: BSD3+license-file: LICENSE+maintainer: Sven Panne <svenpanne@gmail.com>, Jason Dagit <dagitj@gmail.com>+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.md+   examples/00-README+   examples/BOGLGP/00-README+   examples/BOGLGP/Chapter01/Makefile+   examples/BOGLGP/Chapter01/OnYourOwn1.hs+   examples/BOGLGP/Chapter01/Simple.hs+   examples/BOGLGP/Chapter02/Makefile+   examples/BOGLGP/Chapter02/OnYourOwn1.hs+   examples/BOGLGP/Chapter02/OpenGLApplication.hs+   examples/BOGLGP/Chapter03/Lines.hs+   examples/BOGLGP/Chapter03/Makefile+   examples/BOGLGP/Chapter03/OnYourOwn1.hs+   examples/BOGLGP/Chapter03/Points.hs+   examples/BOGLGP/Chapter03/Polygons.hs+   examples/BOGLGP/Chapter03/TrianglesQuads.hs+   examples/BOGLGP/Makefile+   examples/Makefile+   examples/Misc/00-README+   examples/Misc/ARBOcclude.hs+   examples/Misc/ExtractContours.hs+   examples/Misc/Gears.hs+   examples/Misc/Makefile+   examples/Misc/Pitfall14.hs+   examples/Misc/SmoothOpenGL3.hs+   examples/Misc/Triangulate.hs+   examples/OrangeBook/00-README+   examples/OrangeBook/3Dlabs-License.txt+   examples/OrangeBook/Makefile+   examples/OrangeBook/ogl2brick/Brick.frag+   examples/OrangeBook/ogl2brick/Brick.hs+   examples/OrangeBook/ogl2brick/Brick.vert+   examples/OrangeBook/ogl2brick/Makefile+   examples/RedBook4/00-README+   examples/RedBook4/AAIndex.hs+   examples/RedBook4/AARGB.hs+   examples/RedBook4/AccAnti.hs+   examples/RedBook4/AccPersp.hs+   examples/RedBook4/Alpha.hs+   examples/RedBook4/Alpha3D.hs+   examples/RedBook4/BezCurve.hs+   examples/RedBook4/BezMesh.hs+   examples/RedBook4/BezSurf.hs+   examples/RedBook4/BlendEqn.hs+   examples/RedBook4/Checker.hs+   examples/RedBook4/Clip.hs+   examples/RedBook4/ColorMat.hs+   examples/RedBook4/ColorMatrix.hs+   examples/RedBook4/ColorTable.hs+   examples/RedBook4/Combiner.hs+   examples/RedBook4/Convolution.hs+   examples/RedBook4/Cube.hs+   examples/RedBook4/CubeMap.hs+   examples/RedBook4/DList.hs+   examples/RedBook4/DOF.hs+   examples/RedBook4/Data/leeds.bin+   examples/RedBook4/Double.hs+   examples/RedBook4/DrawF.hs+   examples/RedBook4/Feedback.hs+   examples/RedBook4/Fog.hs+   examples/RedBook4/FogCoord.hs+   examples/RedBook4/FogIndex.hs+   examples/RedBook4/Font.hs+   examples/RedBook4/Hello.hs+   examples/RedBook4/Histogram.hs+   examples/RedBook4/Image.hs+   examples/RedBook4/Light.hs+   examples/RedBook4/Lines.hs+   examples/RedBook4/MVArray.hs+   examples/RedBook4/Makefile+   examples/RedBook4/Material.hs+   examples/RedBook4/Minmax.hs+   examples/RedBook4/Mipmap.hs+   examples/RedBook4/Model.hs+   examples/RedBook4/MoveLight.hs+   examples/RedBook4/MultiTex.hs+   examples/RedBook4/Multisamp.hs+   examples/RedBook4/PickDepth.hs+   examples/RedBook4/PickSquare.hs+   examples/RedBook4/Planet.hs+   examples/RedBook4/PointP.hs+   examples/RedBook4/PolyOff.hs+   examples/RedBook4/Polys.hs+   examples/RedBook4/Quadric.hs+   examples/RedBook4/ReadImage.hs+   examples/RedBook4/Robot.hs+   examples/RedBook4/Scene.hs+   examples/RedBook4/Select.hs+   examples/RedBook4/ShadowMap.hs+   examples/RedBook4/Smooth.hs+   examples/RedBook4/Stencil.hs+   examples/RedBook4/Stroke.hs+   examples/RedBook4/SurfPoints.hs+   examples/RedBook4/Surface.hs+   examples/RedBook4/Teapots.hs+   examples/RedBook4/Tess.hs+   examples/RedBook4/TessWind.hs+   examples/RedBook4/TexBind.hs+   examples/RedBook4/TexGen.hs+   examples/RedBook4/TexProx.hs+   examples/RedBook4/TexSub.hs+   examples/RedBook4/Texture3D.hs+   examples/RedBook4/TextureSurf.hs+   examples/RedBook4/Torus.hs+   examples/RedBook4/Trim.hs+   examples/RedBook4/UnProject.hs+   examples/RedBook4/VArray.hs+   examples/RedBook4/Wrap.hs+   examples/RedBook8/00-README+   examples/RedBook8/Chapter01/Makefile+   examples/RedBook8/Chapter01/triangles.frac+   examples/RedBook8/Chapter01/Triangles.hs+   examples/RedBook8/Chapter01/triangles.vert+   examples/RedBook8/common/LoadShaders.hs+   examples/RedBook8/common/Makefile+   examples/RedBook8/Makefile+   examples/examples.mk+   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.6+   else+      build-depends: base < 3+   build-depends: OpenGL >= 2.8.0.0, OpenGLRaw >= 1.3.0.0+   ghc-options: -Wall -O2+   if os(windows) && flag(UseNativeWindowsLibraries)+      if arch(i386)+         cpp-options: "-DCALLCONV=stdcall"+      else+         cpp-options: "-DCALLCONV=ccall"+      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

Graphics/UI/GLUT.hs view

@@ -1,386 +1,386 @@------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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.
+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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.

Graphics/UI/GLUT/Begin.hs view

@@ -1,102 +1,102 @@---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Begin
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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 Foreign.C.Types
-import Graphics.Rendering.OpenGL.GL.StateVar
-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.
-     ContinueExecution
-   | ContinueExectuion
-   deriving ( Eq, Ord, Show )
-
-{-# DEPRECATED ContinueExectuion "Use 'ContinueExecution' instead." #-}
-
-marshalActionOnWindowClose :: ActionOnWindowClose -> CInt
-marshalActionOnWindowClose x = case x of
-   Exit ->  glut_ACTION_EXIT
-   MainLoopReturns -> glut_ACTION_GLUTMAINLOOP_RETURNS
-   ContinueExecution -> glut_ACTION_CONTINUE_EXECUTION
-   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 = 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)
+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Begin+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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 Foreign.C.Types+import Graphics.Rendering.OpenGL.GL.StateVar+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.+     ContinueExecution+   | ContinueExectuion+   deriving ( Eq, Ord, Show )++{-# DEPRECATED ContinueExectuion "Use 'ContinueExecution' instead." #-}++marshalActionOnWindowClose :: ActionOnWindowClose -> CInt+marshalActionOnWindowClose x = case x of+   Exit ->  glut_ACTION_EXIT+   MainLoopReturns -> glut_ACTION_GLUTMAINLOOP_RETURNS+   ContinueExecution -> glut_ACTION_CONTINUE_EXECUTION+   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 = 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)

Graphics/UI/GLUT/Callbacks.hs view

@@ -1,47 +1,47 @@---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Callbacks
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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
+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Callbacks+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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

Graphics/UI/GLUT/Callbacks/Global.hs view

@@ -1,114 +1,114 @@---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Callbacks.Global
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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
-import Foreign.C.Types
-import Graphics.Rendering.OpenGL ( Position(..)
-                                 , SettableStateVar
-                                 , makeSettableStateVar )
-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
+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Callbacks.Global+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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+import Foreign.C.Types+import Graphics.Rendering.OpenGL ( Position(..)+                                 , SettableStateVar+                                 , makeSettableStateVar )+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 view

@@ -1,160 +1,160 @@-{-# OPTIONS_GHC -fno-cse #-}
-
-{-# OPTIONS_HADDOCK hide #-}
---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Callbacks.Registration
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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
-import Data.IORef
-import qualified Data.Map as Map ( empty, lookup, insert, delete )
-import Data.Map ( Map )
-import Foreign.Ptr
-import Graphics.Rendering.OpenGL ( get )
-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
+{-# OPTIONS_GHC -fno-cse #-}++{-# OPTIONS_HADDOCK hide #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Callbacks.Registration+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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+import Data.IORef+import qualified Data.Map as Map ( empty, lookup, insert, delete )+import Data.Map ( Map )+import Foreign.Ptr+import Graphics.Rendering.OpenGL ( get )+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 view

@@ -1,838 +1,838 @@---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Callbacks.Window
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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,
-
-   -- * Callbacks for visibility changes
-   Visibility(..), VisibilityCallback, visibilityCallback,
-   WindowState(..), WindowStateCallback, windowStateCallback,
-
-   -- * Window close callback
-   CloseCallback, closeCallback,
-
-   -- * 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
-) where
-
-import Data.Bits hiding ( shift )
-import Data.Char
-import Data.Maybe
-import Foreign.C.Types
-import Graphics.Rendering.OpenGL ( Position(..), Size(..)
-                                 , SettableStateVar, makeSettableStateVar )
-import Graphics.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
-
---------------------------------------------------------------------------------
-
--- | 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
-   | 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)
-
---------------------------------------------------------------------------------
-
--- | 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))
+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Callbacks.Window+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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,++   -- * Callbacks for visibility changes+   Visibility(..), VisibilityCallback, visibilityCallback,+   WindowState(..), WindowStateCallback, windowStateCallback,++   -- * Window close callback+   CloseCallback, closeCallback,++   -- * 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+) where++import Data.Bits hiding ( shift )+import Data.Char+import Data.Maybe+import Foreign.C.Types+import Graphics.Rendering.OpenGL ( Position(..), Size(..)+                                 , SettableStateVar, makeSettableStateVar )+import Graphics.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++--------------------------------------------------------------------------------++-- | 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+   | 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)++--------------------------------------------------------------------------------++-- | 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))

Graphics/UI/GLUT/Colormap.hs view

@@ -1,110 +1,110 @@---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Colormap
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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 Foreign.C.Types
-import Graphics.Rendering.OpenGL ( GLfloat, GLint, Color3(..), Index1(..)
-                                 , StateVar, makeStateVar, GettableStateVar
-                                 , makeGettableStateVar )
-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
+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Colormap+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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 Foreign.C.Types+import Graphics.Rendering.OpenGL ( GLfloat, GLint, Color3(..), Index1(..)+                                 , StateVar, makeStateVar, GettableStateVar+                                 , makeGettableStateVar )+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 view

@@ -1,37 +1,37 @@---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Debugging
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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 Graphics.Rendering.OpenGL ( Error(..), errors, get )
-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)
+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Debugging+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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 Graphics.Rendering.OpenGL ( Error(..), errors, get )+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 view

@@ -1,122 +1,122 @@---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.DeviceControl
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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 Foreign.C.Types
-import Graphics.Rendering.OpenGL ( StateVar, makeStateVar )
-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
+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.DeviceControl+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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 Foreign.C.Types+import Graphics.Rendering.OpenGL ( StateVar, makeStateVar )+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 view

@@ -1,183 +1,183 @@---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Fonts
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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 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
+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Fonts+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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 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 view

@@ -1,191 +1,191 @@---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.GameMode
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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 Data.List
-import Foreign.C.String
-import Graphics.Rendering.OpenGL ( GLenum, Size(..)
-                                 , GettableStateVar
-                                 , SettableStateVar
-                                 , makeGettableStateVar
-                                 , makeSettableStateVar )
-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
+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.GameMode+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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 Data.List+import Foreign.C.String+import Graphics.Rendering.OpenGL ( GLenum, Size(..)+                                 , GettableStateVar+                                 , SettableStateVar+                                 , makeGettableStateVar+                                 , makeSettableStateVar )+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 view

@@ -1,773 +1,773 @@---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Initialization
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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
-import Data.Bits
-import Data.List
-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(..)
-                                 , StateVar, GettableStateVar, get
-                                 , SettableStateVar, makeStateVar, ($=)
-                                 , makeGettableStateVar
-                                 , makeSettableStateVar )
-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 @'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"
-   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
+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Initialization+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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+import Data.Bits+import Data.List+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(..)+                                 , StateVar, GettableStateVar, get+                                 , SettableStateVar, makeStateVar, ($=)+                                 , makeGettableStateVar+                                 , makeSettableStateVar )+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 @'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"+   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

@@ -1,248 +1,248 @@-{-# OPTIONS_GHC -fno-cse #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Menu
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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 Data.Array
-import Data.IORef
-import qualified Data.Map as Map ( empty, lookup, insert, delete )
-import Control.Monad
-import Data.Map ( Map )
-import Foreign.C.String
-import Foreign.C.Types
-import Foreign.Ptr
-import Graphics.Rendering.OpenGL ( get, ($=), StateVar
-                                 , makeStateVar, GettableStateVar
-                                 , makeGettableStateVar )
-import Graphics.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.
-
-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
+{-# OPTIONS_GHC -fno-cse #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Menu+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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 Data.Array+import Data.IORef+import qualified Data.Map as Map ( empty, lookup, insert, delete )+import Control.Monad+import Data.Map ( Map )+import Foreign.C.String+import Foreign.C.Types+import Foreign.Ptr+import Graphics.Rendering.OpenGL ( get, ($=), StateVar+                                 , makeStateVar, GettableStateVar+                                 , makeGettableStateVar )+import Graphics.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.++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 view

@@ -1,337 +1,337 @@---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Objects
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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 teapot).
---
---------------------------------------------------------------------------------
-
-module Graphics.UI.GLUT.Objects (
-   -- * Rendering flavour
-   Flavour(..),
-
-   -- * Object description
-   Object(..),
-
-   -- * Type synonyms
-   Sides, Rings, NumLevels,
-
-   -- * Rendering
-   renderObject
-) where
-
-import Foreign.C.Types
-import Foreign.Marshal.Utils
-import Foreign.Ptr
-import Graphics.Rendering.OpenGL ( Height, Radius, Slices, Stacks, GLint, GLdouble, Vertex3(..) )
-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
+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Objects+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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 teapot).+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.Objects (+   -- * Rendering flavour+   Flavour(..),++   -- * Object description+   Object(..),++   -- * Type synonyms+   Sides, Rings, NumLevels,++   -- * Rendering+   renderObject+) where++import Foreign.C.Types+import Foreign.Marshal.Utils+import Foreign.Ptr+import Graphics.Rendering.OpenGL ( Height, Radius, Slices, Stacks, GLint, GLdouble, Vertex3(..) )+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 view

@@ -1,168 +1,168 @@---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Overlay
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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 Graphics.Rendering.OpenGL ( GLenum, StateVar, makeStateVar
-                                 , GettableStateVar, makeGettableStateVar
-                                 , SettableStateVar, makeSettableStateVar )
-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 :: Maybe Window -> IO ()
-postOverlayRedisplay =
-   maybe glutPostOverlayRedisplay (\(Window win) -> glutPostWindowOverlayRedisplay win)
+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Overlay+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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 Graphics.Rendering.OpenGL ( GLenum, StateVar, makeStateVar+                                 , GettableStateVar, makeGettableStateVar+                                 , SettableStateVar, makeSettableStateVar )+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 :: Maybe Window -> IO ()+postOverlayRedisplay =+   maybe glutPostOverlayRedisplay (\(Window win) -> glutPostWindowOverlayRedisplay win)

Graphics/UI/GLUT/QueryUtils.hs view

@@ -1,35 +1,35 @@-{-# OPTIONS_HADDOCK hide #-}
---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.QueryUtils
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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
-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
+{-# OPTIONS_HADDOCK hide #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.QueryUtils+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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+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 view

@@ -1,28 +1,28 @@-{-# OPTIONS_HADDOCK hide #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Raw
--- Copyright   :  (c) Sven Panne 2013
--- 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.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
+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Raw+-- Copyright   :  (c) Sven Panne 2013+-- 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.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 view

@@ -1,51 +1,51 @@-{-# LANGUAGE ForeignFunctionInterface, CPP #-}
-{-# OPTIONS_HADDOCK hide #-}
---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Raw.APIEntry
--- Copyright   :  (c) Sven Panne 2002-2013
--- License     :  BSD3
---
--- Maintainer  :  Sven Panne <svenpanne@gmail.com>
--- Stability   :  stable
--- 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)
+{-# LANGUAGE ForeignFunctionInterface, CPP #-}+{-# OPTIONS_HADDOCK hide #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Raw.APIEntry+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- 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 view

@@ -1,201 +1,201 @@-{-# LANGUAGE ForeignFunctionInterface #-}
-{-# OPTIONS_HADDOCK hide #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Raw.Callbacks
--- Copyright   :  (c) Sven Panne 2013
--- License     :  BSD3
---
--- Maintainer  :  Sven Panne <svenpanne@gmail.com>
--- 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)
+{-# LANGUAGE ForeignFunctionInterface #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Raw.Callbacks+-- Copyright   :  (c) Sven Panne 2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- 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 view

@@ -1,29 +1,29 @@-{-# LANGUAGE ForeignFunctionInterface #-}
-{-# OPTIONS_HADDOCK hide #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Raw.Fonts
--- Copyright   :  (c) Sven Panne 2013
--- 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 (
-   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)
+{-# LANGUAGE ForeignFunctionInterface #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Raw.Fonts+-- Copyright   :  (c) Sven Panne 2013+-- 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 (+   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 view

@@ -1,311 +1,311 @@-{-# LANGUAGE ForeignFunctionInterface, CPP #-}
-{-# OPTIONS_HADDOCK hide #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Raw.Functions
--- Copyright   :  (c) Sven Panne 2013
--- 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 (
-   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.Types
-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))
+{-# LANGUAGE ForeignFunctionInterface, CPP #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Raw.Functions+-- Copyright   :  (c) Sven Panne 2013+-- 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 (+   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.Types+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 view

@@ -1,613 +1,613 @@-{-# OPTIONS_HADDOCK hide #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Raw.Tokens
--- Copyright   :  (c) Sven Panne 2013
--- 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
-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
+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Raw.Tokens+-- Copyright   :  (c) Sven Panne 2013+-- 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+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 view

@@ -1,382 +1,382 @@---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.State
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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,
-
-   -- * 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 Foreign.C.Types
-import Foreign.Marshal.Alloc
-import Foreign.Marshal.Array
-import Foreign.Ptr
-import Foreign.Storable
-import Graphics.Rendering.OpenGL ( GLenum, Size(..)
-                                 , StateVar, makeStateVar
-                                 , GettableStateVar, makeGettableStateVar )
-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
+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.State+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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,++   -- * 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 Foreign.C.Types+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable+import Graphics.Rendering.OpenGL ( GLenum, Size(..)+                                 , StateVar, makeStateVar+                                 , GettableStateVar, makeGettableStateVar )+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 view

@@ -1,104 +1,104 @@-{-# OPTIONS_HADDOCK hide #-}
---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Types
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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
+{-# OPTIONS_HADDOCK hide #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Types+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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

Graphics/UI/GLUT/Window.hs view

@@ -1,494 +1,494 @@---------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.GLUT.Window
--- Copyright   :  (c) Sven Panne 2002-2013
--- 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,
-
-   -- * 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 Foreign.C.String
-import Foreign.C.Types
-import Graphics.Rendering.OpenGL ( Position(..), Size(..)
-                                 , StateVar, makeStateVar
-                                 , GettableStateVar, makeGettableStateVar
-                                 , SettableStateVar, makeSettableStateVar )
-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)
+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Window+-- Copyright   :  (c) Sven Panne 2002-2013+-- 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,++   -- * 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 Foreign.C.String+import Foreign.C.Types+import Graphics.Rendering.OpenGL ( Position(..), Size(..)+                                 , StateVar, makeStateVar+                                 , GettableStateVar, makeGettableStateVar+                                 , SettableStateVar, makeSettableStateVar )+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)

README.md view

@@ -1,1 +1,1 @@-[![Build Status](https://travis-ci.org/haskell-opengl/GLUT.png)](https://travis-ci.org/haskell-opengl/GLUT)
+[![Build Status](https://travis-ci.org/haskell-opengl/GLUT.png)](https://travis-ci.org/haskell-opengl/GLUT)

cbits/HsGLUT.c view

@@ -1,154 +1,154 @@-/* -----------------------------------------------------------------------------
- *
- * Module      :  C support for Graphics.UI.GLUT.Raw
- * Copyright   :  (c) Sven Panne 2002-2013
- * License     :  BSD3
- *
- * 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>
-
-void*
-hs_GLUT_getProcAddress(const char *name)
-{
-  static int firstTime = 1;
-  static HMODULE handle = NULL;
-
-  if (firstTime) {
-    firstTime = 0;
-    handle = LoadLibrary(TEXT("glut32"));
-  }
-
-  return handle ? GetProcAddress(handle, name) : NULL;
-}
-
-/* -------------------------------------------------------------------------- */
-#elif defined(USE_NSADDRESSOFSYMBOL)
-
-#include <mach-o/dyld.h>
-#include <stdlib.h>
-#include <string.h>
-
-void*
-hs_GLUT_getProcAddress(const char *name)
-{
-  NSSymbol symbol;
-
-  /* Prepend a '_' for the Unix C symbol mangling convention */
-  char* symbolName = (char*)malloc(strlen(name) + 2);
-  if (!symbolName) {
-    return NULL;
-  }
-  symbolName[0] = '_';
-  strcpy(symbolName + 1, name);
-
-  if (!NSIsSymbolNameDefined(symbolName)) {
-    free(symbolName);
-    return NULL;
-  }
-
-  symbol = NSLookupAndBindSymbol(symbolName);
-  free(symbolName);
-  if (!symbol) {
-    return NULL;
-  }
-
-  return NSAddressOfSymbol(symbol);
-}
-
-/* -------------------------------------------------------------------------- */
-#elif defined(USE_DLSYM)
-
-#include <stdlib.h>
-#include <dlfcn.h>
-
-void*
-hs_GLUT_getProcAddress(const char *name)
-{
-  static int firstTime = 1;
-  static void *handle = NULL;
-
-  if (firstTime) {
-    firstTime = 0;
-    /* Get a handle for our executable. */
-    handle = dlopen(NULL, RTLD_LAZY);
-  }
-
-  return handle ? dlsym(handle, name) : NULL;
-}
-
-/* -------------------------------------------------------------------------- */
-#else
-
-#error "Don't know how to retrieve GLUT entries"
-
-#endif
+/* -----------------------------------------------------------------------------+ *+ * Module      :  C support for Graphics.UI.GLUT.Raw+ * Copyright   :  (c) Sven Panne 2002-2013+ * License     :  BSD3+ *+ * 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>++void*+hs_GLUT_getProcAddress(const char *name)+{+  static int firstTime = 1;+  static HMODULE handle = NULL;++  if (firstTime) {+    firstTime = 0;+    handle = LoadLibrary(TEXT("glut32"));+  }++  return handle ? GetProcAddress(handle, name) : NULL;+}++/* -------------------------------------------------------------------------- */+#elif defined(USE_NSADDRESSOFSYMBOL)++#include <mach-o/dyld.h>+#include <stdlib.h>+#include <string.h>++void*+hs_GLUT_getProcAddress(const char *name)+{+  NSSymbol symbol;++  /* Prepend a '_' for the Unix C symbol mangling convention */+  char* symbolName = (char*)malloc(strlen(name) + 2);+  if (!symbolName) {+    return NULL;+  }+  symbolName[0] = '_';+  strcpy(symbolName + 1, name);++  if (!NSIsSymbolNameDefined(symbolName)) {+    free(symbolName);+    return NULL;+  }++  symbol = NSLookupAndBindSymbol(symbolName);+  free(symbolName);+  if (!symbol) {+    return NULL;+  }++  return NSAddressOfSymbol(symbol);+}++/* -------------------------------------------------------------------------- */+#elif defined(USE_DLSYM)++#include <stdlib.h>+#include <dlfcn.h>++void*+hs_GLUT_getProcAddress(const char *name)+{+  static int firstTime = 1;+  static void *handle = NULL;++  if (firstTime) {+    firstTime = 0;+    /* Get a handle for our executable. */+    handle = dlopen(NULL, RTLD_LAZY);+  }++  return handle ? dlsym(handle, name) : NULL;+}++/* -------------------------------------------------------------------------- */+#else++#error "Don't know how to retrieve GLUT entries"++#endif

+ 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/Makefile view

@@ -1,1 +1,1 @@-include ../../examples.mk
+include ../../examples.mk

examples/BOGLGP/Chapter01/OnYourOwn1.hs view

@@ -1,111 +1,111 @@-{-
-   OnYourOwn1.hs (adapted from Simple.cpp which is (c) 2004 Astle/Hawkins)
-   Copyright (c) Sven Panne 2004-2005 <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 System.Exit ( exitWith, ExitCode(ExitSuccess) )
-import Graphics.UI.GLUT hiding ( initialize )
-
---------------------------------------------------------------------------------
--- Setup GLUT and OpenGL, drop into the event loop.
---------------------------------------------------------------------------------
-main :: IO ()
-main = do
-   -- Setup the basic GLUT stuff
-   _ <- getArgsAndInitialize
-   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]
-
-   -- Create the window
-   initialWindowSize $= Size 1024 768
-   initialWindowPosition $= Position 100 150
-   _ <- createWindow "BOGLGP - Chapter 1 - On Your Own 1"
-
-   initialize
-
-   -- Register the event callback functions
-   displayCallback $= display
-   reshapeCallback $= Just reshape
-   keyboardMouseCallback $= Just keyboardMouseHandler
-   -- No need for an idle callback here, this would just hog the CPU
-   -- without any visible effect
-
-   -- At this point, control is relinquished to the GLUT event handler.
-   -- Control is returned as events occur, via the callback functions.
-   mainLoop
-
---------------------------------------------------------------------------------
--- One time setup, including creating menus, creating a light, setting the
--- shading mode and clear color, and loading textures.
---------------------------------------------------------------------------------
-initialize :: IO ()
-initialize = do
-   -- set up the only meny
-   attachMenu RightButton (Menu [MenuEntry "Exit" (exitWith ExitSuccess)])
-
-   depthFunc $= Just Less
-
---------------------------------------------------------------------------------
--- Handle mouse and keyboard events. For this simple demo, just exit on a
--- left click or when q is pressed.
---------------------------------------------------------------------------------
-keyboardMouseHandler :: KeyboardMouseCallback
-keyboardMouseHandler (MouseButton LeftButton)_ _ _ = exitWith ExitSuccess
-keyboardMouseHandler (Char 'q')              _ _ _ = exitWith ExitSuccess
-keyboardMouseHandler _                       _ _ _ = postRedisplay Nothing
-
---------------------------------------------------------------------------------
--- Reset the viewport for window changes.
---------------------------------------------------------------------------------
-reshape :: ReshapeCallback
-reshape size@(Size width height) =
-   unless (height == 0) $ do
-      viewport $= (Position 0 0, size)
-      matrixMode $= Projection
-      loadIdentity
-      perspective 90 (fromIntegral width / fromIntegral height) 1 100
-
-      matrixMode $= Modelview 0
-
---------------------------------------------------------------------------------
--- Clear and redraw the scene.
---------------------------------------------------------------------------------
-display :: DisplayCallback
-display = do
-   -- set up the camera
-   loadIdentity
-   lookAt (Vertex3 0 1 6) (Vertex3 0 0 0) (Vector3 0 1 0)
-
-   -- clear the screen
-   clear [ ColorBuffer, DepthBuffer ]
-
-   -- resolve overloading, not needed in "real" programs
-   let color3f = color :: Color3 GLfloat -> IO ()
-       vertex3f = vertex :: Vertex3 GLfloat -> IO ()
-
-   -- draw a triangle
-   renderPrimitive Triangles $ do
-      color3f (Color3 1 0 0)
-      vertex3f (Vertex3 2 2.5 (-1))
-      color3f (Color3 1 0 0)
-      vertex3f (Vertex3 (-3.5) (-2.5) (-1))
-      color3f (Color3 1 0 0)
-      vertex3f (Vertex3 2 (-4) 0)
-
-   -- draw a polygon
-   renderPrimitive Polygon $ do
-      color3f (Color3 0 0 1)
-      vertex3f (Vertex3 (-1) 2 0)
-      color3f (Color3 0 0 1)
-      vertex3f (Vertex3 (-3) (-0.5) 0)
-      color3f (Color3 0 0 1)
-      vertex3f (Vertex3 (-1.5) (-3) 0)
-      color3f (Color3 0 0 1)
-      vertex3f (Vertex3 1 (-2) 0)
-      color3f (Color3 0 0 1)
-      vertex3f (Vertex3 1 1 0)
-
-   -- draw everything and swap the display buffer
-   swapBuffers
+{-+   OnYourOwn1.hs (adapted from Simple.cpp which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2004-2005 <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 System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT hiding ( initialize )++--------------------------------------------------------------------------------+-- Setup GLUT and OpenGL, drop into the event loop.+--------------------------------------------------------------------------------+main :: IO ()+main = do+   -- Setup the basic GLUT stuff+   _ <- getArgsAndInitialize+   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]++   -- Create the window+   initialWindowSize $= Size 1024 768+   initialWindowPosition $= Position 100 150+   _ <- createWindow "BOGLGP - Chapter 1 - On Your Own 1"++   initialize++   -- Register the event callback functions+   displayCallback $= display+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboardMouseHandler+   -- No need for an idle callback here, this would just hog the CPU+   -- without any visible effect++   -- At this point, control is relinquished to the GLUT event handler.+   -- Control is returned as events occur, via the callback functions.+   mainLoop++--------------------------------------------------------------------------------+-- One time setup, including creating menus, creating a light, setting the+-- shading mode and clear color, and loading textures.+--------------------------------------------------------------------------------+initialize :: IO ()+initialize = do+   -- set up the only meny+   attachMenu RightButton (Menu [MenuEntry "Exit" (exitWith ExitSuccess)])++   depthFunc $= Just Less++--------------------------------------------------------------------------------+-- Handle mouse and keyboard events. For this simple demo, just exit on a+-- left click or when q is pressed.+--------------------------------------------------------------------------------+keyboardMouseHandler :: KeyboardMouseCallback+keyboardMouseHandler (MouseButton LeftButton)_ _ _ = exitWith ExitSuccess+keyboardMouseHandler (Char 'q')              _ _ _ = exitWith ExitSuccess+keyboardMouseHandler _                       _ _ _ = postRedisplay Nothing++--------------------------------------------------------------------------------+-- Reset the viewport for window changes.+--------------------------------------------------------------------------------+reshape :: ReshapeCallback+reshape size@(Size width height) =+   unless (height == 0) $ do+      viewport $= (Position 0 0, size)+      matrixMode $= Projection+      loadIdentity+      perspective 90 (fromIntegral width / fromIntegral height) 1 100++      matrixMode $= Modelview 0++--------------------------------------------------------------------------------+-- Clear and redraw the scene.+--------------------------------------------------------------------------------+display :: DisplayCallback+display = do+   -- set up the camera+   loadIdentity+   lookAt (Vertex3 0 1 6) (Vertex3 0 0 0) (Vector3 0 1 0)++   -- clear the screen+   clear [ ColorBuffer, DepthBuffer ]++   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+       vertex3f = vertex :: Vertex3 GLfloat -> IO ()++   -- draw a triangle+   renderPrimitive Triangles $ do+      color3f (Color3 1 0 0)+      vertex3f (Vertex3 2 2.5 (-1))+      color3f (Color3 1 0 0)+      vertex3f (Vertex3 (-3.5) (-2.5) (-1))+      color3f (Color3 1 0 0)+      vertex3f (Vertex3 2 (-4) 0)++   -- draw a polygon+   renderPrimitive Polygon $ do+      color3f (Color3 0 0 1)+      vertex3f (Vertex3 (-1) 2 0)+      color3f (Color3 0 0 1)+      vertex3f (Vertex3 (-3) (-0.5) 0)+      color3f (Color3 0 0 1)+      vertex3f (Vertex3 (-1.5) (-3) 0)+      color3f (Color3 0 0 1)+      vertex3f (Vertex3 1 (-2) 0)+      color3f (Color3 0 0 1)+      vertex3f (Vertex3 1 1 0)++   -- draw everything and swap the display buffer+   swapBuffers

examples/BOGLGP/Chapter01/Simple.hs view

@@ -1,111 +1,111 @@-{-
-   Simple.hs (adapted from Simple.cpp which is (c) 2004 Astle/Hawkins)
-   Copyright (c) Sven Panne 2004-2005 <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 System.Exit ( exitWith, ExitCode(ExitSuccess) )
-import Graphics.UI.GLUT hiding ( initialize )
-
---------------------------------------------------------------------------------
--- Setup GLUT and OpenGL, drop into the event loop.
---------------------------------------------------------------------------------
-main :: IO ()
-main = do
-   -- Setup the basic GLUT stuff
-   _ <- getArgsAndInitialize
-   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]
-
-   -- Create the window
-   initialWindowSize $= Size 1024 768
-   initialWindowPosition $= Position 100 150
-   _ <- createWindow "BOGLGP - Chapter 1 - Simple"
-
-   initialize
-
-   -- Register the event callback functions
-   displayCallback $= display
-   reshapeCallback $= Just reshape
-   keyboardMouseCallback $= Just keyboardMouseHandler
-   -- No need for an idle callback here, this would just hog the CPU
-   -- without any visible effect
-
-   -- At this point, control is relinquished to the GLUT event handler.
-   -- Control is returned as events occur, via the callback functions.
-   mainLoop
-
---------------------------------------------------------------------------------
--- One time setup, including creating menus, creating a light, setting the
--- shading mode and clear color, and loading textures.
---------------------------------------------------------------------------------
-initialize :: IO ()
-initialize = do
-   -- set up the only meny
-   attachMenu RightButton (Menu [MenuEntry "Exit" (exitWith ExitSuccess)])
-
-   depthFunc $= Just Less
-
---------------------------------------------------------------------------------
--- Handle mouse and keyboard events. For this simple demo, just exit on a
--- left click or when q is pressed.
---------------------------------------------------------------------------------
-keyboardMouseHandler :: KeyboardMouseCallback
-keyboardMouseHandler (MouseButton LeftButton)_ _ _ = exitWith ExitSuccess
-keyboardMouseHandler (Char 'q')              _ _ _ = exitWith ExitSuccess
-keyboardMouseHandler _                       _ _ _ = postRedisplay Nothing
-
---------------------------------------------------------------------------------
--- Reset the viewport for window changes.
---------------------------------------------------------------------------------
-reshape :: ReshapeCallback
-reshape size@(Size width height) =
-   unless (height == 0) $ do
-      viewport $= (Position 0 0, size)
-      matrixMode $= Projection
-      loadIdentity
-      perspective 90 (fromIntegral width / fromIntegral height) 1 100
-
-      matrixMode $= Modelview 0
-
---------------------------------------------------------------------------------
--- Clear and redraw the scene.
---------------------------------------------------------------------------------
-display :: DisplayCallback
-display = do
-   -- set up the camera
-   loadIdentity
-   lookAt (Vertex3 0 1 6) (Vertex3 0 0 0) (Vector3 0 1 0)
-
-   -- clear the screen
-   clear [ ColorBuffer, DepthBuffer ]
-
-   -- resolve overloading, not needed in "real" programs
-   let color3f = color :: Color3 GLfloat -> IO ()
-       vertex3f = vertex :: Vertex3 GLfloat -> IO ()
-
-   -- draw a triangle
-   renderPrimitive Triangles $ do
-      color3f (Color3 1 0 0)
-      vertex3f (Vertex3 2 2.5 (-1))
-      color3f (Color3 0 1 0)
-      vertex3f (Vertex3 (-3.5) (-2.5) (-1))
-      color3f (Color3 0 0 1)
-      vertex3f (Vertex3 2 (-4) 0)
-
-   -- draw a polygon
-   renderPrimitive Polygon $ do
-      color3f (Color3 1 1 1)
-      vertex3f (Vertex3 (-1) 2 0)
-      color3f (Color3 1 1 0)
-      vertex3f (Vertex3 (-3) (-0.5) 0)
-      color3f (Color3 0 1 1)
-      vertex3f (Vertex3 (-1.5) (-3) 0)
-      color3f (Color3 0 0 0)
-      vertex3f (Vertex3 1 (-2) 0)
-      color3f (Color3 1 0 1)
-      vertex3f (Vertex3 1 1 0)
-
-   -- draw everything and swap the display buffer
-   swapBuffers
+{-+   Simple.hs (adapted from Simple.cpp which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2004-2005 <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 System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT hiding ( initialize )++--------------------------------------------------------------------------------+-- Setup GLUT and OpenGL, drop into the event loop.+--------------------------------------------------------------------------------+main :: IO ()+main = do+   -- Setup the basic GLUT stuff+   _ <- getArgsAndInitialize+   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]++   -- Create the window+   initialWindowSize $= Size 1024 768+   initialWindowPosition $= Position 100 150+   _ <- createWindow "BOGLGP - Chapter 1 - Simple"++   initialize++   -- Register the event callback functions+   displayCallback $= display+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboardMouseHandler+   -- No need for an idle callback here, this would just hog the CPU+   -- without any visible effect++   -- At this point, control is relinquished to the GLUT event handler.+   -- Control is returned as events occur, via the callback functions.+   mainLoop++--------------------------------------------------------------------------------+-- One time setup, including creating menus, creating a light, setting the+-- shading mode and clear color, and loading textures.+--------------------------------------------------------------------------------+initialize :: IO ()+initialize = do+   -- set up the only meny+   attachMenu RightButton (Menu [MenuEntry "Exit" (exitWith ExitSuccess)])++   depthFunc $= Just Less++--------------------------------------------------------------------------------+-- Handle mouse and keyboard events. For this simple demo, just exit on a+-- left click or when q is pressed.+--------------------------------------------------------------------------------+keyboardMouseHandler :: KeyboardMouseCallback+keyboardMouseHandler (MouseButton LeftButton)_ _ _ = exitWith ExitSuccess+keyboardMouseHandler (Char 'q')              _ _ _ = exitWith ExitSuccess+keyboardMouseHandler _                       _ _ _ = postRedisplay Nothing++--------------------------------------------------------------------------------+-- Reset the viewport for window changes.+--------------------------------------------------------------------------------+reshape :: ReshapeCallback+reshape size@(Size width height) =+   unless (height == 0) $ do+      viewport $= (Position 0 0, size)+      matrixMode $= Projection+      loadIdentity+      perspective 90 (fromIntegral width / fromIntegral height) 1 100++      matrixMode $= Modelview 0++--------------------------------------------------------------------------------+-- Clear and redraw the scene.+--------------------------------------------------------------------------------+display :: DisplayCallback+display = do+   -- set up the camera+   loadIdentity+   lookAt (Vertex3 0 1 6) (Vertex3 0 0 0) (Vector3 0 1 0)++   -- clear the screen+   clear [ ColorBuffer, DepthBuffer ]++   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+       vertex3f = vertex :: Vertex3 GLfloat -> IO ()++   -- draw a triangle+   renderPrimitive Triangles $ do+      color3f (Color3 1 0 0)+      vertex3f (Vertex3 2 2.5 (-1))+      color3f (Color3 0 1 0)+      vertex3f (Vertex3 (-3.5) (-2.5) (-1))+      color3f (Color3 0 0 1)+      vertex3f (Vertex3 2 (-4) 0)++   -- draw a polygon+   renderPrimitive Polygon $ do+      color3f (Color3 1 1 1)+      vertex3f (Vertex3 (-1) 2 0)+      color3f (Color3 1 1 0)+      vertex3f (Vertex3 (-3) (-0.5) 0)+      color3f (Color3 0 1 1)+      vertex3f (Vertex3 (-1.5) (-3) 0)+      color3f (Color3 0 0 0)+      vertex3f (Vertex3 1 (-2) 0)+      color3f (Color3 1 0 1)+      vertex3f (Vertex3 1 1 0)++   -- draw everything and swap the display buffer+   swapBuffers

examples/BOGLGP/Chapter02/Makefile view

@@ -1,1 +1,1 @@-include ../../examples.mk
+include ../../examples.mk

examples/BOGLGP/Chapter02/OnYourOwn1.hs view

@@ -1,230 +1,230 @@-{-
-   OnYourOwn1.hs (adapted from OpenGLApplication which is (c) 2004 Astle/Hawkins)
-   Copyright (c) Sven Panne 2004-2005 <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 Data.Maybe ( isJust )
-import Graphics.UI.GLUT hiding ( initialize )
-import System.Console.GetOpt
-import System.Environment ( getProgName )
-import System.Exit ( exitWith, ExitCode(..) )
-import System.IO ( hPutStr, stderr )
-
---------------------------------------------------------------------------------
--- Setup GLUT and OpenGL, drop into the event loop.
---------------------------------------------------------------------------------
-main :: IO ()
-main = do
-   -- Setup the basic GLUT stuff
-   (_, args) <- getArgsAndInitialize
-   opts <- parseOptions args
-   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]
-   (if useFullscreen opts then fullscreenMode else windowedMode) opts
-
-   state <- initialize
-
-   -- Register the event callback functions
-   displayCallback $= do render state; swapBuffers
-   reshapeCallback $= Just setupProjection
-   keyboardMouseCallback $= Just keyboardMouseHandler
-   idleCallback $= Just (do prepare state; postRedisplay Nothing)
-
-   -- At this point, control is relinquished to the GLUT event handler.
-   -- Control is returned as events occur, via the callback functions.
-   mainLoop
-
-fullscreenMode :: Options -> IO ()
-fullscreenMode opts = do
-   let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :))
-   gameModeCapabilities $=
-      (addCapability GameModeWidth (Just (windowWidth  opts)) .
-       addCapability GameModeHeight (Just (windowHeight opts)) .
-       addCapability GameModeBitsPerPlane (bpp opts) .
-       addCapability GameModeRefreshRate (refreshRate opts)) []
-   _ <- enterGameMode
-   maybeWin <- get currentWindow
-   if isJust maybeWin
-      then cursor $= None
-      else do
-         hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n"
-         windowedMode (opts { useFullscreen = False } )
-
-windowedMode :: Options -> IO ()
-windowedMode opts = do
-   initialWindowSize $=
-      Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts))
-   _ <- createWindow "BOGLGP - Chapter 2 - On Your Own 1"
-   return ()
-
---------------------------------------------------------------------------------
--- Option handling
---------------------------------------------------------------------------------
-data Options = Options {
-   useFullscreen :: Bool,
-   windowWidth   :: Int,
-   windowHeight  :: Int,
-   bpp           :: Maybe Int,
-   refreshRate   :: Maybe Int
-   }
-
-startOpt :: Options
-startOpt = Options {
-   useFullscreen = False,
-   windowWidth   = 800,
-   windowHeight  = 600,
-   bpp           = Nothing,
-   refreshRate   = Nothing
-   }
-
-options :: [OptDescr (Options -> IO Options)]
-options = [
-   Option ['f'] ["fullscreen"]
-      (NoArg (\opt -> return opt { useFullscreen = True }))
-      "use fullscreen mode if possible",
-   Option ['w'] ["width"]
-      (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg
-                              return opt { windowWidth = w })
-              "WIDTH")
-      "use window width WIDTH",
-   Option ['h'] ["height"]
-      (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg
-                              return opt { windowHeight = h })
-              "HEIGHT")
-      "use window height HEIGHT",
-   Option ['b'] ["bpp"]
-      (ReqArg (\arg opt -> do b <- readInt "BPP" arg
-                              return opt { bpp = Just b })
-              "BPP")
-      "use BPP bits per plane (ignored in windowed mode)",
-   Option ['r'] ["refresh-rate"]
-      (ReqArg (\arg opt -> do r <- readInt "HZ" arg
-                              return opt { refreshRate = Just r })
-              "HZ")
-      "use refresh rate HZ (ignored in windowed mode)",
-   Option ['?'] ["help"]
-      (NoArg (\_ -> do usage >>= putStr
-                       safeExitWith ExitSuccess))
-      "show help" ]
-
-readInt :: String -> String -> IO Int
-readInt name arg =
-   case reads arg of
-      ((x,[]) : _) -> return x
-      _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"]
-
-usage :: IO String
-usage = do
-   progName <- getProgName
-   return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options
-
-parseOptions :: [String] -> IO Options
-parseOptions args = do
-   let (optsActions, nonOptions, errs) = getOpt Permute options args
-   unless (null nonOptions && null errs) (dieWith errs)
-   foldl (>>=) (return startOpt) optsActions
-
-dieWith :: [String] -> IO a
-dieWith errs = do
-   u <- usage
-   mapM_ (hPutStr stderr) (errs ++ [u])
-   safeExitWith (ExitFailure 1)
-
---------------------------------------------------------------------------------
--- Handle mouse and keyboard events. For this simple demo, just exit when
--- ESCAPE is pressed.
---------------------------------------------------------------------------------
-keyboardMouseHandler :: KeyboardMouseCallback
-keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess
-keyboardMouseHandler _             _   _ _ = return ()
-
-safeExitWith :: ExitCode -> IO a
-safeExitWith code = do
-    gma <- get gameModeActive
-    when gma leaveGameMode
-    exitWith code
-
---------------------------------------------------------------------------------
--- The globale state, which is only the current angle in this simple demo.
--- We don't need the window dimensions here, they are not used and would
--- be easily available via GLUT anyway.
---------------------------------------------------------------------------------
-data State = State { angle :: IORef GLfloat }
-
-makeState :: IO State
-makeState = do
-   a <- newIORef 0
-   return $ State { angle = a }
-
---------------------------------------------------------------------------------
--- Do one time setup, i.e. set the clear color and create the global state.
---------------------------------------------------------------------------------
-initialize :: IO State
-initialize = do
-   -- clear to white background
-   clearColor $= Color4 1 1 1 0
-
-   makeState
-
---------------------------------------------------------------------------------
--- Reset the viewport for window changes.
---------------------------------------------------------------------------------
-setupProjection :: ReshapeCallback
-setupProjection (Size width height) = do
-   -- don't want a divide by zero
-   let h = max 1 height
-   -- reset the viewport to new dimensions
-   viewport $= (Position 0 0, Size width h)
-   -- set projection matrix as the current matrix
-   matrixMode $= Projection
-   -- reset projection matrix
-   loadIdentity
-
-   -- calculate aspect ratio of window
-   perspective 52 (fromIntegral width / fromIntegral h) 1 1000
-
-   -- set modelview matrix
-   matrixMode $= Modelview 0
-   -- reset modelview matrix
-   loadIdentity
-
---------------------------------------------------------------------------------
--- Perform any data-specific updates for a frame. Here we only increment the
--- angle for the rotation of the triangle.
---------------------------------------------------------------------------------
-prepare :: State -> IdleCallback
-prepare state = do
-   angle state $~ (+ 0.1)
-
---------------------------------------------------------------------------------
--- Clear and redraw the scene.
---------------------------------------------------------------------------------
-render :: State -> DisplayCallback
-render state = do
-   -- clear screen and depth buffer
-   clear [ ColorBuffer, DepthBuffer ]
-   loadIdentity
-
-   -- resolve overloading, not needed in "real" programs
-   let translate3f = translate :: Vector3 GLfloat -> IO ()
-       color3f = color :: Color3 GLfloat -> IO ()
-       vertex3f = vertex :: Vertex3 GLfloat -> IO ()
-
-   -- move back 5 units and rotate about all 3 axes
-   translate3f (Vector3 0 0 (-5))
-   a <- get (angle state)
-   rotate a (Vector3 1 0 0)
-   rotate a (Vector3 0 1 0)
-   rotate a (Vector3 0 0 1)
-
-   -- red color
-   color3f (Color3 1 0 0)
-
-   -- draw the triangle such that the rotation point is in the center
-   renderPrimitive Triangles $ do
-      vertex3f (Vertex3   1  (-1) 0)
-      vertex3f (Vertex3 (-1) (-1) 0)
-      vertex3f (Vertex3   0    1  0)
+{-+   OnYourOwn1.hs (adapted from OpenGLApplication which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2004-2005 <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 Data.Maybe ( isJust )+import Graphics.UI.GLUT hiding ( initialize )+import System.Console.GetOpt+import System.Environment ( getProgName )+import System.Exit ( exitWith, ExitCode(..) )+import System.IO ( hPutStr, stderr )++--------------------------------------------------------------------------------+-- Setup GLUT and OpenGL, drop into the event loop.+--------------------------------------------------------------------------------+main :: IO ()+main = do+   -- Setup the basic GLUT stuff+   (_, args) <- getArgsAndInitialize+   opts <- parseOptions args+   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]+   (if useFullscreen opts then fullscreenMode else windowedMode) opts++   state <- initialize++   -- Register the event callback functions+   displayCallback $= do render state; swapBuffers+   reshapeCallback $= Just setupProjection+   keyboardMouseCallback $= Just keyboardMouseHandler+   idleCallback $= Just (do prepare state; postRedisplay Nothing)++   -- At this point, control is relinquished to the GLUT event handler.+   -- Control is returned as events occur, via the callback functions.+   mainLoop++fullscreenMode :: Options -> IO ()+fullscreenMode opts = do+   let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :))+   gameModeCapabilities $=+      (addCapability GameModeWidth (Just (windowWidth  opts)) .+       addCapability GameModeHeight (Just (windowHeight opts)) .+       addCapability GameModeBitsPerPlane (bpp opts) .+       addCapability GameModeRefreshRate (refreshRate opts)) []+   _ <- enterGameMode+   maybeWin <- get currentWindow+   if isJust maybeWin+      then cursor $= None+      else do+         hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n"+         windowedMode (opts { useFullscreen = False } )++windowedMode :: Options -> IO ()+windowedMode opts = do+   initialWindowSize $=+      Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts))+   _ <- createWindow "BOGLGP - Chapter 2 - On Your Own 1"+   return ()++--------------------------------------------------------------------------------+-- Option handling+--------------------------------------------------------------------------------+data Options = Options {+   useFullscreen :: Bool,+   windowWidth   :: Int,+   windowHeight  :: Int,+   bpp           :: Maybe Int,+   refreshRate   :: Maybe Int+   }++startOpt :: Options+startOpt = Options {+   useFullscreen = False,+   windowWidth   = 800,+   windowHeight  = 600,+   bpp           = Nothing,+   refreshRate   = Nothing+   }++options :: [OptDescr (Options -> IO Options)]+options = [+   Option ['f'] ["fullscreen"]+      (NoArg (\opt -> return opt { useFullscreen = True }))+      "use fullscreen mode if possible",+   Option ['w'] ["width"]+      (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg+                              return opt { windowWidth = w })+              "WIDTH")+      "use window width WIDTH",+   Option ['h'] ["height"]+      (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg+                              return opt { windowHeight = h })+              "HEIGHT")+      "use window height HEIGHT",+   Option ['b'] ["bpp"]+      (ReqArg (\arg opt -> do b <- readInt "BPP" arg+                              return opt { bpp = Just b })+              "BPP")+      "use BPP bits per plane (ignored in windowed mode)",+   Option ['r'] ["refresh-rate"]+      (ReqArg (\arg opt -> do r <- readInt "HZ" arg+                              return opt { refreshRate = Just r })+              "HZ")+      "use refresh rate HZ (ignored in windowed mode)",+   Option ['?'] ["help"]+      (NoArg (\_ -> do usage >>= putStr+                       safeExitWith ExitSuccess))+      "show help" ]++readInt :: String -> String -> IO Int+readInt name arg =+   case reads arg of+      ((x,[]) : _) -> return x+      _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"]++usage :: IO String+usage = do+   progName <- getProgName+   return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options++parseOptions :: [String] -> IO Options+parseOptions args = do+   let (optsActions, nonOptions, errs) = getOpt Permute options args+   unless (null nonOptions && null errs) (dieWith errs)+   foldl (>>=) (return startOpt) optsActions++dieWith :: [String] -> IO a+dieWith errs = do+   u <- usage+   mapM_ (hPutStr stderr) (errs ++ [u])+   safeExitWith (ExitFailure 1)++--------------------------------------------------------------------------------+-- Handle mouse and keyboard events. For this simple demo, just exit when+-- ESCAPE is pressed.+--------------------------------------------------------------------------------+keyboardMouseHandler :: KeyboardMouseCallback+keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess+keyboardMouseHandler _             _   _ _ = return ()++safeExitWith :: ExitCode -> IO a+safeExitWith code = do+    gma <- get gameModeActive+    when gma leaveGameMode+    exitWith code++--------------------------------------------------------------------------------+-- The globale state, which is only the current angle in this simple demo.+-- We don't need the window dimensions here, they are not used and would+-- be easily available via GLUT anyway.+--------------------------------------------------------------------------------+data State = State { angle :: IORef GLfloat }++makeState :: IO State+makeState = do+   a <- newIORef 0+   return $ State { angle = a }++--------------------------------------------------------------------------------+-- Do one time setup, i.e. set the clear color and create the global state.+--------------------------------------------------------------------------------+initialize :: IO State+initialize = do+   -- clear to white background+   clearColor $= Color4 1 1 1 0++   makeState++--------------------------------------------------------------------------------+-- Reset the viewport for window changes.+--------------------------------------------------------------------------------+setupProjection :: ReshapeCallback+setupProjection (Size width height) = do+   -- don't want a divide by zero+   let h = max 1 height+   -- reset the viewport to new dimensions+   viewport $= (Position 0 0, Size width h)+   -- set projection matrix as the current matrix+   matrixMode $= Projection+   -- reset projection matrix+   loadIdentity++   -- calculate aspect ratio of window+   perspective 52 (fromIntegral width / fromIntegral h) 1 1000++   -- set modelview matrix+   matrixMode $= Modelview 0+   -- reset modelview matrix+   loadIdentity++--------------------------------------------------------------------------------+-- Perform any data-specific updates for a frame. Here we only increment the+-- angle for the rotation of the triangle.+--------------------------------------------------------------------------------+prepare :: State -> IdleCallback+prepare state = do+   angle state $~ (+ 0.1)++--------------------------------------------------------------------------------+-- Clear and redraw the scene.+--------------------------------------------------------------------------------+render :: State -> DisplayCallback+render state = do+   -- clear screen and depth buffer+   clear [ ColorBuffer, DepthBuffer ]+   loadIdentity++   -- resolve overloading, not needed in "real" programs+   let translate3f = translate :: Vector3 GLfloat -> IO ()+       color3f = color :: Color3 GLfloat -> IO ()+       vertex3f = vertex :: Vertex3 GLfloat -> IO ()++   -- move back 5 units and rotate about all 3 axes+   translate3f (Vector3 0 0 (-5))+   a <- get (angle state)+   rotate a (Vector3 1 0 0)+   rotate a (Vector3 0 1 0)+   rotate a (Vector3 0 0 1)++   -- red color+   color3f (Color3 1 0 0)++   -- draw the triangle such that the rotation point is in the center+   renderPrimitive Triangles $ do+      vertex3f (Vertex3   1  (-1) 0)+      vertex3f (Vertex3 (-1) (-1) 0)+      vertex3f (Vertex3   0    1  0)

examples/BOGLGP/Chapter02/OpenGLApplication.hs view

@@ -1,230 +1,230 @@-{-
-   OpenGLApplication.hs (adapted from OpenGLApplication which is (c) 2004 Astle/Hawkins)
-   Copyright (c) Sven Panne 2004-2005 <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 Data.Maybe ( isJust )
-import Graphics.UI.GLUT hiding ( initialize )
-import System.Console.GetOpt
-import System.Environment ( getProgName )
-import System.Exit ( exitWith, ExitCode(..) )
-import System.IO ( hPutStr, stderr )
-
---------------------------------------------------------------------------------
--- Setup GLUT and OpenGL, drop into the event loop.
---------------------------------------------------------------------------------
-main :: IO ()
-main = do
-   -- Setup the basic GLUT stuff
-   (_, args) <- getArgsAndInitialize
-   opts <- parseOptions args
-   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]
-   (if useFullscreen opts then fullscreenMode else windowedMode) opts
-
-   state <- initialize
-
-   -- Register the event callback functions
-   displayCallback $= do render state; swapBuffers
-   reshapeCallback $= Just setupProjection
-   keyboardMouseCallback $= Just keyboardMouseHandler
-   idleCallback $= Just (do prepare state; postRedisplay Nothing)
-
-   -- At this point, control is relinquished to the GLUT event handler.
-   -- Control is returned as events occur, via the callback functions.
-   mainLoop
-
-fullscreenMode :: Options -> IO ()
-fullscreenMode opts = do
-   let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :))
-   gameModeCapabilities $=
-      (addCapability GameModeWidth (Just (windowWidth  opts)) .
-       addCapability GameModeHeight (Just (windowHeight opts)) .
-       addCapability GameModeBitsPerPlane (bpp opts) .
-       addCapability GameModeRefreshRate (refreshRate opts)) []
-   _ <- enterGameMode
-   maybeWin <- get currentWindow
-   if isJust maybeWin
-      then cursor $= None
-      else do
-         hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n"
-         windowedMode (opts { useFullscreen = False } )
-
-windowedMode :: Options -> IO ()
-windowedMode opts = do
-   initialWindowSize $=
-      Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts))
-   _ <- createWindow "BOGLGP - Chapter 2 - OpenGL Application"
-   return ()
-
---------------------------------------------------------------------------------
--- Option handling
---------------------------------------------------------------------------------
-data Options = Options {
-   useFullscreen :: Bool,
-   windowWidth   :: Int,
-   windowHeight  :: Int,
-   bpp           :: Maybe Int,
-   refreshRate   :: Maybe Int
-   }
-
-startOpt :: Options
-startOpt = Options {
-   useFullscreen = False,
-   windowWidth   = 800,
-   windowHeight  = 600,
-   bpp           = Nothing,
-   refreshRate   = Nothing
-   }
-
-options :: [OptDescr (Options -> IO Options)]
-options = [
-   Option ['f'] ["fullscreen"]
-      (NoArg (\opt -> return opt { useFullscreen = True }))
-      "use fullscreen mode if possible",
-   Option ['w'] ["width"]
-      (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg
-                              return opt { windowWidth = w })
-              "WIDTH")
-      "use window width WIDTH",
-   Option ['h'] ["height"]
-      (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg
-                              return opt { windowHeight = h })
-              "HEIGHT")
-      "use window height HEIGHT",
-   Option ['b'] ["bpp"]
-      (ReqArg (\arg opt -> do b <- readInt "BPP" arg
-                              return opt { bpp = Just b })
-              "BPP")
-      "use BPP bits per plane (ignored in windowed mode)",
-   Option ['r'] ["refresh-rate"]
-      (ReqArg (\arg opt -> do r <- readInt "HZ" arg
-                              return opt { refreshRate = Just r })
-              "HZ")
-      "use refresh rate HZ (ignored in windowed mode)",
-   Option ['?'] ["help"]
-      (NoArg (\_ -> do usage >>= putStr
-                       safeExitWith ExitSuccess))
-      "show help" ]
-
-readInt :: String -> String -> IO Int
-readInt name arg =
-   case reads arg of
-      ((x,[]) : _) -> return x
-      _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"]
-
-usage :: IO String
-usage = do
-   progName <- getProgName
-   return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options
-
-parseOptions :: [String] -> IO Options
-parseOptions args = do
-   let (optsActions, nonOptions, errs) = getOpt Permute options args
-   unless (null nonOptions && null errs) (dieWith errs)
-   foldl (>>=) (return startOpt) optsActions
-
-dieWith :: [String] -> IO a
-dieWith errs = do
-   u <- usage
-   mapM_ (hPutStr stderr) (errs ++ [u])
-   safeExitWith (ExitFailure 1)
-
---------------------------------------------------------------------------------
--- Handle mouse and keyboard events. For this simple demo, just exit when
--- ESCAPE is pressed.
---------------------------------------------------------------------------------
-keyboardMouseHandler :: KeyboardMouseCallback
-keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess
-keyboardMouseHandler _             _   _ _ = return ()
-
-safeExitWith :: ExitCode -> IO a
-safeExitWith code = do
-    gma <- get gameModeActive
-    when gma leaveGameMode
-    exitWith code
-
---------------------------------------------------------------------------------
--- The globale state, which is only the current angle in this simple demo.
--- We don't need the window dimensions here, they are not used and would
--- be easily available via GLUT anyway.
---------------------------------------------------------------------------------
-data State = State { angle :: IORef GLfloat }
-
-makeState :: IO State
-makeState = do
-   a <- newIORef 0
-   return $ State { angle = a }
-
---------------------------------------------------------------------------------
--- Do one time setup, i.e. set the clear color and create the global state.
---------------------------------------------------------------------------------
-initialize :: IO State
-initialize = do
-   -- clear to black background
-   clearColor $= Color4 0 0 0 0
-
-   makeState
-
---------------------------------------------------------------------------------
--- Reset the viewport for window changes.
---------------------------------------------------------------------------------
-setupProjection :: ReshapeCallback
-setupProjection (Size width height) = do
-   -- don't want a divide by zero
-   let h = max 1 height
-   -- reset the viewport to new dimensions
-   viewport $= (Position 0 0, Size width h)
-   -- set projection matrix as the current matrix
-   matrixMode $= Projection
-   -- reset projection matrix
-   loadIdentity
-
-   -- calculate aspect ratio of window
-   perspective 52 (fromIntegral width / fromIntegral h) 1 1000
-
-   -- set modelview matrix
-   matrixMode $= Modelview 0
-   -- reset modelview matrix
-   loadIdentity
-
---------------------------------------------------------------------------------
--- Perform any data-specific updates for a frame. Here we only increment the
--- angle for the rotation of the triangle.
---------------------------------------------------------------------------------
-prepare :: State -> IdleCallback
-prepare state = do
-   angle state $~ (+ 0.1)
-
---------------------------------------------------------------------------------
--- Clear and redraw the scene.
---------------------------------------------------------------------------------
-render :: State -> DisplayCallback
-render state = do
-   -- clear screen and depth buffer
-   clear [ ColorBuffer, DepthBuffer ]
-   loadIdentity
-
-   -- resolve overloading, not needed in "real" programs
-   let translate3f = translate :: Vector3 GLfloat -> IO ()
-       color3f = color :: Color3 GLfloat -> IO ()
-       vertex3f = vertex :: Vertex3 GLfloat -> IO ()
-
-   -- move back 5 units and rotate about all 3 axes
-   translate3f (Vector3 0 0 (-5))
-   a <- get (angle state)
-   rotate a (Vector3 1 0 0)
-   rotate a (Vector3 0 1 0)
-   rotate a (Vector3 0 0 1)
-
-   -- lime greenish color
-   color3f (Color3 0.7 1 0.3)
-
-   -- draw the triangle such that the rotation point is in the center
-   renderPrimitive Triangles $ do
-      vertex3f (Vertex3   1  (-1) 0)
-      vertex3f (Vertex3 (-1) (-1) 0)
-      vertex3f (Vertex3   0    1  0)
+{-+   OpenGLApplication.hs (adapted from OpenGLApplication which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2004-2005 <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 Data.Maybe ( isJust )+import Graphics.UI.GLUT hiding ( initialize )+import System.Console.GetOpt+import System.Environment ( getProgName )+import System.Exit ( exitWith, ExitCode(..) )+import System.IO ( hPutStr, stderr )++--------------------------------------------------------------------------------+-- Setup GLUT and OpenGL, drop into the event loop.+--------------------------------------------------------------------------------+main :: IO ()+main = do+   -- Setup the basic GLUT stuff+   (_, args) <- getArgsAndInitialize+   opts <- parseOptions args+   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]+   (if useFullscreen opts then fullscreenMode else windowedMode) opts++   state <- initialize++   -- Register the event callback functions+   displayCallback $= do render state; swapBuffers+   reshapeCallback $= Just setupProjection+   keyboardMouseCallback $= Just keyboardMouseHandler+   idleCallback $= Just (do prepare state; postRedisplay Nothing)++   -- At this point, control is relinquished to the GLUT event handler.+   -- Control is returned as events occur, via the callback functions.+   mainLoop++fullscreenMode :: Options -> IO ()+fullscreenMode opts = do+   let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :))+   gameModeCapabilities $=+      (addCapability GameModeWidth (Just (windowWidth  opts)) .+       addCapability GameModeHeight (Just (windowHeight opts)) .+       addCapability GameModeBitsPerPlane (bpp opts) .+       addCapability GameModeRefreshRate (refreshRate opts)) []+   _ <- enterGameMode+   maybeWin <- get currentWindow+   if isJust maybeWin+      then cursor $= None+      else do+         hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n"+         windowedMode (opts { useFullscreen = False } )++windowedMode :: Options -> IO ()+windowedMode opts = do+   initialWindowSize $=+      Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts))+   _ <- createWindow "BOGLGP - Chapter 2 - OpenGL Application"+   return ()++--------------------------------------------------------------------------------+-- Option handling+--------------------------------------------------------------------------------+data Options = Options {+   useFullscreen :: Bool,+   windowWidth   :: Int,+   windowHeight  :: Int,+   bpp           :: Maybe Int,+   refreshRate   :: Maybe Int+   }++startOpt :: Options+startOpt = Options {+   useFullscreen = False,+   windowWidth   = 800,+   windowHeight  = 600,+   bpp           = Nothing,+   refreshRate   = Nothing+   }++options :: [OptDescr (Options -> IO Options)]+options = [+   Option ['f'] ["fullscreen"]+      (NoArg (\opt -> return opt { useFullscreen = True }))+      "use fullscreen mode if possible",+   Option ['w'] ["width"]+      (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg+                              return opt { windowWidth = w })+              "WIDTH")+      "use window width WIDTH",+   Option ['h'] ["height"]+      (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg+                              return opt { windowHeight = h })+              "HEIGHT")+      "use window height HEIGHT",+   Option ['b'] ["bpp"]+      (ReqArg (\arg opt -> do b <- readInt "BPP" arg+                              return opt { bpp = Just b })+              "BPP")+      "use BPP bits per plane (ignored in windowed mode)",+   Option ['r'] ["refresh-rate"]+      (ReqArg (\arg opt -> do r <- readInt "HZ" arg+                              return opt { refreshRate = Just r })+              "HZ")+      "use refresh rate HZ (ignored in windowed mode)",+   Option ['?'] ["help"]+      (NoArg (\_ -> do usage >>= putStr+                       safeExitWith ExitSuccess))+      "show help" ]++readInt :: String -> String -> IO Int+readInt name arg =+   case reads arg of+      ((x,[]) : _) -> return x+      _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"]++usage :: IO String+usage = do+   progName <- getProgName+   return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options++parseOptions :: [String] -> IO Options+parseOptions args = do+   let (optsActions, nonOptions, errs) = getOpt Permute options args+   unless (null nonOptions && null errs) (dieWith errs)+   foldl (>>=) (return startOpt) optsActions++dieWith :: [String] -> IO a+dieWith errs = do+   u <- usage+   mapM_ (hPutStr stderr) (errs ++ [u])+   safeExitWith (ExitFailure 1)++--------------------------------------------------------------------------------+-- Handle mouse and keyboard events. For this simple demo, just exit when+-- ESCAPE is pressed.+--------------------------------------------------------------------------------+keyboardMouseHandler :: KeyboardMouseCallback+keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess+keyboardMouseHandler _             _   _ _ = return ()++safeExitWith :: ExitCode -> IO a+safeExitWith code = do+    gma <- get gameModeActive+    when gma leaveGameMode+    exitWith code++--------------------------------------------------------------------------------+-- The globale state, which is only the current angle in this simple demo.+-- We don't need the window dimensions here, they are not used and would+-- be easily available via GLUT anyway.+--------------------------------------------------------------------------------+data State = State { angle :: IORef GLfloat }++makeState :: IO State+makeState = do+   a <- newIORef 0+   return $ State { angle = a }++--------------------------------------------------------------------------------+-- Do one time setup, i.e. set the clear color and create the global state.+--------------------------------------------------------------------------------+initialize :: IO State+initialize = do+   -- clear to black background+   clearColor $= Color4 0 0 0 0++   makeState++--------------------------------------------------------------------------------+-- Reset the viewport for window changes.+--------------------------------------------------------------------------------+setupProjection :: ReshapeCallback+setupProjection (Size width height) = do+   -- don't want a divide by zero+   let h = max 1 height+   -- reset the viewport to new dimensions+   viewport $= (Position 0 0, Size width h)+   -- set projection matrix as the current matrix+   matrixMode $= Projection+   -- reset projection matrix+   loadIdentity++   -- calculate aspect ratio of window+   perspective 52 (fromIntegral width / fromIntegral h) 1 1000++   -- set modelview matrix+   matrixMode $= Modelview 0+   -- reset modelview matrix+   loadIdentity++--------------------------------------------------------------------------------+-- Perform any data-specific updates for a frame. Here we only increment the+-- angle for the rotation of the triangle.+--------------------------------------------------------------------------------+prepare :: State -> IdleCallback+prepare state = do+   angle state $~ (+ 0.1)++--------------------------------------------------------------------------------+-- Clear and redraw the scene.+--------------------------------------------------------------------------------+render :: State -> DisplayCallback+render state = do+   -- clear screen and depth buffer+   clear [ ColorBuffer, DepthBuffer ]+   loadIdentity++   -- resolve overloading, not needed in "real" programs+   let translate3f = translate :: Vector3 GLfloat -> IO ()+       color3f = color :: Color3 GLfloat -> IO ()+       vertex3f = vertex :: Vertex3 GLfloat -> IO ()++   -- move back 5 units and rotate about all 3 axes+   translate3f (Vector3 0 0 (-5))+   a <- get (angle state)+   rotate a (Vector3 1 0 0)+   rotate a (Vector3 0 1 0)+   rotate a (Vector3 0 0 1)++   -- lime greenish color+   color3f (Color3 0.7 1 0.3)++   -- draw the triangle such that the rotation point is in the center+   renderPrimitive Triangles $ do+      vertex3f (Vertex3   1  (-1) 0)+      vertex3f (Vertex3 (-1) (-1) 0)+      vertex3f (Vertex3   0    1  0)

examples/BOGLGP/Chapter03/Lines.hs view

@@ -1,210 +1,210 @@-{-
-   Lines.hs (adapted from Lines which is (c) 2004 Astle/Hawkins)
-   Copyright (c) Sven Panne 2004-2005 <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, zipWithM_ )
-import Data.Maybe ( isJust )
-import Graphics.UI.GLUT hiding ( initialize )
-import System.Console.GetOpt
-import System.Environment ( getProgName )
-import System.Exit ( exitWith, ExitCode(..) )
-import System.IO ( hPutStr, stderr )
-
---------------------------------------------------------------------------------
--- Setup GLUT and OpenGL, drop into the event loop.
---------------------------------------------------------------------------------
-main :: IO ()
-main = do
-   -- Setup the basic GLUT stuff
-   (_, args) <- getArgsAndInitialize
-   opts <- parseOptions args
-   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]
-   (if useFullscreen opts then fullscreenMode else windowedMode) opts
-
-   initialize
-
-   -- Register the event callback functions
-   displayCallback $= do render; swapBuffers
-   reshapeCallback $= Just setupProjection
-   keyboardMouseCallback $= Just keyboardMouseHandler
-   -- No need for an idle callback here, this would just hog the CPU
-   -- without any visible effect
-
-   -- At this point, control is relinquished to the GLUT event handler.
-   -- Control is returned as events occur, via the callback functions.
-   mainLoop
-
-fullscreenMode :: Options -> IO ()
-fullscreenMode opts = do
-   let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :))
-   gameModeCapabilities $=
-      (addCapability GameModeWidth (Just (windowWidth  opts)) .
-       addCapability GameModeHeight (Just (windowHeight opts)) .
-       addCapability GameModeBitsPerPlane (bpp opts) .
-       addCapability GameModeRefreshRate (refreshRate opts)) []
-   _ <- enterGameMode
-   maybeWin <- get currentWindow
-   if isJust maybeWin
-      then cursor $= None
-      else do
-         hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n"
-         windowedMode (opts { useFullscreen = False } )
-
-windowedMode :: Options -> IO ()
-windowedMode opts = do
-   initialWindowSize $=
-      Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts))
-   _ <- createWindow "BOGLGP - Chapter 3 - Lines"
-   return ()
-
---------------------------------------------------------------------------------
--- Option handling
---------------------------------------------------------------------------------
-data Options = Options {
-   useFullscreen :: Bool,
-   windowWidth   :: Int,
-   windowHeight  :: Int,
-   bpp           :: Maybe Int,
-   refreshRate   :: Maybe Int
-   }
-
-startOpt :: Options
-startOpt = Options {
-   useFullscreen = False,
-   windowWidth   = 800,
-   windowHeight  = 600,
-   bpp           = Nothing,
-   refreshRate   = Nothing
-   }
-
-options :: [OptDescr (Options -> IO Options)]
-options = [
-   Option ['f'] ["fullscreen"]
-      (NoArg (\opt -> return opt { useFullscreen = True }))
-      "use fullscreen mode if possible",
-   Option ['w'] ["width"]
-      (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg
-                              return opt { windowWidth = w })
-              "WIDTH")
-      "use window width WIDTH",
-   Option ['h'] ["height"]
-      (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg
-                              return opt { windowHeight = h })
-              "HEIGHT")
-      "use window height HEIGHT",
-   Option ['b'] ["bpp"]
-      (ReqArg (\arg opt -> do b <- readInt "BPP" arg
-                              return opt { bpp = Just b })
-              "BPP")
-      "use BPP bits per plane (ignored in windowed mode)",
-   Option ['r'] ["refresh-rate"]
-      (ReqArg (\arg opt -> do r <- readInt "HZ" arg
-                              return opt { refreshRate = Just r })
-              "HZ")
-      "use refresh rate HZ (ignored in windowed mode)",
-   Option ['?'] ["help"]
-      (NoArg (\_ -> do usage >>= putStr
-                       safeExitWith ExitSuccess))
-      "show help" ]
-
-readInt :: String -> String -> IO Int
-readInt name arg =
-   case reads arg of
-      ((x,[]) : _) -> return x
-      _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"]
-
-usage :: IO String
-usage = do
-   progName <- getProgName
-   return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options
-
-parseOptions :: [String] -> IO Options
-parseOptions args = do
-   let (optsActions, nonOptions, errs) = getOpt Permute options args
-   unless (null nonOptions && null errs) (dieWith errs)
-   foldl (>>=) (return startOpt) optsActions
-
-dieWith :: [String] -> IO a
-dieWith errs = do
-   u <- usage
-   mapM_ (hPutStr stderr) (errs ++ [u])
-   safeExitWith (ExitFailure 1)
-
---------------------------------------------------------------------------------
--- Handle mouse and keyboard events. For this simple demo, just exit when
--- ESCAPE is pressed.
---------------------------------------------------------------------------------
-keyboardMouseHandler :: KeyboardMouseCallback
-keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess
-keyboardMouseHandler _             _   _ _ = return ()
-
-safeExitWith :: ExitCode -> IO a
-safeExitWith code = do
-    gma <- get gameModeActive
-    when gma leaveGameMode
-    exitWith code
-
---------------------------------------------------------------------------------
--- Do one time setup, i.e. set the clear color.
---------------------------------------------------------------------------------
-initialize :: IO ()
-initialize = clearColor $= Color4 0 0 0 0
-
---------------------------------------------------------------------------------
--- Reset the viewport for window changes.
---------------------------------------------------------------------------------
-setupProjection :: ReshapeCallback
-setupProjection (Size width height) = do
-   -- don't want a divide by zero
-   let h = max 1 height
-   -- reset the viewport to new dimensions
-   viewport $= (Position 0 0, Size width h)
-   -- set projection matrix as the current matrix
-   matrixMode $= Projection
-   -- reset projection matrix
-   loadIdentity
-
-   -- calculate aspect ratio of window
-   perspective 52 (fromIntegral width / fromIntegral h) 1 1000
-
-   -- set modelview matrix
-   matrixMode $= Modelview 0
-   -- reset modelview matrix
-   loadIdentity
-
---------------------------------------------------------------------------------
--- Clear and redraw the scene.
---------------------------------------------------------------------------------
-render :: DisplayCallback
-render = do
-   -- clear screen and depth buffer
-   clear [ ColorBuffer, DepthBuffer ]
-   loadIdentity
-   lookAt (Vertex3 0 10 0.1) (Vertex3 0 0 0) (Vector3 0 1 0)
-
-   -- function to draw a series of lines of increasing width
-   let drawLines x = zipWithM_ (\lw line -> do
-          -- set the line width
-          lineWidth $= lw
-
-          -- draw the line
-          renderPrimitive Lines $ do
-             vertex (Vertex3  x      0 (line - 3))
-             vertex (Vertex3 (x + 4) 0 (line - 3)))
-          [ 0.5 .. ]
-          [ 0, 0.5 .. 6.5 :: GLfloat ]
-
-   -- draw a series of lines of increasing width without stippling
-   drawLines (-5)
-
-   -- set the stipple pattern, 0xAAAA = 1010 1010 1010 1010
-   lineStipple $= Just (2, 0xAAAA)
-
-   -- draw a series of lines of increasing width with stippling
-   drawLines 1
-
-   -- disable stippling
-   lineStipple $= Nothing
+{-+   Lines.hs (adapted from Lines which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2004-2005 <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, zipWithM_ )+import Data.Maybe ( isJust )+import Graphics.UI.GLUT hiding ( initialize )+import System.Console.GetOpt+import System.Environment ( getProgName )+import System.Exit ( exitWith, ExitCode(..) )+import System.IO ( hPutStr, stderr )++--------------------------------------------------------------------------------+-- Setup GLUT and OpenGL, drop into the event loop.+--------------------------------------------------------------------------------+main :: IO ()+main = do+   -- Setup the basic GLUT stuff+   (_, args) <- getArgsAndInitialize+   opts <- parseOptions args+   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]+   (if useFullscreen opts then fullscreenMode else windowedMode) opts++   initialize++   -- Register the event callback functions+   displayCallback $= do render; swapBuffers+   reshapeCallback $= Just setupProjection+   keyboardMouseCallback $= Just keyboardMouseHandler+   -- No need for an idle callback here, this would just hog the CPU+   -- without any visible effect++   -- At this point, control is relinquished to the GLUT event handler.+   -- Control is returned as events occur, via the callback functions.+   mainLoop++fullscreenMode :: Options -> IO ()+fullscreenMode opts = do+   let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :))+   gameModeCapabilities $=+      (addCapability GameModeWidth (Just (windowWidth  opts)) .+       addCapability GameModeHeight (Just (windowHeight opts)) .+       addCapability GameModeBitsPerPlane (bpp opts) .+       addCapability GameModeRefreshRate (refreshRate opts)) []+   _ <- enterGameMode+   maybeWin <- get currentWindow+   if isJust maybeWin+      then cursor $= None+      else do+         hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n"+         windowedMode (opts { useFullscreen = False } )++windowedMode :: Options -> IO ()+windowedMode opts = do+   initialWindowSize $=+      Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts))+   _ <- createWindow "BOGLGP - Chapter 3 - Lines"+   return ()++--------------------------------------------------------------------------------+-- Option handling+--------------------------------------------------------------------------------+data Options = Options {+   useFullscreen :: Bool,+   windowWidth   :: Int,+   windowHeight  :: Int,+   bpp           :: Maybe Int,+   refreshRate   :: Maybe Int+   }++startOpt :: Options+startOpt = Options {+   useFullscreen = False,+   windowWidth   = 800,+   windowHeight  = 600,+   bpp           = Nothing,+   refreshRate   = Nothing+   }++options :: [OptDescr (Options -> IO Options)]+options = [+   Option ['f'] ["fullscreen"]+      (NoArg (\opt -> return opt { useFullscreen = True }))+      "use fullscreen mode if possible",+   Option ['w'] ["width"]+      (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg+                              return opt { windowWidth = w })+              "WIDTH")+      "use window width WIDTH",+   Option ['h'] ["height"]+      (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg+                              return opt { windowHeight = h })+              "HEIGHT")+      "use window height HEIGHT",+   Option ['b'] ["bpp"]+      (ReqArg (\arg opt -> do b <- readInt "BPP" arg+                              return opt { bpp = Just b })+              "BPP")+      "use BPP bits per plane (ignored in windowed mode)",+   Option ['r'] ["refresh-rate"]+      (ReqArg (\arg opt -> do r <- readInt "HZ" arg+                              return opt { refreshRate = Just r })+              "HZ")+      "use refresh rate HZ (ignored in windowed mode)",+   Option ['?'] ["help"]+      (NoArg (\_ -> do usage >>= putStr+                       safeExitWith ExitSuccess))+      "show help" ]++readInt :: String -> String -> IO Int+readInt name arg =+   case reads arg of+      ((x,[]) : _) -> return x+      _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"]++usage :: IO String+usage = do+   progName <- getProgName+   return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options++parseOptions :: [String] -> IO Options+parseOptions args = do+   let (optsActions, nonOptions, errs) = getOpt Permute options args+   unless (null nonOptions && null errs) (dieWith errs)+   foldl (>>=) (return startOpt) optsActions++dieWith :: [String] -> IO a+dieWith errs = do+   u <- usage+   mapM_ (hPutStr stderr) (errs ++ [u])+   safeExitWith (ExitFailure 1)++--------------------------------------------------------------------------------+-- Handle mouse and keyboard events. For this simple demo, just exit when+-- ESCAPE is pressed.+--------------------------------------------------------------------------------+keyboardMouseHandler :: KeyboardMouseCallback+keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess+keyboardMouseHandler _             _   _ _ = return ()++safeExitWith :: ExitCode -> IO a+safeExitWith code = do+    gma <- get gameModeActive+    when gma leaveGameMode+    exitWith code++--------------------------------------------------------------------------------+-- Do one time setup, i.e. set the clear color.+--------------------------------------------------------------------------------+initialize :: IO ()+initialize = clearColor $= Color4 0 0 0 0++--------------------------------------------------------------------------------+-- Reset the viewport for window changes.+--------------------------------------------------------------------------------+setupProjection :: ReshapeCallback+setupProjection (Size width height) = do+   -- don't want a divide by zero+   let h = max 1 height+   -- reset the viewport to new dimensions+   viewport $= (Position 0 0, Size width h)+   -- set projection matrix as the current matrix+   matrixMode $= Projection+   -- reset projection matrix+   loadIdentity++   -- calculate aspect ratio of window+   perspective 52 (fromIntegral width / fromIntegral h) 1 1000++   -- set modelview matrix+   matrixMode $= Modelview 0+   -- reset modelview matrix+   loadIdentity++--------------------------------------------------------------------------------+-- Clear and redraw the scene.+--------------------------------------------------------------------------------+render :: DisplayCallback+render = do+   -- clear screen and depth buffer+   clear [ ColorBuffer, DepthBuffer ]+   loadIdentity+   lookAt (Vertex3 0 10 0.1) (Vertex3 0 0 0) (Vector3 0 1 0)++   -- function to draw a series of lines of increasing width+   let drawLines x = zipWithM_ (\lw line -> do+          -- set the line width+          lineWidth $= lw++          -- draw the line+          renderPrimitive Lines $ do+             vertex (Vertex3  x      0 (line - 3))+             vertex (Vertex3 (x + 4) 0 (line - 3)))+          [ 0.5 .. ]+          [ 0, 0.5 .. 6.5 :: GLfloat ]++   -- draw a series of lines of increasing width without stippling+   drawLines (-5)++   -- set the stipple pattern, 0xAAAA = 1010 1010 1010 1010+   lineStipple $= Just (2, 0xAAAA)++   -- draw a series of lines of increasing width with stippling+   drawLines 1++   -- disable stippling+   lineStipple $= Nothing

examples/BOGLGP/Chapter03/Makefile view

@@ -1,1 +1,1 @@-include ../../examples.mk
+include ../../examples.mk

examples/BOGLGP/Chapter03/OnYourOwn1.hs view

@@ -1,217 +1,217 @@-{-
-   OnYourOwn1.hs (adapted from OnYourOwn1 which is (c) 2004 Astle/Hawkins)
-   Copyright (c) Sven Panne 2005 <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.Maybe ( isJust )
-import Graphics.UI.GLUT hiding ( initialize )
-import System.Console.GetOpt
-import System.Environment ( getProgName )
-import System.Exit ( exitWith, ExitCode(..) )
-import System.IO ( hPutStr, stderr )
-
---------------------------------------------------------------------------------
--- Setup GLUT and OpenGL, drop into the event loop.
---------------------------------------------------------------------------------
-main :: IO ()
-main = do
-   -- Setup the basic GLUT stuff
-   (_, args) <- getArgsAndInitialize
-   opts <- parseOptions args
-   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]
-   (if useFullscreen opts then fullscreenMode else windowedMode) opts
-
-   initialize
-
-   -- Register the event callback functions
-   displayCallback $= do render; swapBuffers
-   reshapeCallback $= Just setupProjection
-   keyboardMouseCallback $= Just keyboardMouseHandler
-   -- No need for an idle callback here, this would just hog the CPU
-   -- without any visible effect
-
-   -- At this point, control is relinquished to the GLUT event handler.
-   -- Control is returned as events occur, via the callback functions.
-   mainLoop
-
-fullscreenMode :: Options -> IO ()
-fullscreenMode opts = do
-   let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :))
-   gameModeCapabilities $=
-      (addCapability GameModeWidth (Just (windowWidth  opts)) .
-       addCapability GameModeHeight (Just (windowHeight opts)) .
-       addCapability GameModeBitsPerPlane (bpp opts) .
-       addCapability GameModeRefreshRate (refreshRate opts)) []
-   _ <- enterGameMode
-   maybeWin <- get currentWindow
-   if isJust maybeWin
-      then cursor $= None
-      else do
-         hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n"
-         windowedMode (opts { useFullscreen = False } )
-
-windowedMode :: Options -> IO ()
-windowedMode opts = do
-   initialWindowSize $=
-      Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts))
-   _ <- createWindow "BOGLGP - Chapter 3 - On Your Own 1"
-   return ()
-
---------------------------------------------------------------------------------
--- Option handling
---------------------------------------------------------------------------------
-data Options = Options {
-   useFullscreen :: Bool,
-   windowWidth   :: Int,
-   windowHeight  :: Int,
-   bpp           :: Maybe Int,
-   refreshRate   :: Maybe Int
-   }
-
-startOpt :: Options
-startOpt = Options {
-   useFullscreen = False,
-   windowWidth   = 800,
-   windowHeight  = 600,
-   bpp           = Nothing,
-   refreshRate   = Nothing
-   }
-
-options :: [OptDescr (Options -> IO Options)]
-options = [
-   Option ['f'] ["fullscreen"]
-      (NoArg (\opt -> return opt { useFullscreen = True }))
-      "use fullscreen mode if possible",
-   Option ['w'] ["width"]
-      (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg
-                              return opt { windowWidth = w })
-              "WIDTH")
-      "use window width WIDTH",
-   Option ['h'] ["height"]
-      (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg
-                              return opt { windowHeight = h })
-              "HEIGHT")
-      "use window height HEIGHT",
-   Option ['b'] ["bpp"]
-      (ReqArg (\arg opt -> do b <- readInt "BPP" arg
-                              return opt { bpp = Just b })
-              "BPP")
-      "use BPP bits per plane (ignored in windowed mode)",
-   Option ['r'] ["refresh-rate"]
-      (ReqArg (\arg opt -> do r <- readInt "HZ" arg
-                              return opt { refreshRate = Just r })
-              "HZ")
-      "use refresh rate HZ (ignored in windowed mode)",
-   Option ['?'] ["help"]
-      (NoArg (\_ -> do usage >>= putStr
-                       safeExitWith ExitSuccess))
-      "show help" ]
-
-readInt :: String -> String -> IO Int
-readInt name arg =
-   case reads arg of
-      ((x,[]) : _) -> return x
-      _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"]
-
-usage :: IO String
-usage = do
-   progName <- getProgName
-   return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options
-
-parseOptions :: [String] -> IO Options
-parseOptions args = do
-   let (optsActions, nonOptions, errs) = getOpt Permute options args
-   unless (null nonOptions && null errs) (dieWith errs)
-   foldl (>>=) (return startOpt) optsActions
-
-dieWith :: [String] -> IO a
-dieWith errs = do
-   u <- usage
-   mapM_ (hPutStr stderr) (errs ++ [u])
-   safeExitWith (ExitFailure 1)
-
---------------------------------------------------------------------------------
--- Handle mouse and keyboard events. For this simple demo, just exit when
--- ESCAPE is pressed.
---------------------------------------------------------------------------------
-keyboardMouseHandler :: KeyboardMouseCallback
-keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess
-keyboardMouseHandler _             _   _ _ = return ()
-
-safeExitWith :: ExitCode -> IO a
-safeExitWith code = do
-    gma <- get gameModeActive
-    when gma leaveGameMode
-    exitWith code
-
---------------------------------------------------------------------------------
--- Do one time setup, i.e. set the clear color.
---------------------------------------------------------------------------------
-initialize :: IO ()
-initialize = do
-   -- clear to black background
-   clearColor $= Color4 0 0 0 0
-
---------------------------------------------------------------------------------
--- Reset the viewport for window changes.
---------------------------------------------------------------------------------
-setupProjection :: ReshapeCallback
-setupProjection (Size width height) = do
-   -- don't want a divide by zero
-   let h = max 1 height
-   -- reset the viewport to new dimensions
-   viewport $= (Position 0 0, Size width h)
-   -- set projection matrix as the current matrix
-   matrixMode $= Projection
-   -- reset projection matrix
-   loadIdentity
-
-   -- calculate aspect ratio of window
-   perspective 52 (fromIntegral width / fromIntegral h) 1 1000
-
-   -- set modelview matrix
-   matrixMode $= Modelview 0
-   -- reset modelview matrix
-   loadIdentity
-
---------------------------------------------------------------------------------
--- Clear and redraw the scene.
---------------------------------------------------------------------------------
-render :: DisplayCallback
-render = do
-   -- clear screen and depth buffer
-   clear [ ColorBuffer, DepthBuffer ]
-   loadIdentity
-   lookAt (Vertex3 0 10 0.1) (Vertex3 0 0 0) (Vector3 0 1 0)
-
-   -- resolve overloading, not needed in "real" programs
-   let color3f = color :: Color3 GLfloat -> IO ()
-
-   color3f (Color3 1 1 1)
-
-   drawCircleApproximation 2 10 False
-
--- Hello, this is C... :-)
-for :: [GLint] -> (GLint -> IO ()) -> IO ()
-for = flip mapM_
-
-drawCircleApproximation :: GLfloat -> GLint -> Bool -> IO ()
-drawCircleApproximation radius numberOfSides edgeOnly =
-   -- if edge only, use line strips; otherwise, use polygons
-   renderPrimitive (if edgeOnly then LineStrip else Polygon) $ do
-
-      -- calculate each vertex on the circle
-      for [ 0 .. numberOfSides - 1 ] $ \v -> do
-
-         -- calculate the angle of the current vertex
-         let angle = fromIntegral v * 2 * pi / fromIntegral numberOfSides
-
-         -- draw the current vertex at the correct radius
-         vertex (Vertex3 (cos angle * radius) 0 (sin angle * radius))
-
-      -- if drawing edge only, then need to complete the loop with first vertex
-      when edgeOnly $
-         vertex (Vertex3 radius 0 0)
+{-+   OnYourOwn1.hs (adapted from OnYourOwn1 which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2005 <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.Maybe ( isJust )+import Graphics.UI.GLUT hiding ( initialize )+import System.Console.GetOpt+import System.Environment ( getProgName )+import System.Exit ( exitWith, ExitCode(..) )+import System.IO ( hPutStr, stderr )++--------------------------------------------------------------------------------+-- Setup GLUT and OpenGL, drop into the event loop.+--------------------------------------------------------------------------------+main :: IO ()+main = do+   -- Setup the basic GLUT stuff+   (_, args) <- getArgsAndInitialize+   opts <- parseOptions args+   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]+   (if useFullscreen opts then fullscreenMode else windowedMode) opts++   initialize++   -- Register the event callback functions+   displayCallback $= do render; swapBuffers+   reshapeCallback $= Just setupProjection+   keyboardMouseCallback $= Just keyboardMouseHandler+   -- No need for an idle callback here, this would just hog the CPU+   -- without any visible effect++   -- At this point, control is relinquished to the GLUT event handler.+   -- Control is returned as events occur, via the callback functions.+   mainLoop++fullscreenMode :: Options -> IO ()+fullscreenMode opts = do+   let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :))+   gameModeCapabilities $=+      (addCapability GameModeWidth (Just (windowWidth  opts)) .+       addCapability GameModeHeight (Just (windowHeight opts)) .+       addCapability GameModeBitsPerPlane (bpp opts) .+       addCapability GameModeRefreshRate (refreshRate opts)) []+   _ <- enterGameMode+   maybeWin <- get currentWindow+   if isJust maybeWin+      then cursor $= None+      else do+         hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n"+         windowedMode (opts { useFullscreen = False } )++windowedMode :: Options -> IO ()+windowedMode opts = do+   initialWindowSize $=+      Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts))+   _ <- createWindow "BOGLGP - Chapter 3 - On Your Own 1"+   return ()++--------------------------------------------------------------------------------+-- Option handling+--------------------------------------------------------------------------------+data Options = Options {+   useFullscreen :: Bool,+   windowWidth   :: Int,+   windowHeight  :: Int,+   bpp           :: Maybe Int,+   refreshRate   :: Maybe Int+   }++startOpt :: Options+startOpt = Options {+   useFullscreen = False,+   windowWidth   = 800,+   windowHeight  = 600,+   bpp           = Nothing,+   refreshRate   = Nothing+   }++options :: [OptDescr (Options -> IO Options)]+options = [+   Option ['f'] ["fullscreen"]+      (NoArg (\opt -> return opt { useFullscreen = True }))+      "use fullscreen mode if possible",+   Option ['w'] ["width"]+      (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg+                              return opt { windowWidth = w })+              "WIDTH")+      "use window width WIDTH",+   Option ['h'] ["height"]+      (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg+                              return opt { windowHeight = h })+              "HEIGHT")+      "use window height HEIGHT",+   Option ['b'] ["bpp"]+      (ReqArg (\arg opt -> do b <- readInt "BPP" arg+                              return opt { bpp = Just b })+              "BPP")+      "use BPP bits per plane (ignored in windowed mode)",+   Option ['r'] ["refresh-rate"]+      (ReqArg (\arg opt -> do r <- readInt "HZ" arg+                              return opt { refreshRate = Just r })+              "HZ")+      "use refresh rate HZ (ignored in windowed mode)",+   Option ['?'] ["help"]+      (NoArg (\_ -> do usage >>= putStr+                       safeExitWith ExitSuccess))+      "show help" ]++readInt :: String -> String -> IO Int+readInt name arg =+   case reads arg of+      ((x,[]) : _) -> return x+      _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"]++usage :: IO String+usage = do+   progName <- getProgName+   return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options++parseOptions :: [String] -> IO Options+parseOptions args = do+   let (optsActions, nonOptions, errs) = getOpt Permute options args+   unless (null nonOptions && null errs) (dieWith errs)+   foldl (>>=) (return startOpt) optsActions++dieWith :: [String] -> IO a+dieWith errs = do+   u <- usage+   mapM_ (hPutStr stderr) (errs ++ [u])+   safeExitWith (ExitFailure 1)++--------------------------------------------------------------------------------+-- Handle mouse and keyboard events. For this simple demo, just exit when+-- ESCAPE is pressed.+--------------------------------------------------------------------------------+keyboardMouseHandler :: KeyboardMouseCallback+keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess+keyboardMouseHandler _             _   _ _ = return ()++safeExitWith :: ExitCode -> IO a+safeExitWith code = do+    gma <- get gameModeActive+    when gma leaveGameMode+    exitWith code++--------------------------------------------------------------------------------+-- Do one time setup, i.e. set the clear color.+--------------------------------------------------------------------------------+initialize :: IO ()+initialize = do+   -- clear to black background+   clearColor $= Color4 0 0 0 0++--------------------------------------------------------------------------------+-- Reset the viewport for window changes.+--------------------------------------------------------------------------------+setupProjection :: ReshapeCallback+setupProjection (Size width height) = do+   -- don't want a divide by zero+   let h = max 1 height+   -- reset the viewport to new dimensions+   viewport $= (Position 0 0, Size width h)+   -- set projection matrix as the current matrix+   matrixMode $= Projection+   -- reset projection matrix+   loadIdentity++   -- calculate aspect ratio of window+   perspective 52 (fromIntegral width / fromIntegral h) 1 1000++   -- set modelview matrix+   matrixMode $= Modelview 0+   -- reset modelview matrix+   loadIdentity++--------------------------------------------------------------------------------+-- Clear and redraw the scene.+--------------------------------------------------------------------------------+render :: DisplayCallback+render = do+   -- clear screen and depth buffer+   clear [ ColorBuffer, DepthBuffer ]+   loadIdentity+   lookAt (Vertex3 0 10 0.1) (Vertex3 0 0 0) (Vector3 0 1 0)++   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()++   color3f (Color3 1 1 1)++   drawCircleApproximation 2 10 False++-- Hello, this is C... :-)+for :: [GLint] -> (GLint -> IO ()) -> IO ()+for = flip mapM_++drawCircleApproximation :: GLfloat -> GLint -> Bool -> IO ()+drawCircleApproximation radius numberOfSides edgeOnly =+   -- if edge only, use line strips; otherwise, use polygons+   renderPrimitive (if edgeOnly then LineStrip else Polygon) $ do++      -- calculate each vertex on the circle+      for [ 0 .. numberOfSides - 1 ] $ \v -> do++         -- calculate the angle of the current vertex+         let angle = fromIntegral v * 2 * pi / fromIntegral numberOfSides++         -- draw the current vertex at the correct radius+         vertex (Vertex3 (cos angle * radius) 0 (sin angle * radius))++      -- if drawing edge only, then need to complete the loop with first vertex+      when edgeOnly $+         vertex (Vertex3 radius 0 0)

examples/BOGLGP/Chapter03/Points.hs view

@@ -1,196 +1,196 @@-{-
-   Points.hs (adapted from Points which is (c) 2004 Astle/Hawkins)
-   Copyright (c) Sven Panne 2004-2005 <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, zipWithM_ )
-import Data.Maybe ( isJust )
-import Graphics.UI.GLUT hiding ( initialize )
-import System.Console.GetOpt
-import System.Environment ( getProgName )
-import System.Exit ( exitWith, ExitCode(..) )
-import System.IO ( hPutStr, stderr )
-
---------------------------------------------------------------------------------
--- Setup GLUT and OpenGL, drop into the event loop.
---------------------------------------------------------------------------------
-main :: IO ()
-main = do
-   -- Setup the basic GLUT stuff
-   (_, args) <- getArgsAndInitialize
-   opts <- parseOptions args
-   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]
-   (if useFullscreen opts then fullscreenMode else windowedMode) opts
-
-   initialize
-
-   -- Register the event callback functions
-   displayCallback $= do render; swapBuffers
-   reshapeCallback $= Just setupProjection
-   keyboardMouseCallback $= Just keyboardMouseHandler
-   -- No need for an idle callback here, this would just hog the CPU
-   -- without any visible effect
-
-   -- At this point, control is relinquished to the GLUT event handler.
-   -- Control is returned as events occur, via the callback functions.
-   mainLoop
-
-fullscreenMode :: Options -> IO ()
-fullscreenMode opts = do
-   let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :))
-   gameModeCapabilities $=
-      (addCapability GameModeWidth (Just (windowWidth  opts)) .
-       addCapability GameModeHeight (Just (windowHeight opts)) .
-       addCapability GameModeBitsPerPlane (bpp opts) .
-       addCapability GameModeRefreshRate (refreshRate opts)) []
-   _ <- enterGameMode
-   maybeWin <- get currentWindow
-   if isJust maybeWin
-      then cursor $= None
-      else do
-         hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n"
-         windowedMode (opts { useFullscreen = False } )
-
-windowedMode :: Options -> IO ()
-windowedMode opts = do
-   initialWindowSize $=
-      Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts))
-   _ <- createWindow "BOGLGP - Chapter 3 - Points"
-   return ()
-
---------------------------------------------------------------------------------
--- Option handling
---------------------------------------------------------------------------------
-data Options = Options {
-   useFullscreen :: Bool,
-   windowWidth   :: Int,
-   windowHeight  :: Int,
-   bpp           :: Maybe Int,
-   refreshRate   :: Maybe Int
-   }
-
-startOpt :: Options
-startOpt = Options {
-   useFullscreen = False,
-   windowWidth   = 800,
-   windowHeight  = 600,
-   bpp           = Nothing,
-   refreshRate   = Nothing
-   }
-
-options :: [OptDescr (Options -> IO Options)]
-options = [
-   Option ['f'] ["fullscreen"]
-      (NoArg (\opt -> return opt { useFullscreen = True }))
-      "use fullscreen mode if possible",
-   Option ['w'] ["width"]
-      (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg
-                              return opt { windowWidth = w })
-              "WIDTH")
-      "use window width WIDTH",
-   Option ['h'] ["height"]
-      (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg
-                              return opt { windowHeight = h })
-              "HEIGHT")
-      "use window height HEIGHT",
-   Option ['b'] ["bpp"]
-      (ReqArg (\arg opt -> do b <- readInt "BPP" arg
-                              return opt { bpp = Just b })
-              "BPP")
-      "use BPP bits per plane (ignored in windowed mode)",
-   Option ['r'] ["refresh-rate"]
-      (ReqArg (\arg opt -> do r <- readInt "HZ" arg
-                              return opt { refreshRate = Just r })
-              "HZ")
-      "use refresh rate HZ (ignored in windowed mode)",
-   Option ['?'] ["help"]
-      (NoArg (\_ -> do usage >>= putStr
-                       safeExitWith ExitSuccess))
-      "show help" ]
-
-readInt :: String -> String -> IO Int
-readInt name arg =
-   case reads arg of
-      ((x,[]) : _) -> return x
-      _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"]
-
-usage :: IO String
-usage = do
-   progName <- getProgName
-   return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options
-
-parseOptions :: [String] -> IO Options
-parseOptions args = do
-   let (optsActions, nonOptions, errs) = getOpt Permute options args
-   unless (null nonOptions && null errs) (dieWith errs)
-   foldl (>>=) (return startOpt) optsActions
-
-dieWith :: [String] -> IO a
-dieWith errs = do
-   u <- usage
-   mapM_ (hPutStr stderr) (errs ++ [u])
-   safeExitWith (ExitFailure 1)
-
---------------------------------------------------------------------------------
--- Handle mouse and keyboard events. For this simple demo, just exit when
--- ESCAPE is pressed.
---------------------------------------------------------------------------------
-keyboardMouseHandler :: KeyboardMouseCallback
-keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess
-keyboardMouseHandler _             _   _ _ = return ()
-
-safeExitWith :: ExitCode -> IO a
-safeExitWith code = do
-    gma <- get gameModeActive
-    when gma leaveGameMode
-    exitWith code
-
---------------------------------------------------------------------------------
--- Do one time setup, i.e. set the clear color.
---------------------------------------------------------------------------------
-initialize :: IO ()
-initialize = clearColor $= Color4 0 0 0 0
-
---------------------------------------------------------------------------------
--- Reset the viewport for window changes.
---------------------------------------------------------------------------------
-setupProjection :: ReshapeCallback
-setupProjection (Size width height) = do
-   -- don't want a divide by zero
-   let h = max 1 height
-   -- reset the viewport to new dimensions
-   viewport $= (Position 0 0, Size width h)
-   -- set projection matrix as the current matrix
-   matrixMode $= Projection
-   -- reset projection matrix
-   loadIdentity
-
-   -- calculate aspect ratio of window
-   perspective 52 (fromIntegral width / fromIntegral h) 1 1000
-
-   -- set modelview matrix
-   matrixMode $= Modelview 0
-   -- reset modelview matrix
-   loadIdentity
-
---------------------------------------------------------------------------------
--- Clear and redraw the scene.
---------------------------------------------------------------------------------
-render :: DisplayCallback
-render = do
-   -- clear screen and depth buffer
-   clear [ ColorBuffer, DepthBuffer ]
-   loadIdentity
-   lookAt (Vertex3 0 6 0.1) (Vertex3 0 0 0) (Vector3 0 1 0)
-
-   -- draw a line of points of increasing size
-   zipWithM_ (\ps point -> do
-      -- set the point size
-      pointSize $= ps
-      -- draw the point
-      renderPrimitive Points $
-         vertex (Vertex3 point 0 0))
-      [ 0.5 .. ]
-      [ -4, -3.5 .. 4.5 :: GLfloat ]
+{-+   Points.hs (adapted from Points which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2004-2005 <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, zipWithM_ )+import Data.Maybe ( isJust )+import Graphics.UI.GLUT hiding ( initialize )+import System.Console.GetOpt+import System.Environment ( getProgName )+import System.Exit ( exitWith, ExitCode(..) )+import System.IO ( hPutStr, stderr )++--------------------------------------------------------------------------------+-- Setup GLUT and OpenGL, drop into the event loop.+--------------------------------------------------------------------------------+main :: IO ()+main = do+   -- Setup the basic GLUT stuff+   (_, args) <- getArgsAndInitialize+   opts <- parseOptions args+   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]+   (if useFullscreen opts then fullscreenMode else windowedMode) opts++   initialize++   -- Register the event callback functions+   displayCallback $= do render; swapBuffers+   reshapeCallback $= Just setupProjection+   keyboardMouseCallback $= Just keyboardMouseHandler+   -- No need for an idle callback here, this would just hog the CPU+   -- without any visible effect++   -- At this point, control is relinquished to the GLUT event handler.+   -- Control is returned as events occur, via the callback functions.+   mainLoop++fullscreenMode :: Options -> IO ()+fullscreenMode opts = do+   let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :))+   gameModeCapabilities $=+      (addCapability GameModeWidth (Just (windowWidth  opts)) .+       addCapability GameModeHeight (Just (windowHeight opts)) .+       addCapability GameModeBitsPerPlane (bpp opts) .+       addCapability GameModeRefreshRate (refreshRate opts)) []+   _ <- enterGameMode+   maybeWin <- get currentWindow+   if isJust maybeWin+      then cursor $= None+      else do+         hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n"+         windowedMode (opts { useFullscreen = False } )++windowedMode :: Options -> IO ()+windowedMode opts = do+   initialWindowSize $=+      Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts))+   _ <- createWindow "BOGLGP - Chapter 3 - Points"+   return ()++--------------------------------------------------------------------------------+-- Option handling+--------------------------------------------------------------------------------+data Options = Options {+   useFullscreen :: Bool,+   windowWidth   :: Int,+   windowHeight  :: Int,+   bpp           :: Maybe Int,+   refreshRate   :: Maybe Int+   }++startOpt :: Options+startOpt = Options {+   useFullscreen = False,+   windowWidth   = 800,+   windowHeight  = 600,+   bpp           = Nothing,+   refreshRate   = Nothing+   }++options :: [OptDescr (Options -> IO Options)]+options = [+   Option ['f'] ["fullscreen"]+      (NoArg (\opt -> return opt { useFullscreen = True }))+      "use fullscreen mode if possible",+   Option ['w'] ["width"]+      (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg+                              return opt { windowWidth = w })+              "WIDTH")+      "use window width WIDTH",+   Option ['h'] ["height"]+      (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg+                              return opt { windowHeight = h })+              "HEIGHT")+      "use window height HEIGHT",+   Option ['b'] ["bpp"]+      (ReqArg (\arg opt -> do b <- readInt "BPP" arg+                              return opt { bpp = Just b })+              "BPP")+      "use BPP bits per plane (ignored in windowed mode)",+   Option ['r'] ["refresh-rate"]+      (ReqArg (\arg opt -> do r <- readInt "HZ" arg+                              return opt { refreshRate = Just r })+              "HZ")+      "use refresh rate HZ (ignored in windowed mode)",+   Option ['?'] ["help"]+      (NoArg (\_ -> do usage >>= putStr+                       safeExitWith ExitSuccess))+      "show help" ]++readInt :: String -> String -> IO Int+readInt name arg =+   case reads arg of+      ((x,[]) : _) -> return x+      _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"]++usage :: IO String+usage = do+   progName <- getProgName+   return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options++parseOptions :: [String] -> IO Options+parseOptions args = do+   let (optsActions, nonOptions, errs) = getOpt Permute options args+   unless (null nonOptions && null errs) (dieWith errs)+   foldl (>>=) (return startOpt) optsActions++dieWith :: [String] -> IO a+dieWith errs = do+   u <- usage+   mapM_ (hPutStr stderr) (errs ++ [u])+   safeExitWith (ExitFailure 1)++--------------------------------------------------------------------------------+-- Handle mouse and keyboard events. For this simple demo, just exit when+-- ESCAPE is pressed.+--------------------------------------------------------------------------------+keyboardMouseHandler :: KeyboardMouseCallback+keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess+keyboardMouseHandler _             _   _ _ = return ()++safeExitWith :: ExitCode -> IO a+safeExitWith code = do+    gma <- get gameModeActive+    when gma leaveGameMode+    exitWith code++--------------------------------------------------------------------------------+-- Do one time setup, i.e. set the clear color.+--------------------------------------------------------------------------------+initialize :: IO ()+initialize = clearColor $= Color4 0 0 0 0++--------------------------------------------------------------------------------+-- Reset the viewport for window changes.+--------------------------------------------------------------------------------+setupProjection :: ReshapeCallback+setupProjection (Size width height) = do+   -- don't want a divide by zero+   let h = max 1 height+   -- reset the viewport to new dimensions+   viewport $= (Position 0 0, Size width h)+   -- set projection matrix as the current matrix+   matrixMode $= Projection+   -- reset projection matrix+   loadIdentity++   -- calculate aspect ratio of window+   perspective 52 (fromIntegral width / fromIntegral h) 1 1000++   -- set modelview matrix+   matrixMode $= Modelview 0+   -- reset modelview matrix+   loadIdentity++--------------------------------------------------------------------------------+-- Clear and redraw the scene.+--------------------------------------------------------------------------------+render :: DisplayCallback+render = do+   -- clear screen and depth buffer+   clear [ ColorBuffer, DepthBuffer ]+   loadIdentity+   lookAt (Vertex3 0 6 0.1) (Vertex3 0 0 0) (Vector3 0 1 0)++   -- draw a line of points of increasing size+   zipWithM_ (\ps point -> do+      -- set the point size+      pointSize $= ps+      -- draw the point+      renderPrimitive Points $+         vertex (Vertex3 point 0 0))+      [ 0.5 .. ]+      [ -4, -3.5 .. 4.5 :: GLfloat ]

examples/BOGLGP/Chapter03/Polygons.hs view

@@ -1,230 +1,230 @@-{-
-   Polygons.hs (adapted from Polygons which is (c) 2004 Astle/Hawkins)
-   Copyright (c) Sven Panne 2004-2005 <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 Data.Maybe ( isJust )
-import Graphics.UI.GLUT hiding ( initialize )
-import System.Console.GetOpt
-import System.Environment ( getProgName )
-import System.Exit ( exitWith, ExitCode(..) )
-import System.IO ( hPutStr, stderr )
-
---------------------------------------------------------------------------------
--- Setup GLUT and OpenGL, drop into the event loop.
---------------------------------------------------------------------------------
-main :: IO ()
-main = do
-   -- Setup the basic GLUT stuff
-   (_, args) <- getArgsAndInitialize
-   opts <- parseOptions args
-   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]
-   (if useFullscreen opts then fullscreenMode else windowedMode) opts
-
-   state <- initialize
-
-   -- Register the event callback functions
-   displayCallback $= do render state; swapBuffers
-   reshapeCallback $= Just setupProjection
-   keyboardMouseCallback $= Just keyboardMouseHandler
-   idleCallback $= Just (postRedisplay Nothing)
-
-   -- At this point, control is relinquished to the GLUT event handler.
-   -- Control is returned as events occur, via the callback functions.
-   mainLoop
-
-fullscreenMode :: Options -> IO ()
-fullscreenMode opts = do
-   let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :))
-   gameModeCapabilities $=
-      (addCapability GameModeWidth (Just (windowWidth  opts)) .
-       addCapability GameModeHeight (Just (windowHeight opts)) .
-       addCapability GameModeBitsPerPlane (bpp opts) .
-       addCapability GameModeRefreshRate (refreshRate opts)) []
-   _ <- enterGameMode
-   maybeWin <- get currentWindow
-   if isJust maybeWin
-      then cursor $= None
-      else do
-         hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n"
-         windowedMode (opts { useFullscreen = False } )
-
-windowedMode :: Options -> IO ()
-windowedMode opts = do
-   initialWindowSize $=
-      Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts))
-   _ <- createWindow "BOGLGP - Chapter 3 - Polygons"
-   return ()
-
---------------------------------------------------------------------------------
--- Option handling
---------------------------------------------------------------------------------
-data Options = Options {
-   useFullscreen :: Bool,
-   windowWidth   :: Int,
-   windowHeight  :: Int,
-   bpp           :: Maybe Int,
-   refreshRate   :: Maybe Int
-   }
-
-startOpt :: Options
-startOpt = Options {
-   useFullscreen = False,
-   windowWidth   = 800,
-   windowHeight  = 600,
-   bpp           = Nothing,
-   refreshRate   = Nothing
-   }
-
-options :: [OptDescr (Options -> IO Options)]
-options = [
-   Option ['f'] ["fullscreen"]
-      (NoArg (\opt -> return opt { useFullscreen = True }))
-      "use fullscreen mode if possible",
-   Option ['w'] ["width"]
-      (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg
-                              return opt { windowWidth = w })
-              "WIDTH")
-      "use window width WIDTH",
-   Option ['h'] ["height"]
-      (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg
-                              return opt { windowHeight = h })
-              "HEIGHT")
-      "use window height HEIGHT",
-   Option ['b'] ["bpp"]
-      (ReqArg (\arg opt -> do b <- readInt "BPP" arg
-                              return opt { bpp = Just b })
-              "BPP")
-      "use BPP bits per plane (ignored in windowed mode)",
-   Option ['r'] ["refresh-rate"]
-      (ReqArg (\arg opt -> do r <- readInt "HZ" arg
-                              return opt { refreshRate = Just r })
-              "HZ")
-      "use refresh rate HZ (ignored in windowed mode)",
-   Option ['?'] ["help"]
-      (NoArg (\_ -> do usage >>= putStr
-                       safeExitWith ExitSuccess))
-      "show help" ]
-
-readInt :: String -> String -> IO Int
-readInt name arg =
-   case reads arg of
-      ((x,[]) : _) -> return x
-      _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"]
-
-usage :: IO String
-usage = do
-   progName <- getProgName
-   return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options
-
-parseOptions :: [String] -> IO Options
-parseOptions args = do
-   let (optsActions, nonOptions, errs) = getOpt Permute options args
-   unless (null nonOptions && null errs) (dieWith errs)
-   foldl (>>=) (return startOpt) optsActions
-
-dieWith :: [String] -> IO a
-dieWith errs = do
-   u <- usage
-   mapM_ (hPutStr stderr) (errs ++ [u])
-   safeExitWith (ExitFailure 1)
-
---------------------------------------------------------------------------------
--- Handle mouse and keyboard events. For this simple demo, just exit when
--- ESCAPE is pressed.
---------------------------------------------------------------------------------
-keyboardMouseHandler :: KeyboardMouseCallback
-keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess
-keyboardMouseHandler _             _   _ _ = return ()
-
-safeExitWith :: ExitCode -> IO a
-safeExitWith code = do
-    gma <- get gameModeActive
-    when gma leaveGameMode
-    exitWith code
-
---------------------------------------------------------------------------------
--- The globale state, which is only the current angle in this simple demo.
--- We don't need the window dimensions here, they are not used and would
--- be easily available via GLUT anyway.
---------------------------------------------------------------------------------
-data State = State { angle :: IORef GLfloat }
-
-makeState :: IO State
-makeState = do
-   a <- newIORef 0
-   return $ State { angle = a }
-
---------------------------------------------------------------------------------
--- Do one time setup, i.e. set the clear color and create the global state.
--- Note that there is no need to set the polygon mode here, because we always
--- set the front and back mode together.
---------------------------------------------------------------------------------
-initialize :: IO State
-initialize = do
-   -- clear to black background
-   clearColor $= Color4 0 0 0 0
-
-   makeState
-
---------------------------------------------------------------------------------
--- Reset the viewport for window changes.
---------------------------------------------------------------------------------
-setupProjection :: ReshapeCallback
-setupProjection (Size width height) = do
-   -- don't want a divide by zero
-   let h = max 1 height
-   -- reset the viewport to new dimensions
-   viewport $= (Position 0 0, Size width h)
-   -- set projection matrix as the current matrix
-   matrixMode $= Projection
-   -- reset projection matrix
-   loadIdentity
-
-   -- calculate aspect ratio of window
-   perspective 52 (fromIntegral width / fromIntegral h) 1 1000
-
-   -- set modelview matrix
-   matrixMode $= Modelview 0
-   -- reset modelview matrix
-   loadIdentity
-
---------------------------------------------------------------------------------
--- Clear and redraw the scene.
---------------------------------------------------------------------------------
-render :: State -> DisplayCallback
-render state = do
-   -- clear screen and depth buffer
-   clear [ ColorBuffer, DepthBuffer ]
-   loadIdentity
-   lookAt (Vertex3 0 10 0.1) (Vertex3 0 0 0) (Vector3 0 1 0)
-
-   a <- get (angle state)
-   mapM_ (draw2DSquare a) [
-      (Line, Fill,  -4, Color3 1 0 0),
-      (Fill, Point, -2, Color3 0 1 0),
-      (Fill, Fill,   0, Color3 0 0 1),
-      (Fill, Line,   2, Color3 1 0 1),
-      (Line, Line,   4, Color3 1 1 0)]
-
-   angle state $~ (+ 0.2)
-
-draw2DSquare ::
-   GLfloat -> (PolygonMode, PolygonMode, GLfloat, Color3 GLfloat) -> IO ()
-draw2DSquare a (polygonModeFront, polygonModeBack, deltaX, c) = do
-   polygonMode $= (polygonModeFront, polygonModeBack)
-   preservingMatrix $ do
-      translate (Vector3 deltaX 0 0)
-      rotate a (Vector3 0 0 1)
-      color c
-      renderPrimitive Polygon $ do
-         -- resolve overloading, not needed in "real" programs
-         let vertex3f = vertex :: Vertex3 GLfloat -> IO ()
-         vertex3f (Vertex3 (-0.5) 0   0 )
-         vertex3f (Vertex3   0.5  0   0 )
-         vertex3f (Vertex3   0.5  0 (-1))
-         vertex3f (Vertex3 (-0.5) 0 (-1))
+{-+   Polygons.hs (adapted from Polygons which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2004-2005 <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 Data.Maybe ( isJust )+import Graphics.UI.GLUT hiding ( initialize )+import System.Console.GetOpt+import System.Environment ( getProgName )+import System.Exit ( exitWith, ExitCode(..) )+import System.IO ( hPutStr, stderr )++--------------------------------------------------------------------------------+-- Setup GLUT and OpenGL, drop into the event loop.+--------------------------------------------------------------------------------+main :: IO ()+main = do+   -- Setup the basic GLUT stuff+   (_, args) <- getArgsAndInitialize+   opts <- parseOptions args+   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]+   (if useFullscreen opts then fullscreenMode else windowedMode) opts++   state <- initialize++   -- Register the event callback functions+   displayCallback $= do render state; swapBuffers+   reshapeCallback $= Just setupProjection+   keyboardMouseCallback $= Just keyboardMouseHandler+   idleCallback $= Just (postRedisplay Nothing)++   -- At this point, control is relinquished to the GLUT event handler.+   -- Control is returned as events occur, via the callback functions.+   mainLoop++fullscreenMode :: Options -> IO ()+fullscreenMode opts = do+   let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :))+   gameModeCapabilities $=+      (addCapability GameModeWidth (Just (windowWidth  opts)) .+       addCapability GameModeHeight (Just (windowHeight opts)) .+       addCapability GameModeBitsPerPlane (bpp opts) .+       addCapability GameModeRefreshRate (refreshRate opts)) []+   _ <- enterGameMode+   maybeWin <- get currentWindow+   if isJust maybeWin+      then cursor $= None+      else do+         hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n"+         windowedMode (opts { useFullscreen = False } )++windowedMode :: Options -> IO ()+windowedMode opts = do+   initialWindowSize $=+      Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts))+   _ <- createWindow "BOGLGP - Chapter 3 - Polygons"+   return ()++--------------------------------------------------------------------------------+-- Option handling+--------------------------------------------------------------------------------+data Options = Options {+   useFullscreen :: Bool,+   windowWidth   :: Int,+   windowHeight  :: Int,+   bpp           :: Maybe Int,+   refreshRate   :: Maybe Int+   }++startOpt :: Options+startOpt = Options {+   useFullscreen = False,+   windowWidth   = 800,+   windowHeight  = 600,+   bpp           = Nothing,+   refreshRate   = Nothing+   }++options :: [OptDescr (Options -> IO Options)]+options = [+   Option ['f'] ["fullscreen"]+      (NoArg (\opt -> return opt { useFullscreen = True }))+      "use fullscreen mode if possible",+   Option ['w'] ["width"]+      (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg+                              return opt { windowWidth = w })+              "WIDTH")+      "use window width WIDTH",+   Option ['h'] ["height"]+      (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg+                              return opt { windowHeight = h })+              "HEIGHT")+      "use window height HEIGHT",+   Option ['b'] ["bpp"]+      (ReqArg (\arg opt -> do b <- readInt "BPP" arg+                              return opt { bpp = Just b })+              "BPP")+      "use BPP bits per plane (ignored in windowed mode)",+   Option ['r'] ["refresh-rate"]+      (ReqArg (\arg opt -> do r <- readInt "HZ" arg+                              return opt { refreshRate = Just r })+              "HZ")+      "use refresh rate HZ (ignored in windowed mode)",+   Option ['?'] ["help"]+      (NoArg (\_ -> do usage >>= putStr+                       safeExitWith ExitSuccess))+      "show help" ]++readInt :: String -> String -> IO Int+readInt name arg =+   case reads arg of+      ((x,[]) : _) -> return x+      _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"]++usage :: IO String+usage = do+   progName <- getProgName+   return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options++parseOptions :: [String] -> IO Options+parseOptions args = do+   let (optsActions, nonOptions, errs) = getOpt Permute options args+   unless (null nonOptions && null errs) (dieWith errs)+   foldl (>>=) (return startOpt) optsActions++dieWith :: [String] -> IO a+dieWith errs = do+   u <- usage+   mapM_ (hPutStr stderr) (errs ++ [u])+   safeExitWith (ExitFailure 1)++--------------------------------------------------------------------------------+-- Handle mouse and keyboard events. For this simple demo, just exit when+-- ESCAPE is pressed.+--------------------------------------------------------------------------------+keyboardMouseHandler :: KeyboardMouseCallback+keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess+keyboardMouseHandler _             _   _ _ = return ()++safeExitWith :: ExitCode -> IO a+safeExitWith code = do+    gma <- get gameModeActive+    when gma leaveGameMode+    exitWith code++--------------------------------------------------------------------------------+-- The globale state, which is only the current angle in this simple demo.+-- We don't need the window dimensions here, they are not used and would+-- be easily available via GLUT anyway.+--------------------------------------------------------------------------------+data State = State { angle :: IORef GLfloat }++makeState :: IO State+makeState = do+   a <- newIORef 0+   return $ State { angle = a }++--------------------------------------------------------------------------------+-- Do one time setup, i.e. set the clear color and create the global state.+-- Note that there is no need to set the polygon mode here, because we always+-- set the front and back mode together.+--------------------------------------------------------------------------------+initialize :: IO State+initialize = do+   -- clear to black background+   clearColor $= Color4 0 0 0 0++   makeState++--------------------------------------------------------------------------------+-- Reset the viewport for window changes.+--------------------------------------------------------------------------------+setupProjection :: ReshapeCallback+setupProjection (Size width height) = do+   -- don't want a divide by zero+   let h = max 1 height+   -- reset the viewport to new dimensions+   viewport $= (Position 0 0, Size width h)+   -- set projection matrix as the current matrix+   matrixMode $= Projection+   -- reset projection matrix+   loadIdentity++   -- calculate aspect ratio of window+   perspective 52 (fromIntegral width / fromIntegral h) 1 1000++   -- set modelview matrix+   matrixMode $= Modelview 0+   -- reset modelview matrix+   loadIdentity++--------------------------------------------------------------------------------+-- Clear and redraw the scene.+--------------------------------------------------------------------------------+render :: State -> DisplayCallback+render state = do+   -- clear screen and depth buffer+   clear [ ColorBuffer, DepthBuffer ]+   loadIdentity+   lookAt (Vertex3 0 10 0.1) (Vertex3 0 0 0) (Vector3 0 1 0)++   a <- get (angle state)+   mapM_ (draw2DSquare a) [+      (Line, Fill,  -4, Color3 1 0 0),+      (Fill, Point, -2, Color3 0 1 0),+      (Fill, Fill,   0, Color3 0 0 1),+      (Fill, Line,   2, Color3 1 0 1),+      (Line, Line,   4, Color3 1 1 0)]++   angle state $~ (+ 0.2)++draw2DSquare ::+   GLfloat -> (PolygonMode, PolygonMode, GLfloat, Color3 GLfloat) -> IO ()+draw2DSquare a (polygonModeFront, polygonModeBack, deltaX, c) = do+   polygonMode $= (polygonModeFront, polygonModeBack)+   preservingMatrix $ do+      translate (Vector3 deltaX 0 0)+      rotate a (Vector3 0 0 1)+      color c+      renderPrimitive Polygon $ do+         -- resolve overloading, not needed in "real" programs+         let vertex3f = vertex :: Vertex3 GLfloat -> IO ()+         vertex3f (Vertex3 (-0.5) 0   0 )+         vertex3f (Vertex3   0.5  0   0 )+         vertex3f (Vertex3   0.5  0 (-1))+         vertex3f (Vertex3 (-0.5) 0 (-1))

examples/BOGLGP/Chapter03/TrianglesQuads.hs view

@@ -1,294 +1,294 @@-{-
-   TrianglesQuads.hs (adapted from TrianglesQuads which is (c) 2004 Astle/Hawkins)
-   Copyright (c) Sven Panne 2004-2005 <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.Maybe ( isJust )
-import Graphics.UI.GLUT hiding ( initialize )
-import System.Console.GetOpt
-import System.Environment ( getProgName )
-import System.Exit ( exitWith, ExitCode(..) )
-import System.IO ( hPutStr, stderr )
-
---------------------------------------------------------------------------------
--- Setup GLUT and OpenGL, drop into the event loop.
---------------------------------------------------------------------------------
-main :: IO ()
-main = do
-   -- Setup the basic GLUT stuff
-   (_, args) <- getArgsAndInitialize
-   opts <- parseOptions args
-   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]
-   (if useFullscreen opts then fullscreenMode else windowedMode) opts
-
-   initialize
-
-   -- Register the event callback functions
-   displayCallback $= do render; swapBuffers
-   reshapeCallback $= Just setupProjection
-   keyboardMouseCallback $= Just keyboardMouseHandler
-   -- No need for an idle callback here, this would just hog the CPU
-   -- without any visible effect
-
-   -- At this point, control is relinquished to the GLUT event handler.
-   -- Control is returned as events occur, via the callback functions.
-   mainLoop
-
-fullscreenMode :: Options -> IO ()
-fullscreenMode opts = do
-   let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :))
-   gameModeCapabilities $=
-      (addCapability GameModeWidth (Just (windowWidth  opts)) .
-       addCapability GameModeHeight (Just (windowHeight opts)) .
-       addCapability GameModeBitsPerPlane (bpp opts) .
-       addCapability GameModeRefreshRate (refreshRate opts)) []
-   _ <- enterGameMode
-   maybeWin <- get currentWindow
-   if isJust maybeWin
-      then cursor $= None
-      else do
-         hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n"
-         windowedMode (opts { useFullscreen = False } )
-
-windowedMode :: Options -> IO ()
-windowedMode opts = do
-   initialWindowSize $=
-      Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts))
-   _ <- createWindow "BOGLGP - Chapter 3 - TrianglesQuads"
-   return ()
-
---------------------------------------------------------------------------------
--- Option handling
---------------------------------------------------------------------------------
-data Options = Options {
-   useFullscreen :: Bool,
-   windowWidth   :: Int,
-   windowHeight  :: Int,
-   bpp           :: Maybe Int,
-   refreshRate   :: Maybe Int
-   }
-
-startOpt :: Options
-startOpt = Options {
-   useFullscreen = False,
-   windowWidth   = 800,
-   windowHeight  = 600,
-   bpp           = Nothing,
-   refreshRate   = Nothing
-   }
-
-options :: [OptDescr (Options -> IO Options)]
-options = [
-   Option ['f'] ["fullscreen"]
-      (NoArg (\opt -> return opt { useFullscreen = True }))
-      "use fullscreen mode if possible",
-   Option ['w'] ["width"]
-      (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg
-                              return opt { windowWidth = w })
-              "WIDTH")
-      "use window width WIDTH",
-   Option ['h'] ["height"]
-      (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg
-                              return opt { windowHeight = h })
-              "HEIGHT")
-      "use window height HEIGHT",
-   Option ['b'] ["bpp"]
-      (ReqArg (\arg opt -> do b <- readInt "BPP" arg
-                              return opt { bpp = Just b })
-              "BPP")
-      "use BPP bits per plane (ignored in windowed mode)",
-   Option ['r'] ["refresh-rate"]
-      (ReqArg (\arg opt -> do r <- readInt "HZ" arg
-                              return opt { refreshRate = Just r })
-              "HZ")
-      "use refresh rate HZ (ignored in windowed mode)",
-   Option ['?'] ["help"]
-      (NoArg (\_ -> do usage >>= putStr
-                       safeExitWith ExitSuccess))
-      "show help" ]
-
-readInt :: String -> String -> IO Int
-readInt name arg =
-   case reads arg of
-      ((x,[]) : _) -> return x
-      _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"]
-
-usage :: IO String
-usage = do
-   progName <- getProgName
-   return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options
-
-parseOptions :: [String] -> IO Options
-parseOptions args = do
-   let (optsActions, nonOptions, errs) = getOpt Permute options args
-   unless (null nonOptions && null errs) (dieWith errs)
-   foldl (>>=) (return startOpt) optsActions
-
-dieWith :: [String] -> IO a
-dieWith errs = do
-   u <- usage
-   mapM_ (hPutStr stderr) (errs ++ [u])
-   safeExitWith (ExitFailure 1)
-
---------------------------------------------------------------------------------
--- Handle mouse and keyboard events. For this simple demo, just exit when
--- ESCAPE is pressed.
---------------------------------------------------------------------------------
-keyboardMouseHandler :: KeyboardMouseCallback
-keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess
-keyboardMouseHandler _             _   _ _ = return ()
-
-safeExitWith :: ExitCode -> IO a
-safeExitWith code = do
-    gma <- get gameModeActive
-    when gma leaveGameMode
-    exitWith code
-
---------------------------------------------------------------------------------
--- Do one time setup, i.e. set the clear color.
---------------------------------------------------------------------------------
-initialize :: IO ()
-initialize = clearColor $= Color4 0 0 0 0
-
---------------------------------------------------------------------------------
--- Reset the viewport for window changes.
---------------------------------------------------------------------------------
-setupProjection :: ReshapeCallback
-setupProjection (Size width height) = do
-   -- don't want a divide by zero
-   let h = max 1 height
-   -- reset the viewport to new dimensions
-   viewport $= (Position 0 0, Size width h)
-   -- set projection matrix as the current matrix
-   matrixMode $= Projection
-   -- reset projection matrix
-   loadIdentity
-
-   -- calculate aspect ratio of window
-   perspective 52 (fromIntegral width / fromIntegral h) 1 1000
-
-   -- set modelview matrix
-   matrixMode $= Modelview 0
-   -- reset modelview matrix
-   loadIdentity
-
---------------------------------------------------------------------------------
--- Clear and redraw the scene.
---------------------------------------------------------------------------------
-render :: DisplayCallback
-render = do
-   -- clear screen and depth buffer
-   clear [ ColorBuffer, DepthBuffer ]
-   loadIdentity
-   lookAt (Vertex3 0 10 0.1) (Vertex3 0 0 0) (Vector3 0 1 0)
-
-   -- resolve overloading, not needed in "real" programs
-   let translate3f = translate :: Vector3 GLfloat -> IO ()
-
-   -- top left
-   preservingMatrix $ do
-      translate3f (Vector3 (-6) 0 (-4))
-      drawPoints
-
-   -- top middle
-   preservingMatrix $ do
-      polygonMode $= (Fill, Fill)
-      translate3f (Vector3 (-2) 0 (-4))
-      drawTriangles
-
-   -- top right
-   preservingMatrix $ do
-      polygonMode $= (Line, Line)
-      translate3f (Vector3 2 0 (-4))
-      drawQuads
-
-   -- bottom left
-   preservingMatrix $ do
-      polygonMode $= (Line, Line)
-      translate3f (Vector3 (-6) 0 0.5)
-      drawTriangleStrip
-
-   -- bottom middle
-   preservingMatrix $ do
-      polygonMode $= (Line, Line)
-      translate3f (Vector3 (-2) 0 0.5)
-      drawTriangleFan
-
-   -- bottom right
-   preservingMatrix $ do
-      polygonMode $= (Line, Line)
-      translate3f (Vector3 2 0 0.5)
-      drawQuadStrip
-
--- Hello, this is C... :-)
-for :: [GLfloat] -> (GLfloat -> IO ()) -> IO ()
-for = flip mapM_
-
--- draw grid of points showing dataset we are working with
-drawPoints :: IO ()
-drawPoints = do
-   pointSize $= 4
-   renderPrimitive Points $
-      for [ 0 .. 3 ] $ \x ->
-         for [ 0 .. 3 ] $ \z ->
-            vertex (Vertex3 x 0 z)
-
--- draw grid as individual triangles
-drawTriangles :: IO ()
-drawTriangles =
-   renderPrimitive Triangles $
-      for [ 0 .. 2 ] $ \x ->
-         for [ 0 .. 2 ] $ \z -> do
-            vertex (Vertex3  x      0  z     )
-            vertex (Vertex3 (x + 1) 0  z     )
-            vertex (Vertex3  x      0 (z + 1))
-
--- draw grid as triangle fan
-drawTriangleFan :: IO ()
-drawTriangleFan =
-   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)
-
-      -- right side
-      for [ 3, 2 .. 0 ] $ \z ->
-         vertex (Vertex3 3 0 z)
-
--- draw grid as triangle strips
-drawTriangleStrip :: IO ()
-drawTriangleStrip =
-   -- 3 rows of triangle strips
-   for [ 0 .. 2 ] $ \x ->
-      renderPrimitive TriangleStrip $
-         for [ 0 .. 2 ] $ \z -> do
-            vertex (Vertex3  x      0  z     )
-            vertex (Vertex3 (x + 1) 0  z     )
-            vertex (Vertex3  x      0 (z + 1))
-            vertex (Vertex3 (x + 1) 0 (z + 1))
-
--- draw grid as individual quads
-drawQuads :: IO ()
-drawQuads =
-   renderPrimitive Quads $
-      for [ 0 .. 2 ] $ \x ->
-         for [ 0 .. 2 ] $ \z -> do
-            vertex (Vertex3  x      0  z     )
-            vertex (Vertex3 (x + 1) 0  z     )
-            vertex (Vertex3 (x + 1) 0 (z + 1))
-            vertex (Vertex3  x      0 (z + 1))
-
--- draw grid as quad strips
-drawQuadStrip :: IO ()
-drawQuadStrip =
-   for [ 0 .. 2 ] $ \x ->
-      renderPrimitive QuadStrip $
-         for [ 0 .. 3 ] $ \z -> do
-            vertex (Vertex3  x      0 z)
-            vertex (Vertex3 (x + 1) 0 z)
+{-+   TrianglesQuads.hs (adapted from TrianglesQuads which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2004-2005 <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.Maybe ( isJust )+import Graphics.UI.GLUT hiding ( initialize )+import System.Console.GetOpt+import System.Environment ( getProgName )+import System.Exit ( exitWith, ExitCode(..) )+import System.IO ( hPutStr, stderr )++--------------------------------------------------------------------------------+-- Setup GLUT and OpenGL, drop into the event loop.+--------------------------------------------------------------------------------+main :: IO ()+main = do+   -- Setup the basic GLUT stuff+   (_, args) <- getArgsAndInitialize+   opts <- parseOptions args+   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]+   (if useFullscreen opts then fullscreenMode else windowedMode) opts++   initialize++   -- Register the event callback functions+   displayCallback $= do render; swapBuffers+   reshapeCallback $= Just setupProjection+   keyboardMouseCallback $= Just keyboardMouseHandler+   -- No need for an idle callback here, this would just hog the CPU+   -- without any visible effect++   -- At this point, control is relinquished to the GLUT event handler.+   -- Control is returned as events occur, via the callback functions.+   mainLoop++fullscreenMode :: Options -> IO ()+fullscreenMode opts = do+   let addCapability c = maybe id (\x -> (Where' c IsEqualTo x :))+   gameModeCapabilities $=+      (addCapability GameModeWidth (Just (windowWidth  opts)) .+       addCapability GameModeHeight (Just (windowHeight opts)) .+       addCapability GameModeBitsPerPlane (bpp opts) .+       addCapability GameModeRefreshRate (refreshRate opts)) []+   _ <- enterGameMode+   maybeWin <- get currentWindow+   if isJust maybeWin+      then cursor $= None+      else do+         hPutStr stderr "Could not enter fullscreen mode, using windowed mode\n"+         windowedMode (opts { useFullscreen = False } )++windowedMode :: Options -> IO ()+windowedMode opts = do+   initialWindowSize $=+      Size (fromIntegral (windowWidth opts)) (fromIntegral (windowHeight opts))+   _ <- createWindow "BOGLGP - Chapter 3 - TrianglesQuads"+   return ()++--------------------------------------------------------------------------------+-- Option handling+--------------------------------------------------------------------------------+data Options = Options {+   useFullscreen :: Bool,+   windowWidth   :: Int,+   windowHeight  :: Int,+   bpp           :: Maybe Int,+   refreshRate   :: Maybe Int+   }++startOpt :: Options+startOpt = Options {+   useFullscreen = False,+   windowWidth   = 800,+   windowHeight  = 600,+   bpp           = Nothing,+   refreshRate   = Nothing+   }++options :: [OptDescr (Options -> IO Options)]+options = [+   Option ['f'] ["fullscreen"]+      (NoArg (\opt -> return opt { useFullscreen = True }))+      "use fullscreen mode if possible",+   Option ['w'] ["width"]+      (ReqArg (\arg opt -> do w <- readInt "WIDTH" arg+                              return opt { windowWidth = w })+              "WIDTH")+      "use window width WIDTH",+   Option ['h'] ["height"]+      (ReqArg (\arg opt -> do h <- readInt "HEIGHT" arg+                              return opt { windowHeight = h })+              "HEIGHT")+      "use window height HEIGHT",+   Option ['b'] ["bpp"]+      (ReqArg (\arg opt -> do b <- readInt "BPP" arg+                              return opt { bpp = Just b })+              "BPP")+      "use BPP bits per plane (ignored in windowed mode)",+   Option ['r'] ["refresh-rate"]+      (ReqArg (\arg opt -> do r <- readInt "HZ" arg+                              return opt { refreshRate = Just r })+              "HZ")+      "use refresh rate HZ (ignored in windowed mode)",+   Option ['?'] ["help"]+      (NoArg (\_ -> do usage >>= putStr+                       safeExitWith ExitSuccess))+      "show help" ]++readInt :: String -> String -> IO Int+readInt name arg =+   case reads arg of+      ((x,[]) : _) -> return x+      _ -> dieWith ["Can't parse " ++ name ++ " argument '" ++ arg ++ "'\n"]++usage :: IO String+usage = do+   progName <- getProgName+   return $ usageInfo ("Usage: " ++ progName ++ " [OPTION...]") options++parseOptions :: [String] -> IO Options+parseOptions args = do+   let (optsActions, nonOptions, errs) = getOpt Permute options args+   unless (null nonOptions && null errs) (dieWith errs)+   foldl (>>=) (return startOpt) optsActions++dieWith :: [String] -> IO a+dieWith errs = do+   u <- usage+   mapM_ (hPutStr stderr) (errs ++ [u])+   safeExitWith (ExitFailure 1)++--------------------------------------------------------------------------------+-- Handle mouse and keyboard events. For this simple demo, just exit when+-- ESCAPE is pressed.+--------------------------------------------------------------------------------+keyboardMouseHandler :: KeyboardMouseCallback+keyboardMouseHandler (Char '\27') Down _ _ = safeExitWith ExitSuccess+keyboardMouseHandler _             _   _ _ = return ()++safeExitWith :: ExitCode -> IO a+safeExitWith code = do+    gma <- get gameModeActive+    when gma leaveGameMode+    exitWith code++--------------------------------------------------------------------------------+-- Do one time setup, i.e. set the clear color.+--------------------------------------------------------------------------------+initialize :: IO ()+initialize = clearColor $= Color4 0 0 0 0++--------------------------------------------------------------------------------+-- Reset the viewport for window changes.+--------------------------------------------------------------------------------+setupProjection :: ReshapeCallback+setupProjection (Size width height) = do+   -- don't want a divide by zero+   let h = max 1 height+   -- reset the viewport to new dimensions+   viewport $= (Position 0 0, Size width h)+   -- set projection matrix as the current matrix+   matrixMode $= Projection+   -- reset projection matrix+   loadIdentity++   -- calculate aspect ratio of window+   perspective 52 (fromIntegral width / fromIntegral h) 1 1000++   -- set modelview matrix+   matrixMode $= Modelview 0+   -- reset modelview matrix+   loadIdentity++--------------------------------------------------------------------------------+-- Clear and redraw the scene.+--------------------------------------------------------------------------------+render :: DisplayCallback+render = do+   -- clear screen and depth buffer+   clear [ ColorBuffer, DepthBuffer ]+   loadIdentity+   lookAt (Vertex3 0 10 0.1) (Vertex3 0 0 0) (Vector3 0 1 0)++   -- resolve overloading, not needed in "real" programs+   let translate3f = translate :: Vector3 GLfloat -> IO ()++   -- top left+   preservingMatrix $ do+      translate3f (Vector3 (-6) 0 (-4))+      drawPoints++   -- top middle+   preservingMatrix $ do+      polygonMode $= (Fill, Fill)+      translate3f (Vector3 (-2) 0 (-4))+      drawTriangles++   -- top right+   preservingMatrix $ do+      polygonMode $= (Line, Line)+      translate3f (Vector3 2 0 (-4))+      drawQuads++   -- bottom left+   preservingMatrix $ do+      polygonMode $= (Line, Line)+      translate3f (Vector3 (-6) 0 0.5)+      drawTriangleStrip++   -- bottom middle+   preservingMatrix $ do+      polygonMode $= (Line, Line)+      translate3f (Vector3 (-2) 0 0.5)+      drawTriangleFan++   -- bottom right+   preservingMatrix $ do+      polygonMode $= (Line, Line)+      translate3f (Vector3 2 0 0.5)+      drawQuadStrip++-- Hello, this is C... :-)+for :: [GLfloat] -> (GLfloat -> IO ()) -> IO ()+for = flip mapM_++-- draw grid of points showing dataset we are working with+drawPoints :: IO ()+drawPoints = do+   pointSize $= 4+   renderPrimitive Points $+      for [ 0 .. 3 ] $ \x ->+         for [ 0 .. 3 ] $ \z ->+            vertex (Vertex3 x 0 z)++-- draw grid as individual triangles+drawTriangles :: IO ()+drawTriangles =+   renderPrimitive Triangles $+      for [ 0 .. 2 ] $ \x ->+         for [ 0 .. 2 ] $ \z -> do+            vertex (Vertex3  x      0  z     )+            vertex (Vertex3 (x + 1) 0  z     )+            vertex (Vertex3  x      0 (z + 1))++-- draw grid as triangle fan+drawTriangleFan :: IO ()+drawTriangleFan =+   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)++      -- right side+      for [ 3, 2 .. 0 ] $ \z ->+         vertex (Vertex3 3 0 z)++-- draw grid as triangle strips+drawTriangleStrip :: IO ()+drawTriangleStrip =+   -- 3 rows of triangle strips+   for [ 0 .. 2 ] $ \x ->+      renderPrimitive TriangleStrip $+         for [ 0 .. 2 ] $ \z -> do+            vertex (Vertex3  x      0  z     )+            vertex (Vertex3 (x + 1) 0  z     )+            vertex (Vertex3  x      0 (z + 1))+            vertex (Vertex3 (x + 1) 0 (z + 1))++-- draw grid as individual quads+drawQuads :: IO ()+drawQuads =+   renderPrimitive Quads $+      for [ 0 .. 2 ] $ \x ->+         for [ 0 .. 2 ] $ \z -> do+            vertex (Vertex3  x      0  z     )+            vertex (Vertex3 (x + 1) 0  z     )+            vertex (Vertex3 (x + 1) 0 (z + 1))+            vertex (Vertex3  x      0 (z + 1))++-- draw grid as quad strips+drawQuadStrip :: IO ()+drawQuadStrip =+   for [ 0 .. 2 ] $ \x ->+      renderPrimitive QuadStrip $+         for [ 0 .. 3 ] $ \z -> do+            vertex (Vertex3  x      0 z)+            vertex (Vertex3 (x + 1) 0 z)

examples/BOGLGP/Makefile view

@@ -1,2 +1,2 @@-SUBDIRS := $(wildcard Chapter*)
-include ../examples.mk
+SUBDIRS := $(wildcard Chapter*)+include ../examples.mk

examples/Makefile view

@@ -1,2 +1,2 @@-SUBDIRS := BOGLGP Misc OrangeBook RedBook4 RedBook8
-include examples.mk
+SUBDIRS := BOGLGP Misc OrangeBook RedBook4 RedBook8+include examples.mk

+ 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,193 +1,193 @@-{-
-   ARBOcclude.hs (adapted from arbocclude.c which is (c) Brian Paul)
-   Copyright (c) Sven Panne 2002-2005 <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, when )
-import Data.IORef ( IORef, newIORef )
-import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure )
-import Graphics.UI.GLUT
-
-data State = State {
-   anim     :: IORef Bool,
-   xPos     :: IORef GLfloat,
-   sign     :: IORef GLfloat,
-   lastTime :: IORef Int }
-
-makeState :: IO State
-makeState = do
-   a <- newIORef True
-   x <- newIORef 0
-   s <- newIORef 1
-   l <- newIORef =<< get elapsedTime
-   return $ State { anim = a, xPos = x, sign = s, lastTime = l }
-
-petrol, orange, white :: Color3 GLfloat
-petrol = Color3 0.0 0.6 0.8
-orange = Color3 0.8 0.5 0.0
-white  = Color3 1.0 1.0 1.0
-
-printString :: Vertex2 GLfloat -> String -> IO ()
-printString pos s = do
-   color white
-   rasterPos pos
-   renderString Fixed8By13 s
-
-idle :: State -> IdleCallback
-idle state = do
-   time <- get elapsedTime
-   l <- get (lastTime state)
-   let timeDiff = fromIntegral (time - l)
-
-   when (timeDiff >= 20) $ do -- 50Hz update
-      lastTime state $= time
-
-      s <- get (sign state)
-      step state (timeDiff / 1000 * s)
-      x <- get (xPos state)
-
-      when (x > 2.5) $ do
-         xPos state $= 2.5
-         sign state $= (-1)
-
-      when (x < -2.5) $ do
-         xPos state $= (-2.5)
-         sign state $= 1
-
-display :: QueryObject -> State -> DisplayCallback
-display occQuery state = do
-   clear [ ColorBuffer, DepthBuffer ]
-
-   matrixMode $= Projection
-   loadIdentity
-   frustum (-1) 1 (-1) 1 5 25
-   matrixMode $= Modelview 0
-   loadIdentity
-   translate (Vector3 0 0 (-15 :: GLfloat))
-
-   drawOccludingPolygons
-
-   -- draw the test polygon with occlusion testing
-   passed <- preservingMatrix $ do
-      x <- get (xPos state)
-      translate (Vector3 x 0 (-0.5))
-      scale 0.3 0.3 (1.0 :: GLfloat)
-      rotate (-90 * x) (Vector3 0 0 1)
-
-      withQuery SamplesPassed occQuery $ do
-         colorMask $= Color4 Disabled Disabled Disabled Disabled
-         depthMask $= Disabled
-         drawRect
-
-      p <- waitForResult occQuery
-
-      -- turn off occlusion testing
-      colorMask $= Color4 Enabled Enabled Enabled Enabled
-      depthMask $= Enabled
-
-      -- draw the orange rect, so we can see what's going on
-      color orange
-      drawRect
-
-      return p
-
-   -- Print result message
-   matrixMode $= Projection
-   loadIdentity
-   ortho (-1) 1 (-1) 1 (-1) 1
-   matrixMode $= Modelview 0
-   loadIdentity
-
-   printString (Vertex2 (-0.50) (-0.7))
-      (" " ++ flushRight 4 passed ++ " Fragments Visible")
-   when (passed == 0) $
-      printString (Vertex2 (-0.25) (-0.8)) "Fully Occluded"
-
-   swapBuffers
-
-drawOccludingPolygons :: IO ()
-drawOccludingPolygons = do
-   color petrol
-   drawQuads [
-      Vertex2 (-1.6) (-1.5),
-      Vertex2 (-0.4) (-1.5),
-      Vertex2 (-0.4)   1.5 ,
-      Vertex2 (-1.6)   1.5 ,
-
-      Vertex2   0.4  (-1.5),
-      Vertex2   1.6  (-1.5),
-      Vertex2   1.6    1.5 ,
-      Vertex2   0.4    1.5 ]
-
-drawRect :: IO ()
-drawRect = do
-   drawQuads [
-      Vertex2 (-1) (-1),
-      Vertex2   1  (-1),
-      Vertex2   1    1 ,
-      Vertex2 (-1)   1 ]
-
-drawQuads :: [Vertex2 GLfloat] -> IO ()
-drawQuads = renderPrimitive Quads . mapM_ vertex
-
-waitForResult :: QueryObject -> IO GLuint
-waitForResult occQuery = do
-   let loop = do -- do useful work here, if any
-                 ready <- get (queryResultAvailable occQuery)
-                 unless ready loop
-   loop
-   get (queryResult occQuery)
-
-flushRight :: Show a => Int -> a -> String
-flushRight width x = replicate (width - length s) ' ' ++ s
-   where s = show x
-
-keyboard :: State -> KeyboardMouseCallback
-keyboard _     (Char '\27')          Down _ _ = exitWith ExitSuccess
-keyboard state (Char ' ')            Down _ _ = do anim state $~ not
-                                                   setIdleCallback state
-keyboard state (SpecialKey KeyLeft)  Down _ _ = step state (-0.1)
-keyboard state (SpecialKey KeyRight) Down _ _ = step state   0.1
-keyboard _     _                     _    _ _ = return ()
-
-setIdleCallback :: State -> IO ()
-setIdleCallback state = do
-   a <- get (anim state)
-   idleCallback $= if a then Just (idle state) else Nothing
-
-step :: State -> GLfloat -> IO ()
-step state s = do
-   xPos state $~ (+ s)
-   postRedisplay Nothing
-
-myInit :: IO ()
-myInit = do
-   exts <- get glExtensions
-   unless ("GL_ARB_occlusion_query" `elem` exts) $ do
-      putStrLn "Sorry, this demo requires the GL_ARB_occlusion_query extension."
-      exitFailure
-
-   bits <- get (queryCounterBits SamplesPassed)
-   unless (bits > 0) $ do
-      putStrLn "Hmmm, GL_QUERY_COUNTER_BITS_ARB is zero!"
-      exitFailure
-
-   depthFunc $= Just Less
-
-main :: IO ()
-main = do
-   (progName, _args) <- getArgsAndInitialize
-   initialWindowPosition $= Position 0 0
-   initialWindowSize $= Size 400 400
-   initialDisplayMode $= [ RGBMode, DoubleBuffered, WithDepthBuffer ]
-   _ <- createWindow progName
-   state <- makeState
-   reshapeCallback $= Just (\size -> viewport $= (Position 0 0, size))
-   keyboardMouseCallback $= Just (keyboard state)
-   setIdleCallback state
-   occQuery <- genObjectName
-   displayCallback $= display occQuery state
-   myInit
-   mainLoop
+{-+   ARBOcclude.hs (adapted from arbocclude.c which is (c) Brian Paul)+   Copyright (c) Sven Panne 2002-2005 <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, when )+import Data.IORef ( IORef, newIORef )+import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure )+import Graphics.UI.GLUT++data State = State {+   anim     :: IORef Bool,+   xPos     :: IORef GLfloat,+   sign     :: IORef GLfloat,+   lastTime :: IORef Int }++makeState :: IO State+makeState = do+   a <- newIORef True+   x <- newIORef 0+   s <- newIORef 1+   l <- newIORef =<< get elapsedTime+   return $ State { anim = a, xPos = x, sign = s, lastTime = l }++petrol, orange, white :: Color3 GLfloat+petrol = Color3 0.0 0.6 0.8+orange = Color3 0.8 0.5 0.0+white  = Color3 1.0 1.0 1.0++printString :: Vertex2 GLfloat -> String -> IO ()+printString pos s = do+   color white+   rasterPos pos+   renderString Fixed8By13 s++idle :: State -> IdleCallback+idle state = do+   time <- get elapsedTime+   l <- get (lastTime state)+   let timeDiff = fromIntegral (time - l)++   when (timeDiff >= 20) $ do -- 50Hz update+      lastTime state $= time++      s <- get (sign state)+      step state (timeDiff / 1000 * s)+      x <- get (xPos state)++      when (x > 2.5) $ do+         xPos state $= 2.5+         sign state $= (-1)++      when (x < -2.5) $ do+         xPos state $= (-2.5)+         sign state $= 1++display :: QueryObject -> State -> DisplayCallback+display occQuery state = do+   clear [ ColorBuffer, DepthBuffer ]++   matrixMode $= Projection+   loadIdentity+   frustum (-1) 1 (-1) 1 5 25+   matrixMode $= Modelview 0+   loadIdentity+   translate (Vector3 0 0 (-15 :: GLfloat))++   drawOccludingPolygons++   -- draw the test polygon with occlusion testing+   passed <- preservingMatrix $ do+      x <- get (xPos state)+      translate (Vector3 x 0 (-0.5))+      scale 0.3 0.3 (1.0 :: GLfloat)+      rotate (-90 * x) (Vector3 0 0 1)++      withQuery SamplesPassed occQuery $ do+         colorMask $= Color4 Disabled Disabled Disabled Disabled+         depthMask $= Disabled+         drawRect++      p <- waitForResult occQuery++      -- turn off occlusion testing+      colorMask $= Color4 Enabled Enabled Enabled Enabled+      depthMask $= Enabled++      -- draw the orange rect, so we can see what's going on+      color orange+      drawRect++      return p++   -- Print result message+   matrixMode $= Projection+   loadIdentity+   ortho (-1) 1 (-1) 1 (-1) 1+   matrixMode $= Modelview 0+   loadIdentity++   printString (Vertex2 (-0.50) (-0.7))+      (" " ++ flushRight 4 passed ++ " Fragments Visible")+   when (passed == 0) $+      printString (Vertex2 (-0.25) (-0.8)) "Fully Occluded"++   swapBuffers++drawOccludingPolygons :: IO ()+drawOccludingPolygons = do+   color petrol+   drawQuads [+      Vertex2 (-1.6) (-1.5),+      Vertex2 (-0.4) (-1.5),+      Vertex2 (-0.4)   1.5 ,+      Vertex2 (-1.6)   1.5 ,++      Vertex2   0.4  (-1.5),+      Vertex2   1.6  (-1.5),+      Vertex2   1.6    1.5 ,+      Vertex2   0.4    1.5 ]++drawRect :: IO ()+drawRect = do+   drawQuads [+      Vertex2 (-1) (-1),+      Vertex2   1  (-1),+      Vertex2   1    1 ,+      Vertex2 (-1)   1 ]++drawQuads :: [Vertex2 GLfloat] -> IO ()+drawQuads = renderPrimitive Quads . mapM_ vertex++waitForResult :: QueryObject -> IO GLuint+waitForResult occQuery = do+   let loop = do -- do useful work here, if any+                 ready <- get (queryResultAvailable occQuery)+                 unless ready loop+   loop+   get (queryResult occQuery)++flushRight :: Show a => Int -> a -> String+flushRight width x = replicate (width - length s) ' ' ++ s+   where s = show x++keyboard :: State -> KeyboardMouseCallback+keyboard _     (Char '\27')          Down _ _ = exitWith ExitSuccess+keyboard state (Char ' ')            Down _ _ = do anim state $~ not+                                                   setIdleCallback state+keyboard state (SpecialKey KeyLeft)  Down _ _ = step state (-0.1)+keyboard state (SpecialKey KeyRight) Down _ _ = step state   0.1+keyboard _     _                     _    _ _ = return ()++setIdleCallback :: State -> IO ()+setIdleCallback state = do+   a <- get (anim state)+   idleCallback $= if a then Just (idle state) else Nothing++step :: State -> GLfloat -> IO ()+step state s = do+   xPos state $~ (+ s)+   postRedisplay Nothing++myInit :: IO ()+myInit = do+   exts <- get glExtensions+   unless ("GL_ARB_occlusion_query" `elem` exts) $ do+      putStrLn "Sorry, this demo requires the GL_ARB_occlusion_query extension."+      exitFailure++   bits <- get (queryCounterBits SamplesPassed)+   unless (bits > 0) $ do+      putStrLn "Hmmm, GL_QUERY_COUNTER_BITS_ARB is zero!"+      exitFailure++   depthFunc $= Just Less++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialWindowPosition $= Position 0 0+   initialWindowSize $= Size 400 400+   initialDisplayMode $= [ RGBMode, DoubleBuffered, WithDepthBuffer ]+   _ <- createWindow progName+   state <- makeState+   reshapeCallback $= Just (\size -> viewport $= (Position 0 0, size))+   keyboardMouseCallback $= Just (keyboard state)+   setIdleCallback state+   occQuery <- genObjectName+   displayCallback $= display occQuery state+   myInit+   mainLoop

examples/Misc/ExtractContours.hs view

@@ -1,117 +1,117 @@-{-
-   ExtractContours.hs (adapted from tess.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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 contour extraction. 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 $
-      drawPolygonContours (\_ -> return ()) =<<
-         extractContours TessWindingOdd 0 (Normal3 0 0 0) noOpCombiner rectAndTri
-
-   starList <- defineNewList Compile $
-      drawPolygonContours color =<<
-         extractContours TessWindingPositive 0 (Normal3 0 0 0) combineColors star
-
-   return [ rectAndTriList, starList ]
-
-drawPolygonContours :: (v -> IO ()) -> PolygonContours v -> IO ()
-drawPolygonContours colorHandler (PolygonContours simpleContours) =
-   flip mapM_ simpleContours $ \(SimpleContour vertices) ->
-      renderPrimitive LineLoop $
-         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
+{-+   ExtractContours.hs (adapted from tess.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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 contour extraction. 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 $+      drawPolygonContours (\_ -> return ()) =<<+         extractContours TessWindingOdd 0 (Normal3 0 0 0) noOpCombiner rectAndTri++   starList <- defineNewList Compile $+      drawPolygonContours color =<<+         extractContours TessWindingPositive 0 (Normal3 0 0 0) combineColors star++   return [ rectAndTriList, starList ]++drawPolygonContours :: (v -> IO ()) -> PolygonContours v -> IO ()+drawPolygonContours colorHandler (PolygonContours simpleContours) =+   flip mapM_ simpleContours $ \(SimpleContour vertices) ->+      renderPrimitive LineLoop $+         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/Misc/Gears.hs view

@@ -1,301 +1,301 @@-{-
-   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 <svenpanne@gmail.com>
-   This file is part of HOpenGL and distributed under a BSD-style license
-   See the file libraries/GLUT/LICENSE
-
-   Command line options:
-     -info      print GL implementation information
-     -exit      automatically exit after 30 seconds
--}
-
---------------------------------------------------------------------------------
-
-import Control.Monad ( when )
-import Data.IORef ( IORef, newIORef )
-import Data.List ( intersperse )
-import System.Console.GetOpt
-import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure )
-import Graphics.UI.GLUT
-
---------------------------------------------------------------------------------
-
-type View = (GLfloat, GLfloat, GLfloat)
-
-data State = State {
-   frames  :: IORef Int,
-   t0      :: IORef Int,
-   viewRot :: IORef View,
-   angle'  :: IORef GLfloat }
-
-makeState :: IO State
-makeState = do
-   f <- newIORef 0
-   t <- newIORef 0
-   v <- newIORef (20, 30, 0)
-   a <- newIORef 0
-   return $ State { frames = f, t0 = t, viewRot = v, angle' = a }
-
---  Draw a gear wheel.  You'll probably want to call this function when
---  building a display list since we do a lot of trig here.
---
---  Input: innerRadius - radius of hole at center
---         outerRadius - radius at center of teeth
---         width - width of gear
---         teeth - number of teeth
---         toothDepth - depth of tooth
-
-gear :: GLfloat -> GLfloat -> GLfloat -> GLint -> GLfloat -> IO ()
-gear innerRadius outerRadius width teeth toothDepth = do
-   let r0 = innerRadius
-       r1 = outerRadius - toothDepth / 2
-       r2 = outerRadius + toothDepth / 2
-
-       da = 2 * pi / fromIntegral teeth / 4
-       w  = 0.5 * width
-
-       render p f =
-          renderPrimitive p $
-             mapM_ (\i -> let angle = fromIntegral i * 2 * pi / fromIntegral teeth
-                              in f r0 r1 r2 w da teeth i angle)
-                   [ 0 .. teeth ]
-
-   shadeModel $= Flat
-   currentNormal $= Normal3 0 0 1
-   render QuadStrip gearFront
-   render Quads     teethFront
-   currentNormal $= Normal3 0 0 (-1)
-   render QuadStrip gearBack
-   render Quads     teethBack
-   render QuadStrip teethFace
-   shadeModel $= Smooth
-   render QuadStrip gearInside
-
-type Renderer =
-   GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLint -> GLint -> GLfloat -> IO ()
-
--- draw front face
-gearFront :: Renderer
-gearFront r0 r1 _ w da teeth i angle = do
-   vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) w)
-   vertex (Vertex3 (r1 * cos angle) (r1 * sin angle) w)
-   when (i < teeth) $ do
-      vertex (Vertex3 (r0 * cos  angle          ) (r0 * sin  angle          ) w)
-      vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) w)
-
--- draw front sides of teeth
-teethFront :: Renderer
-teethFront _ r1 r2 w da teeth i angle =
-   when (i < teeth) $ do
-      vertex (Vertex3 (r1 * cos  angle          ) (r1 * sin  angle          ) w)
-      vertex (Vertex3 (r2 * cos (angle +     da)) (r2 * sin (angle +     da)) w)
-      vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) w)
-      vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) w)
-
--- draw back face
-gearBack :: Renderer
-gearBack r0 r1 _ w da teeth i angle = do
-   vertex (Vertex3 (r1 * cos angle) (r1 * sin angle) (-w))
-   vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) (-w))
-   when (i < teeth) $ do
-      vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) (-w))
-      vertex (Vertex3 (r0 * cos  angle          ) (r0 * sin  angle          ) (-w))
-
--- draw back sides of teeth
-teethBack :: Renderer
-teethBack _ r1 r2 w da teeth i angle =
-   when (i < teeth) $ do
-      vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) (-w))
-      vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) (-w))
-      vertex (Vertex3 (r2 * cos (angle +     da)) (r2 * sin (angle +     da)) (-w))
-      vertex (Vertex3 (r1 * cos  angle          ) (r1 * sin  angle          ) (-w))
-
--- draw outward faces of teeth
-teethFace :: Renderer
-teethFace _ r1 r2 w da teeth i angle =
-  if (i < teeth) then do
-    vertex (Vertex3 (r1*(cos angle)) (r1*(sin angle)) w)
-    vertex (Vertex3 (r1*(cos angle)) (r1*(sin angle)) (-w))
-
-    let u'    = r2 * cos (angle + da) - r1 * cos angle
-        v'    = r2 * sin (angle + da) - r1 * sin angle
-        len   = sqrt (u' * u' + v' * v')
-        u     = u' / len
-        v     = v' / len
-    currentNormal $= Normal3 v (-u) 0
-    vertex (Vertex3 (r2 * cos (angle +     da)) (r2 * sin (angle +     da))   w )
-    vertex (Vertex3 (r2 * cos (angle +     da)) (r2 * sin (angle +     da)) (-w))
-    currentNormal $= Normal3 (cos angle) (sin angle) 0
-    vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da))   w )
-    vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) (-w))
-    let u2    = r1 * cos (angle + 3 * da) - r2 * cos (angle + 2 * da);
-        v2    = r1 * sin (angle + 3 * da) - r2 * sin (angle + 2 * da);
-    currentNormal $= Normal3 v2 (-u2) 0
-    vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da))   w )
-    vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) (-w))
-    currentNormal $= Normal3 (cos angle) (sin angle) 0
-  else do
-    vertex (Vertex3 (r1 * cos 0) (r1 * sin 0)   w )
-    vertex (Vertex3 (r1 * cos 0) (r1 * sin 0) (-w))
-
--- draw inside radius cylinder
-gearInside :: Renderer
-gearInside r0 _ _ w _ _ _ angle = do
-   currentNormal $= Normal3 (-cos angle) (-sin angle) 0
-   vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) (-w))
-   vertex (Vertex3 (r0 * cos angle) (r0 * sin angle)   w )
-
-draw :: (DisplayList,DisplayList,DisplayList,Int) -> State -> IO ()
-draw (gear1, gear2, gear3, autoexit) state = do
-   clear [ ColorBuffer, DepthBuffer ]
-   (x, y, z) <- get (viewRot state)
-   a <- get (angle' state)
-
-   let translatef = translate :: Vector3 GLfloat -> IO ()
-   preservingMatrix $ do
-      rotate x (Vector3 1 0 0)
-      rotate y (Vector3 0 1 0)
-      rotate z (Vector3 0 0 1)
-
-      preservingMatrix $ do
-         translatef (Vector3 (-3) (-2) 0)
-         rotate a (Vector3 0 0 1)
-         callList gear1
-
-      preservingMatrix $ do
-         translatef (Vector3 3.1 (-2) 0)
-         rotate (-2 * a - 9) (Vector3 0 0 1)
-         callList gear2
-
-      preservingMatrix $ do
-         translatef (Vector3 (-3.1) 4.2 0)
-         rotate (-2 * a - 25) (Vector3 0 0 1)
-         callList gear3
-
-   swapBuffers
-   frames state $~! (+1)
-   t0' <- get (t0 state)
-   t <- get elapsedTime
-   when (t - t0' >= 5000) $ do
-      f <- get (frames state)
-      let seconds = fromIntegral (t - t0') / 1000 :: GLfloat
-          fps = fromIntegral f / seconds
-      putStrLn (show f ++ " frames in " ++ show seconds ++ " seconds = "++ show fps ++ " FPS")
-      t0 state $= t
-      frames state $= 0
-      when ((t >= 999 * autoexit) && (autoexit /= 0)) $
-         exitWith ExitSuccess
-
-idle :: State -> IdleCallback
-idle state = do
-   angle' state $~! (+2)
-   postRedisplay Nothing
-
-keyboard :: State -> KeyboardMouseCallback
-keyboard state (Char 'z')           _ _ _ = modRot state ( 0,  0,  5)
-keyboard state (Char 'Z')           _ _ _ = modRot state ( 0,  0, -5)
-keyboard state (SpecialKey KeyUp)   _ _ _ = modRot state ( 5,  0,  0)
-keyboard state (SpecialKey KeyDown) _ _ _ = modRot state (-5,  0,  0)
-keyboard state (SpecialKey KeyLeft) _ _ _ = modRot state ( 0,  5,  0)
-keyboard state (SpecialKey KeyRight)_ _ _ = modRot state ( 0, -5,  0)
-keyboard _     (Char '\27')         _ _ _ = exitWith ExitSuccess
-keyboard _     _                    _ _ _ = return ()
-
-modRot :: State -> View -> IO ()
-modRot state (dx,dy,dz) = do
-   (x, y, z) <- get (viewRot state)
-   viewRot state $= (x + dx, y + dy, z + dz)
-   postRedisplay Nothing
-
--- new window size or exposure
-reshape :: ReshapeCallback
-reshape s@(Size width height) = do
-   let h = fromIntegral height / fromIntegral width
-
-   viewport $= (Position 0 0, s)
-   matrixMode $= Projection
-   loadIdentity
-   frustum (-1) 1 (-h) h 5 60
-   matrixMode $= Modelview 0
-   loadIdentity
-   translate (Vector3 0 0 (-40 :: GLfloat))
-
-data Flag = GLInfo | AutoExit deriving ( Eq, Ord, Show )
-
-argInfo :: [OptDescr Flag]
-argInfo  = [
-   Option ['i'] ["info"] (NoArg GLInfo)   "print gl information",
-   Option ['e'] ["exit"] (NoArg AutoExit) "auto exit after 30 seconds" ]
-
-opts :: [String] -> IO [Flag]
-opts args =
-   case getOpt Permute argInfo args of
-      (o,_,[])   -> return o
-      (_,_,errs) -> do
-         putStr (concat errs ++ usageInfo "Usage: Gears [OPTION...]" argInfo)
-         exitFailure
-
-info :: IO ()
-info = do
-   rendererStr <- get renderer
-   putStrLn ("GL_RENDERER   = " ++ rendererStr)
-   vendorStr <- get vendor
-   putStrLn ("GL_VENDOR     = " ++ vendorStr)
-   versionStr <- get glVersion
-   putStrLn ("GL_VERSION    = " ++ versionStr)
-   exts <- get glExtensions
-   putStrLn ("GL_EXTENSIONS = " ++ concat (intersperse " " exts))
-
-myInit :: [String] -> IO (DisplayList,DisplayList,DisplayList,Int)
-myInit args = do
-   position (Light 0) $= Vertex4 5 5 10 0
-   cullFace $= Just Back
-   lighting $= Enabled
-   light (Light 0) $= Enabled
-   depthFunc $= Just Less
-
-   -- make the gears
-   g1 <- defineNewList Compile $ do
-      materialAmbientAndDiffuse Front $= Color4 0.8 0.1 0.0 1.0
-      gear 1 4 1 20 0.7
-
-   g2 <- defineNewList Compile $ do
-      materialAmbientAndDiffuse Front $= Color4 0.0 0.8 0.2 1.0
-      gear 0.5 2 2 10 0.7
-
-   g3 <- defineNewList Compile $ do
-      materialAmbientAndDiffuse Front $= Color4 0.2 0.2 1.0 1.0
-      gear 1.3 2 0.5 10 0.7
-
-   normalize $= Enabled
-
-   flags <- opts args
-   when (GLInfo `elem` flags) info
-   let autoexit = if AutoExit `elem` flags then 30 else 0
-   when (autoexit /= 0) $
-      putStrLn ("Auto Exit after " ++ show autoexit ++ " seconds.")
-
-   return (g1, g2, g3, autoexit)
-
-visible :: State -> Visibility -> IO ()
-visible state Visible    = idleCallback $= Just (idle state)
-visible _     NotVisible = idleCallback $= Nothing
-
-main :: IO ()
-main  = do
-   (_progName, args) <- getArgsAndInitialize
-   initialDisplayMode $= [ RGBMode, WithDepthBuffer, DoubleBuffered ]
-
-   initialWindowPosition $= Position 0 0
-   initialWindowSize $= Size 300 300
-   _ <- createWindow "Gears"
-   state <- makeState
-   gearsAndAuto <- myInit args
-
-   displayCallback $= draw gearsAndAuto state
-   reshapeCallback $= Just reshape
-   keyboardMouseCallback $= Just (keyboard state)
-   visibilityCallback $= Just (visible state)
-
-   mainLoop
+{-+   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 <svenpanne@gmail.com>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   Command line options:+     -info      print GL implementation information+     -exit      automatically exit after 30 seconds+-}++--------------------------------------------------------------------------------++import Control.Monad ( when )+import Data.IORef ( IORef, newIORef )+import Data.List ( intersperse )+import System.Console.GetOpt+import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure )+import Graphics.UI.GLUT++--------------------------------------------------------------------------------++type View = (GLfloat, GLfloat, GLfloat)++data State = State {+   frames  :: IORef Int,+   t0      :: IORef Int,+   viewRot :: IORef View,+   angle'  :: IORef GLfloat }++makeState :: IO State+makeState = do+   f <- newIORef 0+   t <- newIORef 0+   v <- newIORef (20, 30, 0)+   a <- newIORef 0+   return $ State { frames = f, t0 = t, viewRot = v, angle' = a }++--  Draw a gear wheel.  You'll probably want to call this function when+--  building a display list since we do a lot of trig here.+--+--  Input: innerRadius - radius of hole at center+--         outerRadius - radius at center of teeth+--         width - width of gear+--         teeth - number of teeth+--         toothDepth - depth of tooth++gear :: GLfloat -> GLfloat -> GLfloat -> GLint -> GLfloat -> IO ()+gear innerRadius outerRadius width teeth toothDepth = do+   let r0 = innerRadius+       r1 = outerRadius - toothDepth / 2+       r2 = outerRadius + toothDepth / 2++       da = 2 * pi / fromIntegral teeth / 4+       w  = 0.5 * width++       render p f =+          renderPrimitive p $+             mapM_ (\i -> let angle = fromIntegral i * 2 * pi / fromIntegral teeth+                              in f r0 r1 r2 w da teeth i angle)+                   [ 0 .. teeth ]++   shadeModel $= Flat+   currentNormal $= Normal3 0 0 1+   render QuadStrip gearFront+   render Quads     teethFront+   currentNormal $= Normal3 0 0 (-1)+   render QuadStrip gearBack+   render Quads     teethBack+   render QuadStrip teethFace+   shadeModel $= Smooth+   render QuadStrip gearInside++type Renderer =+   GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLint -> GLint -> GLfloat -> IO ()++-- draw front face+gearFront :: Renderer+gearFront r0 r1 _ w da teeth i angle = do+   vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) w)+   vertex (Vertex3 (r1 * cos angle) (r1 * sin angle) w)+   when (i < teeth) $ do+      vertex (Vertex3 (r0 * cos  angle          ) (r0 * sin  angle          ) w)+      vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) w)++-- draw front sides of teeth+teethFront :: Renderer+teethFront _ r1 r2 w da teeth i angle =+   when (i < teeth) $ do+      vertex (Vertex3 (r1 * cos  angle          ) (r1 * sin  angle          ) w)+      vertex (Vertex3 (r2 * cos (angle +     da)) (r2 * sin (angle +     da)) w)+      vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) w)+      vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) w)++-- draw back face+gearBack :: Renderer+gearBack r0 r1 _ w da teeth i angle = do+   vertex (Vertex3 (r1 * cos angle) (r1 * sin angle) (-w))+   vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) (-w))+   when (i < teeth) $ do+      vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) (-w))+      vertex (Vertex3 (r0 * cos  angle          ) (r0 * sin  angle          ) (-w))++-- draw back sides of teeth+teethBack :: Renderer+teethBack _ r1 r2 w da teeth i angle =+   when (i < teeth) $ do+      vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) (-w))+      vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) (-w))+      vertex (Vertex3 (r2 * cos (angle +     da)) (r2 * sin (angle +     da)) (-w))+      vertex (Vertex3 (r1 * cos  angle          ) (r1 * sin  angle          ) (-w))++-- draw outward faces of teeth+teethFace :: Renderer+teethFace _ r1 r2 w da teeth i angle =+  if (i < teeth) then do+    vertex (Vertex3 (r1*(cos angle)) (r1*(sin angle)) w)+    vertex (Vertex3 (r1*(cos angle)) (r1*(sin angle)) (-w))++    let u'    = r2 * cos (angle + da) - r1 * cos angle+        v'    = r2 * sin (angle + da) - r1 * sin angle+        len   = sqrt (u' * u' + v' * v')+        u     = u' / len+        v     = v' / len+    currentNormal $= Normal3 v (-u) 0+    vertex (Vertex3 (r2 * cos (angle +     da)) (r2 * sin (angle +     da))   w )+    vertex (Vertex3 (r2 * cos (angle +     da)) (r2 * sin (angle +     da)) (-w))+    currentNormal $= Normal3 (cos angle) (sin angle) 0+    vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da))   w )+    vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) (-w))+    let u2    = r1 * cos (angle + 3 * da) - r2 * cos (angle + 2 * da);+        v2    = r1 * sin (angle + 3 * da) - r2 * sin (angle + 2 * da);+    currentNormal $= Normal3 v2 (-u2) 0+    vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da))   w )+    vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) (-w))+    currentNormal $= Normal3 (cos angle) (sin angle) 0+  else do+    vertex (Vertex3 (r1 * cos 0) (r1 * sin 0)   w )+    vertex (Vertex3 (r1 * cos 0) (r1 * sin 0) (-w))++-- draw inside radius cylinder+gearInside :: Renderer+gearInside r0 _ _ w _ _ _ angle = do+   currentNormal $= Normal3 (-cos angle) (-sin angle) 0+   vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) (-w))+   vertex (Vertex3 (r0 * cos angle) (r0 * sin angle)   w )++draw :: (DisplayList,DisplayList,DisplayList,Int) -> State -> IO ()+draw (gear1, gear2, gear3, autoexit) state = do+   clear [ ColorBuffer, DepthBuffer ]+   (x, y, z) <- get (viewRot state)+   a <- get (angle' state)++   let translatef = translate :: Vector3 GLfloat -> IO ()+   preservingMatrix $ do+      rotate x (Vector3 1 0 0)+      rotate y (Vector3 0 1 0)+      rotate z (Vector3 0 0 1)++      preservingMatrix $ do+         translatef (Vector3 (-3) (-2) 0)+         rotate a (Vector3 0 0 1)+         callList gear1++      preservingMatrix $ do+         translatef (Vector3 3.1 (-2) 0)+         rotate (-2 * a - 9) (Vector3 0 0 1)+         callList gear2++      preservingMatrix $ do+         translatef (Vector3 (-3.1) 4.2 0)+         rotate (-2 * a - 25) (Vector3 0 0 1)+         callList gear3++   swapBuffers+   frames state $~! (+1)+   t0' <- get (t0 state)+   t <- get elapsedTime+   when (t - t0' >= 5000) $ do+      f <- get (frames state)+      let seconds = fromIntegral (t - t0') / 1000 :: GLfloat+          fps = fromIntegral f / seconds+      putStrLn (show f ++ " frames in " ++ show seconds ++ " seconds = "++ show fps ++ " FPS")+      t0 state $= t+      frames state $= 0+      when ((t >= 999 * autoexit) && (autoexit /= 0)) $+         exitWith ExitSuccess++idle :: State -> IdleCallback+idle state = do+   angle' state $~! (+2)+   postRedisplay Nothing++keyboard :: State -> KeyboardMouseCallback+keyboard state (Char 'z')           _ _ _ = modRot state ( 0,  0,  5)+keyboard state (Char 'Z')           _ _ _ = modRot state ( 0,  0, -5)+keyboard state (SpecialKey KeyUp)   _ _ _ = modRot state ( 5,  0,  0)+keyboard state (SpecialKey KeyDown) _ _ _ = modRot state (-5,  0,  0)+keyboard state (SpecialKey KeyLeft) _ _ _ = modRot state ( 0,  5,  0)+keyboard state (SpecialKey KeyRight)_ _ _ = modRot state ( 0, -5,  0)+keyboard _     (Char '\27')         _ _ _ = exitWith ExitSuccess+keyboard _     _                    _ _ _ = return ()++modRot :: State -> View -> IO ()+modRot state (dx,dy,dz) = do+   (x, y, z) <- get (viewRot state)+   viewRot state $= (x + dx, y + dy, z + dz)+   postRedisplay Nothing++-- new window size or exposure+reshape :: ReshapeCallback+reshape s@(Size width height) = do+   let h = fromIntegral height / fromIntegral width++   viewport $= (Position 0 0, s)+   matrixMode $= Projection+   loadIdentity+   frustum (-1) 1 (-h) h 5 60+   matrixMode $= Modelview 0+   loadIdentity+   translate (Vector3 0 0 (-40 :: GLfloat))++data Flag = GLInfo | AutoExit deriving ( Eq, Ord, Show )++argInfo :: [OptDescr Flag]+argInfo  = [+   Option ['i'] ["info"] (NoArg GLInfo)   "print gl information",+   Option ['e'] ["exit"] (NoArg AutoExit) "auto exit after 30 seconds" ]++opts :: [String] -> IO [Flag]+opts args =+   case getOpt Permute argInfo args of+      (o,_,[])   -> return o+      (_,_,errs) -> do+         putStr (concat errs ++ usageInfo "Usage: Gears [OPTION...]" argInfo)+         exitFailure++info :: IO ()+info = do+   rendererStr <- get renderer+   putStrLn ("GL_RENDERER   = " ++ rendererStr)+   vendorStr <- get vendor+   putStrLn ("GL_VENDOR     = " ++ vendorStr)+   versionStr <- get glVersion+   putStrLn ("GL_VERSION    = " ++ versionStr)+   exts <- get glExtensions+   putStrLn ("GL_EXTENSIONS = " ++ concat (intersperse " " exts))++myInit :: [String] -> IO (DisplayList,DisplayList,DisplayList,Int)+myInit args = do+   position (Light 0) $= Vertex4 5 5 10 0+   cullFace $= Just Back+   lighting $= Enabled+   light (Light 0) $= Enabled+   depthFunc $= Just Less++   -- make the gears+   g1 <- defineNewList Compile $ do+      materialAmbientAndDiffuse Front $= Color4 0.8 0.1 0.0 1.0+      gear 1 4 1 20 0.7++   g2 <- defineNewList Compile $ do+      materialAmbientAndDiffuse Front $= Color4 0.0 0.8 0.2 1.0+      gear 0.5 2 2 10 0.7++   g3 <- defineNewList Compile $ do+      materialAmbientAndDiffuse Front $= Color4 0.2 0.2 1.0 1.0+      gear 1.3 2 0.5 10 0.7++   normalize $= Enabled++   flags <- opts args+   when (GLInfo `elem` flags) info+   let autoexit = if AutoExit `elem` flags then 30 else 0+   when (autoexit /= 0) $+      putStrLn ("Auto Exit after " ++ show autoexit ++ " seconds.")++   return (g1, g2, g3, autoexit)++visible :: State -> Visibility -> IO ()+visible state Visible    = idleCallback $= Just (idle state)+visible _     NotVisible = idleCallback $= Nothing++main :: IO ()+main  = do+   (_progName, args) <- getArgsAndInitialize+   initialDisplayMode $= [ RGBMode, WithDepthBuffer, DoubleBuffered ]++   initialWindowPosition $= Position 0 0+   initialWindowSize $= Size 300 300+   _ <- createWindow "Gears"+   state <- makeState+   gearsAndAuto <- myInit args++   displayCallback $= draw gearsAndAuto state+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboard state)+   visibilityCallback $= Just (visible state)++   mainLoop

examples/Misc/Makefile view

@@ -1,1 +1,1 @@-include ../examples.mk
+include ../examples.mk

examples/Misc/Pitfall14.hs view

@@ -1,33 +1,33 @@-{-
-   Pitfall14
-   Copyright (c) Sven Panne 2002-2005 <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 pitfall 14 (Careful Enabling Color Material)
-   of Mark Kilgard's "16 Common OpenGL Pitfalls", see:
-   http://www.opengl.org/resources/features/KilgardTechniques/oglpitfall/
--}
-
-import Control.Monad ( unless )
-import System.Exit ( exitFailure )
-import Graphics.UI.GLUT
-
-main :: IO ()
-main = do
-   (progName, _args) <- getArgsAndInitialize
-   initialDisplayMode $= [ SingleBuffered, RGBMode ]
-   _ <- createWindow progName
-
-   currentColor $= Color4 1 1 1 1
-   materialAmbient Front $= Color4 0.1 0.1 0.1 1
-   -- re-get to avoid any rounding issues
-   mafBefore <- get (materialAmbient Front)
-
-   colorMaterial $= Just (Front, Diffuse)
-   mafAfter <- get (materialAmbient Front)
-   unless (mafBefore == mafAfter) $ do
-      putStrLn "ERROR: The ambient material property changed!"
-      putStrLn ("   before: " ++ show mafBefore)
-      putStrLn ("   after : " ++ show mafAfter)
-      exitFailure
+{-+   Pitfall14+   Copyright (c) Sven Panne 2002-2005 <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 pitfall 14 (Careful Enabling Color Material)+   of Mark Kilgard's "16 Common OpenGL Pitfalls", see:+   http://www.opengl.org/resources/features/KilgardTechniques/oglpitfall/+-}++import Control.Monad ( unless )+import System.Exit ( exitFailure )+import Graphics.UI.GLUT++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   _ <- createWindow progName++   currentColor $= Color4 1 1 1 1+   materialAmbient Front $= Color4 0.1 0.1 0.1 1+   -- re-get to avoid any rounding issues+   mafBefore <- get (materialAmbient Front)++   colorMaterial $= Just (Front, Diffuse)+   mafAfter <- get (materialAmbient Front)+   unless (mafBefore == mafAfter) $ do+      putStrLn "ERROR: The ambient material property changed!"+      putStrLn ("   before: " ++ show mafBefore)+      putStrLn ("   after : " ++ show mafAfter)+      exitFailure

examples/Misc/SmoothOpenGL3.hs view

@@ -1,272 +1,272 @@-{-
-   SmoothOpenGL3.hs (adapted from freeglut's smooth_opengl3.c example)
-   Copyright (c) Sven Panne 2009 <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 qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
-import Foreign.Marshal.Array
-import Foreign.Ptr
-import Foreign.Storable
-import Graphics.Rendering.OpenGL.Raw.Core31
-import Graphics.UI.GLUT
-import System.Exit
-import System.IO
-
-data State = State {
-   vertexBufferName :: BufferObject,
-   fgProjectionMatrixIndex :: UniformLocation,
-   fgColorIndex :: AttribLocation ,
-   fgVertexIndex :: AttribLocation,
-   projectionMatrix :: GLmatrix GLfloat }
-
-checkError :: String -> IO ()
-checkError functionName = get errors >>= mapM_ reportError
-   where reportError e = 
-            hPutStrLn stderr (showError e ++ " detected in " ++ functionName)
-         showError (Error category message) =
-            "GL error " ++ show category ++ " (" ++ message ++ ")"
-
-varray :: [GLfloat]
-varray = [
-   1, 0, 0, -- red
-   5, 5,    -- lower left
-
-   0, 1, 0, -- green
-   25, 5,   -- lower right
-
-   0, 0, 1, -- blue
-   5, 25 ]  -- upper left
-
-numColorComponents :: NumComponents
-numColorComponents = 3
-
-numVertexComponents :: NumComponents
-numVertexComponents = 2
-
-sizeOfComponent :: Int
-sizeOfComponent = sizeOf (head varray)
-
-stride :: Stride
-stride = fromIntegral sizeOfComponent * fromIntegral (numColorComponents + numVertexComponents)
-
-sizeOfVarray :: Int
-sizeOfVarray = length varray * sizeOfComponent
-
-numElements :: NumArrayIndices
-numElements = fromIntegral sizeOfVarray `div` fromIntegral stride
-
-initBuffer :: IO BufferObject
-initBuffer = do
-   bufferObject <- genObjectName
-   bindBuffer ArrayBuffer $= Just bufferObject
-   withArray varray $ \buffer ->
-      bufferData ArrayBuffer $= (fromIntegral sizeOfVarray, buffer, StaticDraw)
-   checkError "initBuffer"
-   return bufferObject
-
-packUtf8 :: String -> B.ByteString
-packUtf8 = TE.encodeUtf8 . T.pack
-
-vertexShaderSource :: B.ByteString
-vertexShaderSource = packUtf8 . unlines $ [
-   "#version 140",
-   "uniform mat4 fg_ProjectionMatrix;",
-   "in vec4 fg_Color;",
-   "in vec4 fg_Vertex;",
-   "smooth out vec4 fg_SmoothColor;",
-   "void main()",
-   "{",
-   "   fg_SmoothColor = fg_Color;",
-   "   gl_Position = fg_ProjectionMatrix * fg_Vertex;",
-   "}" ]
-
-fragmentShaderSource :: B.ByteString
-fragmentShaderSource = packUtf8 . unlines $ [
-   "#version 140",
-   "smooth in vec4 fg_SmoothColor;",
-   "out vec4 fg_FragColor;",
-   "void main(void)",
-   "{",
-   "   fg_FragColor = fg_SmoothColor;",
-   "}" ]
-
-checked :: (t -> IO ()) -> (t -> GettableStateVar Bool) -> (t -> GettableStateVar String) -> String -> t -> IO ()
-checked action getStatus getInfoLog message object = do
-   action object
-   status <- get (getStatus object)
-   unless status $
-      hPutStrLn stderr . ((message ++ " log: ") ++) =<< get (getInfoLog object)
-
-compileAndCheck :: Shader -> IO ()
-compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile"
-
-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"
-
-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 VertexShader vertexShaderSource
-   fragmentShader <- compileShaderSource FragmentShader fragmentShaderSource
-   program <- createProgramUsing [vertexShader, fragmentShader]
-   currentProgram $= Just program
-
-   projectionMatrixIndex <- get (uniformLocation program "fg_ProjectionMatrix")
-
-   colorIndex <- get (attribLocation program "fg_Color")
-   vertexAttribArray colorIndex $= Enabled
-
-   vertexIndex <- get (attribLocation program "fg_Vertex")
-   vertexAttribArray vertexIndex $= Enabled
-
-   checkError "initShader"
-   return (projectionMatrixIndex, colorIndex, vertexIndex)
-
-initRendering :: IO ()
-initRendering = do
-   clearColor $= Color4 0 0 0 0
-   checkError "initRendering"
-
-myInit :: IO State
-myInit = do
-   bufferObject <- initBuffer
-   (projectionMatrixIndex, colorIndex, vertexIndex) <- initShader
-   initRendering
-   m <- newMatrix ColumnMajor (replicate 16 0)
-   return $ State {
-      vertexBufferName = bufferObject,
-      fgProjectionMatrixIndex = projectionMatrixIndex,
-      fgColorIndex = colorIndex,
-      fgVertexIndex = vertexIndex,
-      projectionMatrix = m }
-
-dumpInfo :: IO ()
-dumpInfo = do
-   let dump message var = putStrLn . ((message ++ ": ") ++) =<< get var
-   dump "Vendor" vendor
-   dump "Renderer" renderer
-   dump "Version" glVersion
-   dump "GLSL" shadingLanguageVersion
-   checkError "dumpInfo"
-
-bufferObjectPtr :: Integral a => a -> Ptr b
-bufferObjectPtr = plusPtr (nullPtr :: Ptr GLchar) . fromIntegral
-
-vertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor a
-vertexArrayDescriptor count offset =
-   VertexArrayDescriptor count Float stride (bufferObjectPtr (fromIntegral sizeOfComponent * offset))
-
-triangle :: State -> IO ()
-triangle state = do
-   withMatrix (projectionMatrix state) $ \order buffer ->
-      uniformMatrix4fv (fgProjectionMatrixIndex state) 1 (order == RowMajor) buffer
-   bindBuffer ArrayBuffer $= Just (vertexBufferName state)
-   vertexAttribPointer (fgColorIndex state) $=
-      (ToFloat, vertexArrayDescriptor numColorComponents 0)
-   vertexAttribPointer (fgVertexIndex state) $=
-      (ToFloat, vertexArrayDescriptor numVertexComponents numColorComponents)
-   drawArrays Triangles 0 numElements
-   checkError "triangle"
-
--- The OpenGL package offers no interface for glUniformMatrix*fv yet
-uniformMatrix4fv :: UniformLocation -> GLsizei -> Bool -> Ptr GLfloat -> IO ()
-uniformMatrix4fv location count =
-   glUniformMatrix4fv (uniformLocationToGLint location) count . marshalGLboolean
-   where marshalGLboolean x = fromIntegral $ case x of
-            False -> gl_FALSE
-            True -> gl_TRUE
-         -- MEGA HACK because UniformLocation is abstract
-         uniformLocationToGLint = read . head . tail . words . show
-
-display :: State -> DisplayCallback
-display state = do
-   clear [ ColorBuffer ]
-   triangle state
-   flush
-   checkError "display"
-
-loadOrtho :: (Matrix m, MatrixComponent a, Fractional a) => m a -> a -> a -> a -> a -> a -> a -> IO ()
-loadOrtho m l r b t n f =
-   fillMatrix m [
-      [2 / (r - l),
-       0,
-       0,
-       0],
-
-      [0,
-       2 / (t - b),
-       0,
-       0],
-
-      [0,
-       0,
-       -2 / (f - n),
-       0],
-
-      [-(r + l) / (r - l),
-       -(t + b) / (t - b),
-       -(f + n) / (f - n),
-       1 ]]
-
-fillMatrix :: (Matrix m, MatrixComponent a) => m a -> [[a]] -> IO ()
-fillMatrix m xs =
-   withMatrix m $ \order buffer ->
-      pokeArray buffer . concat . rearrange order $ xs
-
-rearrange :: MatrixOrder -> [[a]] -> [[a]]
-rearrange ColumnMajor = id
-rearrange RowMajor = transpose
-
-loadOrtho2D :: (Matrix m, MatrixComponent a, Fractional a) => m a -> a -> a -> a -> a -> IO ()
-loadOrtho2D m l r b t = loadOrtho m l r b t (-1) 1
-
-reshape :: State -> ReshapeCallback
-reshape state size@(Size w h) = do
-   viewport $= (Position 0 0, size)
-   let wf = fromIntegral w
-       hf = fromIntegral h
-   if w <= h
-      then loadOrtho2D (projectionMatrix state) 0 30 0 (30 * hf / wf)
-      else loadOrtho2D (projectionMatrix state) 0 (30 * wf / hf) 0 30
-   checkError "reshape"
-
-keyboard :: KeyboardMouseCallback
-keyboard (Char '\27') Down _ _ = exitWith ExitSuccess
-keyboard _            _    _ _ = return ()
-
-main :: IO ()
-main = do
-   (progName, args) <- getArgsAndInitialize
-   initialDisplayMode $= [ SingleBuffered, RGBMode ]
-   -- add command line argument "classic" for a pre-3.x context
-   unless (args == ["classic"]) $ do
-      initialContextVersion $= (3, 1)
-      initialContextFlags $= [ ForwardCompatibleContext, DebugContext ]
-   initialWindowSize $= Size 500 500
-   initialWindowPosition $= Position 100 100
-   _ <- createWindow progName
-   dumpInfo
-   state <- myInit
-   displayCallback $= display state
-   reshapeCallback $= Just (reshape state)
-   keyboardMouseCallback $= Just keyboard
-   mainLoop
+{-+   SmoothOpenGL3.hs (adapted from freeglut's smooth_opengl3.c example)+   Copyright (c) Sven Panne 2009 <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 qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable+import Graphics.Rendering.OpenGL.Raw.Core31+import Graphics.UI.GLUT+import System.Exit+import System.IO++data State = State {+   vertexBufferName :: BufferObject,+   fgProjectionMatrixIndex :: UniformLocation,+   fgColorIndex :: AttribLocation ,+   fgVertexIndex :: AttribLocation,+   projectionMatrix :: GLmatrix GLfloat }++checkError :: String -> IO ()+checkError functionName = get errors >>= mapM_ reportError+   where reportError e = +            hPutStrLn stderr (showError e ++ " detected in " ++ functionName)+         showError (Error category message) =+            "GL error " ++ show category ++ " (" ++ message ++ ")"++varray :: [GLfloat]+varray = [+   1, 0, 0, -- red+   5, 5,    -- lower left++   0, 1, 0, -- green+   25, 5,   -- lower right++   0, 0, 1, -- blue+   5, 25 ]  -- upper left++numColorComponents :: NumComponents+numColorComponents = 3++numVertexComponents :: NumComponents+numVertexComponents = 2++sizeOfComponent :: Int+sizeOfComponent = sizeOf (head varray)++stride :: Stride+stride = fromIntegral sizeOfComponent * fromIntegral (numColorComponents + numVertexComponents)++sizeOfVarray :: Int+sizeOfVarray = length varray * sizeOfComponent++numElements :: NumArrayIndices+numElements = fromIntegral sizeOfVarray `div` fromIntegral stride++initBuffer :: IO BufferObject+initBuffer = do+   bufferObject <- genObjectName+   bindBuffer ArrayBuffer $= Just bufferObject+   withArray varray $ \buffer ->+      bufferData ArrayBuffer $= (fromIntegral sizeOfVarray, buffer, StaticDraw)+   checkError "initBuffer"+   return bufferObject++packUtf8 :: String -> B.ByteString+packUtf8 = TE.encodeUtf8 . T.pack++vertexShaderSource :: B.ByteString+vertexShaderSource = packUtf8 . unlines $ [+   "#version 140",+   "uniform mat4 fg_ProjectionMatrix;",+   "in vec4 fg_Color;",+   "in vec4 fg_Vertex;",+   "smooth out vec4 fg_SmoothColor;",+   "void main()",+   "{",+   "   fg_SmoothColor = fg_Color;",+   "   gl_Position = fg_ProjectionMatrix * fg_Vertex;",+   "}" ]++fragmentShaderSource :: B.ByteString+fragmentShaderSource = packUtf8 . unlines $ [+   "#version 140",+   "smooth in vec4 fg_SmoothColor;",+   "out vec4 fg_FragColor;",+   "void main(void)",+   "{",+   "   fg_FragColor = fg_SmoothColor;",+   "}" ]++checked :: (t -> IO ()) -> (t -> GettableStateVar Bool) -> (t -> GettableStateVar String) -> String -> t -> IO ()+checked action getStatus getInfoLog message object = do+   action object+   status <- get (getStatus object)+   unless status $+      hPutStrLn stderr . ((message ++ " log: ") ++) =<< get (getInfoLog object)++compileAndCheck :: Shader -> IO ()+compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile"++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"++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 VertexShader vertexShaderSource+   fragmentShader <- compileShaderSource FragmentShader fragmentShaderSource+   program <- createProgramUsing [vertexShader, fragmentShader]+   currentProgram $= Just program++   projectionMatrixIndex <- get (uniformLocation program "fg_ProjectionMatrix")++   colorIndex <- get (attribLocation program "fg_Color")+   vertexAttribArray colorIndex $= Enabled++   vertexIndex <- get (attribLocation program "fg_Vertex")+   vertexAttribArray vertexIndex $= Enabled++   checkError "initShader"+   return (projectionMatrixIndex, colorIndex, vertexIndex)++initRendering :: IO ()+initRendering = do+   clearColor $= Color4 0 0 0 0+   checkError "initRendering"++myInit :: IO State+myInit = do+   bufferObject <- initBuffer+   (projectionMatrixIndex, colorIndex, vertexIndex) <- initShader+   initRendering+   m <- newMatrix ColumnMajor (replicate 16 0)+   return $ State {+      vertexBufferName = bufferObject,+      fgProjectionMatrixIndex = projectionMatrixIndex,+      fgColorIndex = colorIndex,+      fgVertexIndex = vertexIndex,+      projectionMatrix = m }++dumpInfo :: IO ()+dumpInfo = do+   let dump message var = putStrLn . ((message ++ ": ") ++) =<< get var+   dump "Vendor" vendor+   dump "Renderer" renderer+   dump "Version" glVersion+   dump "GLSL" shadingLanguageVersion+   checkError "dumpInfo"++bufferObjectPtr :: Integral a => a -> Ptr b+bufferObjectPtr = plusPtr (nullPtr :: Ptr GLchar) . fromIntegral++vertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor a+vertexArrayDescriptor count offset =+   VertexArrayDescriptor count Float stride (bufferObjectPtr (fromIntegral sizeOfComponent * offset))++triangle :: State -> IO ()+triangle state = do+   withMatrix (projectionMatrix state) $ \order buffer ->+      uniformMatrix4fv (fgProjectionMatrixIndex state) 1 (order == RowMajor) buffer+   bindBuffer ArrayBuffer $= Just (vertexBufferName state)+   vertexAttribPointer (fgColorIndex state) $=+      (ToFloat, vertexArrayDescriptor numColorComponents 0)+   vertexAttribPointer (fgVertexIndex state) $=+      (ToFloat, vertexArrayDescriptor numVertexComponents numColorComponents)+   drawArrays Triangles 0 numElements+   checkError "triangle"++-- The OpenGL package offers no interface for glUniformMatrix*fv yet+uniformMatrix4fv :: UniformLocation -> GLsizei -> Bool -> Ptr GLfloat -> IO ()+uniformMatrix4fv location count =+   glUniformMatrix4fv (uniformLocationToGLint location) count . marshalGLboolean+   where marshalGLboolean x = fromIntegral $ case x of+            False -> gl_FALSE+            True -> gl_TRUE+         -- MEGA HACK because UniformLocation is abstract+         uniformLocationToGLint = read . head . tail . words . show++display :: State -> DisplayCallback+display state = do+   clear [ ColorBuffer ]+   triangle state+   flush+   checkError "display"++loadOrtho :: (Matrix m, MatrixComponent a, Fractional a) => m a -> a -> a -> a -> a -> a -> a -> IO ()+loadOrtho m l r b t n f =+   fillMatrix m [+      [2 / (r - l),+       0,+       0,+       0],++      [0,+       2 / (t - b),+       0,+       0],++      [0,+       0,+       -2 / (f - n),+       0],++      [-(r + l) / (r - l),+       -(t + b) / (t - b),+       -(f + n) / (f - n),+       1 ]]++fillMatrix :: (Matrix m, MatrixComponent a) => m a -> [[a]] -> IO ()+fillMatrix m xs =+   withMatrix m $ \order buffer ->+      pokeArray buffer . concat . rearrange order $ xs++rearrange :: MatrixOrder -> [[a]] -> [[a]]+rearrange ColumnMajor = id+rearrange RowMajor = transpose++loadOrtho2D :: (Matrix m, MatrixComponent a, Fractional a) => m a -> a -> a -> a -> a -> IO ()+loadOrtho2D m l r b t = loadOrtho m l r b t (-1) 1++reshape :: State -> ReshapeCallback+reshape state size@(Size w h) = do+   viewport $= (Position 0 0, size)+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then loadOrtho2D (projectionMatrix state) 0 30 0 (30 * hf / wf)+      else loadOrtho2D (projectionMatrix state) 0 (30 * wf / hf) 0 30+   checkError "reshape"++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   -- add command line argument "classic" for a pre-3.x context+   unless (args == ["classic"]) $ do+      initialContextVersion $= (3, 1)+      initialContextFlags $= [ ForwardCompatibleContext, DebugContext ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   _ <- createWindow progName+   dumpInfo+   state <- myInit+   displayCallback $= display state+   reshapeCallback $= Just (reshape state)+   keyboardMouseCallback $= Just keyboard+   mainLoop

examples/Misc/Triangulate.hs view

@@ -1,122 +1,122 @@-{-
-   Triangulate.hs (adapted from tess.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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 triangulation. 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 System.Random ( randomIO )
-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 ]
-
-star :: ComplexPolygon DontCare
-star = ComplexPolygon [
-   ComplexContour [
-      AnnotatedVertex (Vertex3 250  50 0) 0,
-      AnnotatedVertex (Vertex3 325 200 0) 0,
-      AnnotatedVertex (Vertex3 400  50 0) 0,
-      AnnotatedVertex (Vertex3 250 150 0) 0,
-      AnnotatedVertex (Vertex3 400 150 0) 0 ] ]
-
-myInit :: IO [DisplayList]
-myInit = do
-   clearColor $= Color4 0 0 0 0
-   rectAndTriList <- compileNewList TessWindingOdd rectAndTri
-   starList <- compileNewList TessWindingPositive star
-   return [ rectAndTriList, starList ]
-
-compileNewList :: TessWinding -> ComplexPolygon DontCare -> IO DisplayList
-compileNewList windingRule complexPolygon =
-   defineNewList Compile $
-      drawTriangulation =<<
-         triangulate windingRule 0 (Normal3 0 0 0) noOpCombiner complexPolygon
-
-noOpCombiner :: Combiner DontCare
-noOpCombiner _newVertex _weightedProperties = 0
-
-drawTriangulation :: Triangulation DontCare -> IO ()
-drawTriangulation (Triangulation triangles) =
-   renderPrimitive Triangles $
-      flip mapM_ triangles $ \(Triangle tv1 tv2 tv3) -> do
-         randomColor
-         drawTriangleVertex tv1
-         drawTriangleVertex tv2
-         drawTriangleVertex tv3
-
--- CFloat has no Random instance, so we go via Float
-randomGLfloat :: IO GLfloat
-randomGLfloat = fmap (realToFrac :: Float -> GLfloat) randomIO
-
-randomColor :: IO ()
-randomColor = do
-   r <- randomGLfloat
-   g <- randomGLfloat
-   b <- randomGLfloat
-   color (Color3 r g b)
-
-drawTriangleVertex :: TriangleVertex DontCare -> IO ()
-drawTriangleVertex (AnnotatedVertex plainVertex (_, e)) = do
-   edgeFlag $= e
-   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
+{-+   Triangulate.hs (adapted from tess.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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 triangulation. 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 System.Random ( randomIO )+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 ]++star :: ComplexPolygon DontCare+star = ComplexPolygon [+   ComplexContour [+      AnnotatedVertex (Vertex3 250  50 0) 0,+      AnnotatedVertex (Vertex3 325 200 0) 0,+      AnnotatedVertex (Vertex3 400  50 0) 0,+      AnnotatedVertex (Vertex3 250 150 0) 0,+      AnnotatedVertex (Vertex3 400 150 0) 0 ] ]++myInit :: IO [DisplayList]+myInit = do+   clearColor $= Color4 0 0 0 0+   rectAndTriList <- compileNewList TessWindingOdd rectAndTri+   starList <- compileNewList TessWindingPositive star+   return [ rectAndTriList, starList ]++compileNewList :: TessWinding -> ComplexPolygon DontCare -> IO DisplayList+compileNewList windingRule complexPolygon =+   defineNewList Compile $+      drawTriangulation =<<+         triangulate windingRule 0 (Normal3 0 0 0) noOpCombiner complexPolygon++noOpCombiner :: Combiner DontCare+noOpCombiner _newVertex _weightedProperties = 0++drawTriangulation :: Triangulation DontCare -> IO ()+drawTriangulation (Triangulation triangles) =+   renderPrimitive Triangles $+      flip mapM_ triangles $ \(Triangle tv1 tv2 tv3) -> do+         randomColor+         drawTriangleVertex tv1+         drawTriangleVertex tv2+         drawTriangleVertex tv3++-- CFloat has no Random instance, so we go via Float+randomGLfloat :: IO GLfloat+randomGLfloat = fmap (realToFrac :: Float -> GLfloat) randomIO++randomColor :: IO ()+randomColor = do+   r <- randomGLfloat+   g <- randomGLfloat+   b <- randomGLfloat+   color (Color3 r g b)++drawTriangleVertex :: TriangleVertex DontCare -> IO ()+drawTriangleVertex (AnnotatedVertex plainVertex (_, e)) = do+   edgeFlag $= e+   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/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/Makefile view

@@ -1,2 +1,2 @@-SUBDIRS := ogl2brick
-include ../examples.mk
+SUBDIRS := ogl2brick+include ../examples.mk

examples/OrangeBook/ogl2brick/Brick.hs view

@@ -1,370 +1,370 @@-{-
-   Brick.hs (adapted from ogl2brick.c which is (c) 3Dlabs Inc. Ltd.)
-   Copyright (c) Sven Panne 2006 <svenpanne@gmail.com>
-   This file is part of HOpenGL and distributed under a BSD-style license
-   See the file libraries/GLUT/LICENSE
--}
-
-import Prelude hiding ( sum )
-import Control.Applicative
-import Control.Exception ( IOException, catch )
-import Control.Monad
-import qualified Data.ByteString as B
-import Data.Foldable ( Foldable, sum )
-import Data.IORef
-import System.Exit
-import Graphics.UI.GLUT
-
-infixl 6 $+, $-
-infixl 7 $*
-
-inertiaThreshold, inertiaFactor :: GLfloat
-inertiaThreshold = 1
-inertiaFactor = 0.5
-
-scaleFactor, scaleIncrement :: GLfloat
-scaleFactor = 0.01
-scaleIncrement = 0.5
-
-timerFrequencyMillis :: Timeout
-timerFrequencyMillis = 20
-
-clearColors :: [Color4 GLclampf]
-clearColors = [
-   Color4 0.0 0.0 0.0 1,
-   Color4 0.2 0.2 0.3 1,
-   Color4 0.7 0.7 0.7 1 ]
-
-models :: [IO ()]
-models = [
-   drawCube,
-   renderObject Solid (Teapot 0.6),
-   renderObject Solid (Sphere' 0.6 64 64),
-   renderObject Solid (Torus 0.2 0.6 64 64) ]
-
-initialDiff :: Vector3 GLfloat
-initialDiff = Vector3 206 16 10
-
-initialInertia :: Vector3 GLfloat
-initialInertia = Vector3 (-0.5) 0 0
-
-data State = State {
-   diff :: IORef (Vector3 GLfloat),
-   lastIncr :: IORef (Vector3 GLfloat),
-   inertia :: IORef (Vector3 GLfloat),
-   inertiaOld :: IORef (Vector3 GLfloat),
-   theScale :: IORef GLfloat,
-   lastPosition :: IORef Position,
-   shouldRotate :: IORef Bool,
-   colorCycle :: IORef [Color4 GLclampf],
-   modelCycle :: IORef [IO ()],
-   modifiers :: IORef Modifiers
-   }
-
-makeState :: IO State
-makeState = do
-   di <- newIORef initialDiff
-   li <- newIORef (pure 0)
-   ia <- newIORef initialInertia
-   io <- newIORef (pure 0)
-   sc <- newIORef 1
-   lp <- newIORef (Position (-1) (-1))
-   sr <- newIORef True
-   cc <- newIORef (cycle clearColors)
-   mc <- newIORef (cycle models)
-   mo <- newIORef (Modifiers Up Up Up)
-   return $ State {
-      diff = di,
-      lastIncr = li,
-      inertia = ia,
-      inertiaOld = io,
-      theScale = sc,
-      lastPosition = lp,
-      shouldRotate = sr,
-      colorCycle = cc,
-      modelCycle = mc,
-      modifiers = mo
-      }
-
--- Our tiny vector math library...
-($+), ($-), ($*) :: (Applicative t, Num a) => t a -> t a -> t a
-($+) = liftA2 (+)
-($-) = liftA2 (-)
-($*) = liftA2 (*)
-
-step :: (Applicative t, Num a, Ord a) => t a -> t a -> t a
-step = liftA2 (\e x -> if x < e then 0 else 1)
-
-dot :: (Applicative t, Foldable t, Num a) => t a -> t a -> a
-dot v1 v2 = sum (v1 $* v2)
-
-drawFace :: Normal3 GLfloat -> Vertex3 GLfloat -> Vertex3 GLfloat
-         -> Vertex3 GLfloat -> Vertex3 GLfloat -> IO ()
-drawFace p q r s t = do
-   let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()
-   normal p
-   texCoord2f (TexCoord2 1 1)
-   vertex q
-   texCoord2f (TexCoord2 0 1)
-   vertex r
-   texCoord2f (TexCoord2 0 0)
-   vertex s
-   texCoord2f (TexCoord2 1 0)
-   vertex t
-
-drawCube :: IO ()
-drawCube = do
-   let size = 1
-       sc = 0.2
-       delta = 0.1
-
-       a = Vertex3   size    size  ( size * sc + delta)
-       b = Vertex3   size    size  (-size * sc + delta)
-       c = Vertex3   size  (-size) (-size * sc)
-       d = Vertex3   size  (-size) ( size * sc)
-       e = Vertex3 (-size)   size  ( size * sc + delta)
-       f = Vertex3 (-size)   size  (-size * sc + delta)
-       g = Vertex3 (-size) (-size) (-size * sc)
-       h = Vertex3 (-size) (-size) ( size * sc)
-
-       i = Normal3   1    0    0
-       k = Normal3 (-1)   0    0
-       l = Normal3   0    0  (-1)
-       m = Normal3   0    0    1
-       n = Normal3   0    1    0
-       o = Normal3   0  (-1)   0
-
-   renderPrimitive Quads $ do
-      drawFace i d c b a
-      drawFace k g h e f
-      drawFace l c g f b
-      drawFace m h d a e
-      drawFace n e a b f
-      drawFace o g c d h
-
-display :: State -> DisplayCallback
-display state = do
-   loadIdentity
-   translate (Vector3 0 0 (-5 :: GLfloat))
-
-   Vector3 xDiff yDiff zDiff <- get (diff state)
-   rotate yDiff (Vector3 1 0 0)
-   rotate xDiff (Vector3 0 1 0)
-   rotate zDiff (Vector3 0 0 1)
-
-   sc <- get (theScale state)
-   scale sc sc sc
-
-   clear [ ColorBuffer, DepthBuffer ]
-   (drawModel:_) <- get (modelCycle state)
-   drawModel
-
-   flush
-   swapBuffers
-
-nextClearColor :: State -> IO ()
-nextClearColor state = do
-   cc <- get (colorCycle state)
-   clearColor $= head cc
-   colorCycle state $~ tail
-
-toggleRotation :: State -> IO ()
-toggleRotation state = do
-   rot <- get (shouldRotate state)
-   shouldRotate state $~ not
-   if rot
-      then do
-         ia <- get (inertia state)
-         inertiaOld state $= ia
-      else do
-        io <- get (inertiaOld state)
-        inertia state $= io
-        -- To prevent confusion, force some rotation
-        when (dot io io == 0) $
-           inertia state $= initialInertia
-
-printHelp :: IO ()
-printHelp = mapM_ putStrLn [
-   "",
-   "Keyboard commands:",
-   "",
-   "b - Toggle among background clear colors",
-   "q, <esc> - Quit",
-   "t - Toggle among models to render",
-   "? - Help",
-   "<home> - reset zoom and rotation",
-   "<space> or <click> - stop rotation",
-   "<+>, <-> or <ctrl + drag> - zoom model",
-   "<arrow keys> or <drag> - rotate model",
-   ""]
-
-resetState :: State -> IO ()
-resetState state = do
-   diff state $= initialDiff
-   lastIncr state $= pure 0
-   inertia state $= initialInertia
-   theScale state $= 1
-
-calcInertia :: State -> IO ()
-calcInertia state = do
-   lastPosition state $= Position (-1) (-1)
-   li <- get (lastIncr state)
-   ia <- get (inertia state)
-   let t = pure inertiaThreshold
-       f = pure inertiaFactor
-       l = (pure 1 $- (step (fmap negate t) li)) $* ((li $+ t) $* f $- ia)
-       r = (step t li) $* ((li $- t) $* f $- ia)
-   inertia state $= l $+ ia $+ r
-   lastIncr state $= pure 0
-
-keyboard :: State -> KeyboardMouseCallback
-keyboard state key keyState mods _ = do
-   modifiers state $= mods
-   postRedisplay Nothing
-   case (key, keyState) of
-      (Char 'b', Down) -> nextClearColor state
-      (Char 'q', Down) -> exitWith ExitSuccess
-      (Char '\27', Down) -> exitWith ExitSuccess
-      (Char 't', Down) -> modelCycle state $~ tail
-      (Char ' ', Down) -> toggleRotation state
-      (Char '+', Down) -> theScale state $~ (+ scaleIncrement)
-      (Char '-', Down) -> theScale state $~ (+ (- scaleIncrement))
-      (Char _, Down) -> printHelp
-      (SpecialKey KeyHome, Down) -> resetState state
-      (SpecialKey KeyLeft, Down) -> diff state $~ ($- Vector3 1 0 0)
-      (SpecialKey KeyRight, Down) -> diff state $~ ($+ Vector3 1 0 0)
-      (SpecialKey KeyUp, Down) -> diff state $~ ($- Vector3 0 1 0)
-      (SpecialKey KeyDown, Down) -> diff state $~ ($+ Vector3 0 1 0)
-      (MouseButton LeftButton, Down) -> do
-         inertia state $= pure 0
-         lastIncr state $= pure 0
-      (MouseButton LeftButton, Up) -> calcInertia state
-      (_, _) -> return ()
-
-motion :: State -> MotionCallback
-motion state pos@(Position x y) = do
-   postRedisplay Nothing
-   Position xt yt <- get (lastPosition state)
-   lastPosition state $= pos
-   when (xt /= -1 || yt /= -1) $ do
-      let li@(Vector3 xl yl _) = Vector3 (fromIntegral (x - xt)) (fromIntegral (y - yt)) 0
-      lastIncr state $= li
-      when (xt /= -1) $ do
-         mods <- get (modifiers state)
-         if ctrl mods == Down
-            then do diff state $~ ($+ Vector3 0 0 xl)
-                    theScale state $~ (+ (yl * scaleFactor))
-            else diff state $~ ($+ li)
-
-timer :: State -> TimerCallback
-timer state = do
-   rot <- get (shouldRotate state)
-   when rot $ do
-      ia <- get (inertia state)
-      diff state $~ ($+ ia)
-      postRedisplay Nothing
-   addTimerCallback timerFrequencyMillis (timer state)
-
-reshape :: ReshapeCallback
-reshape size@(Size w h) = do
-   let vp = 0.8
-       aspect = fromIntegral w / fromIntegral h
-
-   viewport $= (Position 0 0, size)
-
-   matrixMode $= Projection
-   loadIdentity
-   frustum (-vp) vp (-vp / aspect) (vp / aspect) 3 10
-
-   matrixMode $= Modelview 0
-   loadIdentity
-   translate (Vector3 0 0 (-5 :: GLfloat))
-
--- Make sure that GLSL is supported by the driver, either directly by the core
--- or via an extension.
-checkGLSLSupport :: IO ()
-checkGLSLSupport = do
-   version <- get (majorMinor glVersion)
-   unless (version >= (2,0)) $ do
-      extensions <- get glExtensions
-      unless ("GL_ARB_shading_language_100" `elem` extensions) $
-         ioError (userError "No GLSL support found.")
-
-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)
-   infoLog <- get (shaderInfoLog shader)
-   mapM_ putStrLn ["Shader info log for '" ++ filePath ++ "':", infoLog, ""]
-   unless ok $ do
-      deleteObjectNames [shader]
-      ioError (userError "shader compilation failed")
-   return shader
-
-installBrickShaders :: [Shader] -> IO ()
-installBrickShaders shaders = do
-   brickProg <- createProgram
-   attachedShaders brickProg $= shaders
-   linkProgram brickProg
-   reportErrors
-   ok <- get (linkStatus brickProg)
-   infoLog <- get (programInfoLog brickProg)
-   mapM_ putStrLn ["Program info log:", infoLog, ""]
-   unless ok $ do
-      deleteObjectNames [brickProg]
-      ioError (userError "linking failed")
-
-   currentProgram $= Just brickProg
-
-   let setUniform var val = do
-       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))
-   setUniform "BrickSize" (Vertex2 0.30 (0.15 :: GLfloat))
-   setUniform "BrickPct" (Vertex2 0.90 (0.85 :: GLfloat))
-   setUniform "LightPosition" (Vertex3 0 0 (4 :: GLfloat))
-
-main :: IO ()
-main = do
-   _ <- getArgsAndInitialize
-   initialDisplayMode $= [ RGBMode, WithDepthBuffer, DoubleBuffered ]
-   initialWindowSize $= Size 500 500
-   _ <- createWindow "3Dlabs Brick Shader"
-
-   -- Note: We don't use an idle callback, we redisplay more intelligently.
-   state <- makeState
-   displayCallback $= display state
-   keyboardMouseCallback $= Just (keyboard state)
-   reshapeCallback $= Just reshape
-   motionCallback $= Just (motion state)
-   addTimerCallback timerFrequencyMillis (timer state)
-
-   Control.Exception.catch
-     (do checkGLSLSupport
-         vs <- readAndCompileShader VertexShader "Brick.vert"
-         fs <- readAndCompileShader FragmentShader "Brick.frag"
-         installBrickShaders [vs, fs])
-     (\exception -> do
-         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
-         materialShininess Front $= 16
-         position (Light 0) $= Vertex4 0 0 4 0
-         lighting $= Enabled
-         light (Light 0) $= Enabled)
-
-   depthFunc $= Just Less
-   nextClearColor state
-
-   -- display help
-   keyboard state (Char '?') Down (Modifiers Up Up Up) (Position 0 0)
-
-   mainLoop
+{-+   Brick.hs (adapted from ogl2brick.c which is (c) 3Dlabs Inc. Ltd.)+   Copyright (c) Sven Panne 2006 <svenpanne@gmail.com>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE+-}++import Prelude hiding ( sum )+import Control.Applicative+import Control.Exception ( IOException, catch )+import Control.Monad+import qualified Data.ByteString as B+import Data.Foldable ( Foldable, sum )+import Data.IORef+import System.Exit+import Graphics.UI.GLUT++infixl 6 $+, $-+infixl 7 $*++inertiaThreshold, inertiaFactor :: GLfloat+inertiaThreshold = 1+inertiaFactor = 0.5++scaleFactor, scaleIncrement :: GLfloat+scaleFactor = 0.01+scaleIncrement = 0.5++timerFrequencyMillis :: Timeout+timerFrequencyMillis = 20++clearColors :: [Color4 GLclampf]+clearColors = [+   Color4 0.0 0.0 0.0 1,+   Color4 0.2 0.2 0.3 1,+   Color4 0.7 0.7 0.7 1 ]++models :: [IO ()]+models = [+   drawCube,+   renderObject Solid (Teapot 0.6),+   renderObject Solid (Sphere' 0.6 64 64),+   renderObject Solid (Torus 0.2 0.6 64 64) ]++initialDiff :: Vector3 GLfloat+initialDiff = Vector3 206 16 10++initialInertia :: Vector3 GLfloat+initialInertia = Vector3 (-0.5) 0 0++data State = State {+   diff :: IORef (Vector3 GLfloat),+   lastIncr :: IORef (Vector3 GLfloat),+   inertia :: IORef (Vector3 GLfloat),+   inertiaOld :: IORef (Vector3 GLfloat),+   theScale :: IORef GLfloat,+   lastPosition :: IORef Position,+   shouldRotate :: IORef Bool,+   colorCycle :: IORef [Color4 GLclampf],+   modelCycle :: IORef [IO ()],+   modifiers :: IORef Modifiers+   }++makeState :: IO State+makeState = do+   di <- newIORef initialDiff+   li <- newIORef (pure 0)+   ia <- newIORef initialInertia+   io <- newIORef (pure 0)+   sc <- newIORef 1+   lp <- newIORef (Position (-1) (-1))+   sr <- newIORef True+   cc <- newIORef (cycle clearColors)+   mc <- newIORef (cycle models)+   mo <- newIORef (Modifiers Up Up Up)+   return $ State {+      diff = di,+      lastIncr = li,+      inertia = ia,+      inertiaOld = io,+      theScale = sc,+      lastPosition = lp,+      shouldRotate = sr,+      colorCycle = cc,+      modelCycle = mc,+      modifiers = mo+      }++-- Our tiny vector math library...+($+), ($-), ($*) :: (Applicative t, Num a) => t a -> t a -> t a+($+) = liftA2 (+)+($-) = liftA2 (-)+($*) = liftA2 (*)++step :: (Applicative t, Num a, Ord a) => t a -> t a -> t a+step = liftA2 (\e x -> if x < e then 0 else 1)++dot :: (Applicative t, Foldable t, Num a) => t a -> t a -> a+dot v1 v2 = sum (v1 $* v2)++drawFace :: Normal3 GLfloat -> Vertex3 GLfloat -> Vertex3 GLfloat+         -> Vertex3 GLfloat -> Vertex3 GLfloat -> IO ()+drawFace p q r s t = do+   let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()+   normal p+   texCoord2f (TexCoord2 1 1)+   vertex q+   texCoord2f (TexCoord2 0 1)+   vertex r+   texCoord2f (TexCoord2 0 0)+   vertex s+   texCoord2f (TexCoord2 1 0)+   vertex t++drawCube :: IO ()+drawCube = do+   let size = 1+       sc = 0.2+       delta = 0.1++       a = Vertex3   size    size  ( size * sc + delta)+       b = Vertex3   size    size  (-size * sc + delta)+       c = Vertex3   size  (-size) (-size * sc)+       d = Vertex3   size  (-size) ( size * sc)+       e = Vertex3 (-size)   size  ( size * sc + delta)+       f = Vertex3 (-size)   size  (-size * sc + delta)+       g = Vertex3 (-size) (-size) (-size * sc)+       h = Vertex3 (-size) (-size) ( size * sc)++       i = Normal3   1    0    0+       k = Normal3 (-1)   0    0+       l = Normal3   0    0  (-1)+       m = Normal3   0    0    1+       n = Normal3   0    1    0+       o = Normal3   0  (-1)   0++   renderPrimitive Quads $ do+      drawFace i d c b a+      drawFace k g h e f+      drawFace l c g f b+      drawFace m h d a e+      drawFace n e a b f+      drawFace o g c d h++display :: State -> DisplayCallback+display state = do+   loadIdentity+   translate (Vector3 0 0 (-5 :: GLfloat))++   Vector3 xDiff yDiff zDiff <- get (diff state)+   rotate yDiff (Vector3 1 0 0)+   rotate xDiff (Vector3 0 1 0)+   rotate zDiff (Vector3 0 0 1)++   sc <- get (theScale state)+   scale sc sc sc++   clear [ ColorBuffer, DepthBuffer ]+   (drawModel:_) <- get (modelCycle state)+   drawModel++   flush+   swapBuffers++nextClearColor :: State -> IO ()+nextClearColor state = do+   cc <- get (colorCycle state)+   clearColor $= head cc+   colorCycle state $~ tail++toggleRotation :: State -> IO ()+toggleRotation state = do+   rot <- get (shouldRotate state)+   shouldRotate state $~ not+   if rot+      then do+         ia <- get (inertia state)+         inertiaOld state $= ia+      else do+        io <- get (inertiaOld state)+        inertia state $= io+        -- To prevent confusion, force some rotation+        when (dot io io == 0) $+           inertia state $= initialInertia++printHelp :: IO ()+printHelp = mapM_ putStrLn [+   "",+   "Keyboard commands:",+   "",+   "b - Toggle among background clear colors",+   "q, <esc> - Quit",+   "t - Toggle among models to render",+   "? - Help",+   "<home> - reset zoom and rotation",+   "<space> or <click> - stop rotation",+   "<+>, <-> or <ctrl + drag> - zoom model",+   "<arrow keys> or <drag> - rotate model",+   ""]++resetState :: State -> IO ()+resetState state = do+   diff state $= initialDiff+   lastIncr state $= pure 0+   inertia state $= initialInertia+   theScale state $= 1++calcInertia :: State -> IO ()+calcInertia state = do+   lastPosition state $= Position (-1) (-1)+   li <- get (lastIncr state)+   ia <- get (inertia state)+   let t = pure inertiaThreshold+       f = pure inertiaFactor+       l = (pure 1 $- (step (fmap negate t) li)) $* ((li $+ t) $* f $- ia)+       r = (step t li) $* ((li $- t) $* f $- ia)+   inertia state $= l $+ ia $+ r+   lastIncr state $= pure 0++keyboard :: State -> KeyboardMouseCallback+keyboard state key keyState mods _ = do+   modifiers state $= mods+   postRedisplay Nothing+   case (key, keyState) of+      (Char 'b', Down) -> nextClearColor state+      (Char 'q', Down) -> exitWith ExitSuccess+      (Char '\27', Down) -> exitWith ExitSuccess+      (Char 't', Down) -> modelCycle state $~ tail+      (Char ' ', Down) -> toggleRotation state+      (Char '+', Down) -> theScale state $~ (+ scaleIncrement)+      (Char '-', Down) -> theScale state $~ (+ (- scaleIncrement))+      (Char _, Down) -> printHelp+      (SpecialKey KeyHome, Down) -> resetState state+      (SpecialKey KeyLeft, Down) -> diff state $~ ($- Vector3 1 0 0)+      (SpecialKey KeyRight, Down) -> diff state $~ ($+ Vector3 1 0 0)+      (SpecialKey KeyUp, Down) -> diff state $~ ($- Vector3 0 1 0)+      (SpecialKey KeyDown, Down) -> diff state $~ ($+ Vector3 0 1 0)+      (MouseButton LeftButton, Down) -> do+         inertia state $= pure 0+         lastIncr state $= pure 0+      (MouseButton LeftButton, Up) -> calcInertia state+      (_, _) -> return ()++motion :: State -> MotionCallback+motion state pos@(Position x y) = do+   postRedisplay Nothing+   Position xt yt <- get (lastPosition state)+   lastPosition state $= pos+   when (xt /= -1 || yt /= -1) $ do+      let li@(Vector3 xl yl _) = Vector3 (fromIntegral (x - xt)) (fromIntegral (y - yt)) 0+      lastIncr state $= li+      when (xt /= -1) $ do+         mods <- get (modifiers state)+         if ctrl mods == Down+            then do diff state $~ ($+ Vector3 0 0 xl)+                    theScale state $~ (+ (yl * scaleFactor))+            else diff state $~ ($+ li)++timer :: State -> TimerCallback+timer state = do+   rot <- get (shouldRotate state)+   when rot $ do+      ia <- get (inertia state)+      diff state $~ ($+ ia)+      postRedisplay Nothing+   addTimerCallback timerFrequencyMillis (timer state)++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   let vp = 0.8+       aspect = fromIntegral w / fromIntegral h++   viewport $= (Position 0 0, size)++   matrixMode $= Projection+   loadIdentity+   frustum (-vp) vp (-vp / aspect) (vp / aspect) 3 10++   matrixMode $= Modelview 0+   loadIdentity+   translate (Vector3 0 0 (-5 :: GLfloat))++-- Make sure that GLSL is supported by the driver, either directly by the core+-- or via an extension.+checkGLSLSupport :: IO ()+checkGLSLSupport = do+   version <- get (majorMinor glVersion)+   unless (version >= (2,0)) $ do+      extensions <- get glExtensions+      unless ("GL_ARB_shading_language_100" `elem` extensions) $+         ioError (userError "No GLSL support found.")++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)+   infoLog <- get (shaderInfoLog shader)+   mapM_ putStrLn ["Shader info log for '" ++ filePath ++ "':", infoLog, ""]+   unless ok $ do+      deleteObjectNames [shader]+      ioError (userError "shader compilation failed")+   return shader++installBrickShaders :: [Shader] -> IO ()+installBrickShaders shaders = do+   brickProg <- createProgram+   attachedShaders brickProg $= shaders+   linkProgram brickProg+   reportErrors+   ok <- get (linkStatus brickProg)+   infoLog <- get (programInfoLog brickProg)+   mapM_ putStrLn ["Program info log:", infoLog, ""]+   unless ok $ do+      deleteObjectNames [brickProg]+      ioError (userError "linking failed")++   currentProgram $= Just brickProg++   let setUniform var val = do+       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))+   setUniform "BrickSize" (Vertex2 0.30 (0.15 :: GLfloat))+   setUniform "BrickPct" (Vertex2 0.90 (0.85 :: GLfloat))+   setUniform "LightPosition" (Vertex3 0 0 (4 :: GLfloat))++main :: IO ()+main = do+   _ <- getArgsAndInitialize+   initialDisplayMode $= [ RGBMode, WithDepthBuffer, DoubleBuffered ]+   initialWindowSize $= Size 500 500+   _ <- createWindow "3Dlabs Brick Shader"++   -- Note: We don't use an idle callback, we redisplay more intelligently.+   state <- makeState+   displayCallback $= display state+   keyboardMouseCallback $= Just (keyboard state)+   reshapeCallback $= Just reshape+   motionCallback $= Just (motion state)+   addTimerCallback timerFrequencyMillis (timer state)++   Control.Exception.catch+     (do checkGLSLSupport+         vs <- readAndCompileShader VertexShader "Brick.vert"+         fs <- readAndCompileShader FragmentShader "Brick.frag"+         installBrickShaders [vs, fs])+     (\exception -> do+         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+         materialShininess Front $= 16+         position (Light 0) $= Vertex4 0 0 4 0+         lighting $= Enabled+         light (Light 0) $= Enabled)++   depthFunc $= Just Less+   nextClearColor state++   -- display help+   keyboard state (Char '?') Down (Modifiers Up Up Up) (Position 0 0)++   mainLoop

examples/OrangeBook/ogl2brick/Makefile view

@@ -1,1 +1,1 @@-include ../../examples.mk
+include ../../examples.mk

examples/RedBook4/AAIndex.hs view

@@ -1,104 +1,104 @@-{-
-   AAIndex.hs (adapted from aaindex.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2006 <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
+{-+   AAIndex.hs (adapted from aaindex.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <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

@@ -1,104 +1,104 @@-{-
-   AARGB.hs (adapted from aargb.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2006 <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
+{-+   AARGB.hs (adapted from aargb.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <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

@@ -1,132 +1,132 @@-{-
-   AccAnti.hs (adapted from accanti.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2006 <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
+{-+   AccAnti.hs (adapted from accanti.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <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

@@ -1,166 +1,166 @@-{-
-   AccPersp.hs (adapted from accpersp.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2006 <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
+{-+   AccPersp.hs (adapted from accpersp.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <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

@@ -1,91 +1,91 @@-{-
-   Alpha.hs (adapted from alpha.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Alpha.hs (adapted from alpha.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,124 +1,124 @@-{-
-   Alpha3D.hs (adapted from alpha3D.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2006 <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
+{-+   Alpha3D.hs (adapted from alpha3D.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <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

@@ -1,67 +1,67 @@-{-
-   BezCurve.hs (adapted from bezcurve.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   BezCurve.hs (adapted from bezcurve.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,84 +1,84 @@-{-
-   BezMesh.hs (adapted from bezmesh.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   BezMesh.hs (adapted from bezmesh.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,79 +1,79 @@-{-
-   BezSurf.hs (adapted from bezsurf.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   BezSurf.hs (adapted from bezsurf.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,95 +1,95 @@-{-
-   BlendEqn.hs (adapted from blendeqn.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   BlendEqn.hs (adapted from blendeqn.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,101 +1,101 @@-{-
-   Checker.hs  (adapted from checker.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Checker.hs  (adapted from checker.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,63 +1,63 @@-{-
-   Clip.hs (adapted from clip.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Clip.hs (adapted from clip.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,94 +1,94 @@-{-
-   Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,65 +1,65 @@-{-
-   ColorMatrix.hs (adapted from colormatrix.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   ColorMatrix.hs (adapted from colormatrix.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,62 +1,62 @@-{-
-   ColorTable.hs (adapted from colortable.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   ColorTable.hs (adapted from colortable.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,236 +1,236 @@-{-
-   Combiner.hs  (adapted from combiner.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Combiner.hs  (adapted from combiner.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,83 +1,83 @@-{-
-   Convolution.hs (adapted from convolution.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Convolution.hs (adapted from convolution.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,56 +1,56 @@-{-
-   Cube.hs (adapted from cube.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Cube.hs (adapted from cube.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,118 +1,118 @@-{-
-   CubeMap.hs  (adapted from CubeMap.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   CubeMap.hs  (adapted from CubeMap.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,85 +1,85 @@-{-
-   DList.hs (adapted from list.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   DList.hs (adapted from list.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,182 +1,182 @@-{-
-   DOF.hs (adapted from dof.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2006 <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
+{-+   DOF.hs (adapted from dof.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <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/Double.hs view

@@ -1,76 +1,76 @@-{-
-   Double.hs (adapted from double.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Double.hs (adapted from double.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,62 +1,62 @@-{-
-   DrawF.hs  (adapted from drawf.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   DrawF.hs  (adapted from drawf.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,77 +1,77 @@-{-
-   Feedback.hs (adapted from feedback.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Feedback.hs (adapted from feedback.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,90 +1,90 @@-{-
-   Fog.hs (adapted from fog.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Fog.hs (adapted from fog.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,122 +1,122 @@-{-
-   FogCoord.hs (adapted from fogcoord.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
-
-
+{-+   FogCoord.hs (adapted from fogcoord.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,76 +1,76 @@-{-
-   FogIndex.hs (adapted from fogindex.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   FogIndex.hs (adapted from fogindex.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,127 +1,127 @@-{-
-   Font.hs  (adapted from font.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Font.hs  (adapted from font.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,55 +1,55 @@-{-
-   Hello.hs (adapted from hello.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Hello.hs (adapted from hello.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,85 +1,85 @@-{-
-   Histogram.hs (adapted from histogram.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Histogram.hs (adapted from histogram.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,116 +1,116 @@-{-
-   Image.hs  (adapted from image.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Image.hs  (adapted from image.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,62 +1,62 @@-{-
-   Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,88 +1,88 @@-{-
-   Lines.hs (adapted from lines.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Lines.hs (adapted from lines.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,87 +1,87 @@-{-
-   MVArray.hs (adapted from mvarray.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   MVArray.hs (adapted from mvarray.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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/Makefile view

@@ -1,4 +1,4 @@-EXCLUDED_SOURCES := ReadImage.hs
-include ../examples.mk
-
-ColorMatrix ColorTable Convolution Histogram Minmax: ReadImage.o
+EXCLUDED_SOURCES := ReadImage.hs+include ../examples.mk++ColorMatrix ColorTable Convolution Histogram Minmax: ReadImage.o

examples/RedBook4/Material.hs view

@@ -1,149 +1,149 @@-{-
-   Material.hs (adapted from material.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Material.hs (adapted from material.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,64 +1,64 @@-{-
-   Minmax.hs (adapted from minmax.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Minmax.hs (adapted from minmax.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,97 +1,97 @@-{-
-   Mipmap.hs  (adapted from mipmap.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Mipmap.hs  (adapted from mipmap.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,86 +1,86 @@-{-
-   Model.hs (adapted from model.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Model.hs (adapted from model.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,85 +1,85 @@-{-
-   MoveLight.hs (adapted from movelight.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   MoveLight.hs (adapted from movelight.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,111 +1,111 @@-{-
-   MultiTex.hs  (adapted from multitex.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   MultiTex.hs  (adapted from multitex.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,137 +1,137 @@-{-
-   Multisamp.hs (adapted from multisamp.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2006 <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
+{-+   Multisamp.hs (adapted from multisamp.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <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

@@ -1,126 +1,126 @@-{-
-   PickDepth.hs (adapted from pickdepth.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   PickDepth.hs (adapted from pickdepth.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,121 +1,121 @@-{-
-   PickSquare.hs (adapted from picksquare.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   PickSquare.hs (adapted from picksquare.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,83 +1,83 @@-{-
-   Planet.hs (adapted from planet.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Planet.hs (adapted from planet.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,152 +1,152 @@-{-
-   PointP.hs (adapted from pointp.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2006 <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
+{-+   PointP.hs (adapted from pointp.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <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

@@ -1,151 +1,151 @@-{-
-   PolyOff.hs (adapted from polyoff.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2006 <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
+{-+   PolyOff.hs (adapted from polyoff.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <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

@@ -1,84 +1,84 @@-{-
-   Polys.hs (adapted from polys.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Polys.hs (adapted from polys.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,106 +1,106 @@-{-
-   Quadric.hs (adapted from quadric.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Quadric.hs (adapted from quadric.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,65 +1,65 @@-{-
-   ReadImage.hs (adapted from readImage.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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)
+{-+   ReadImage.hs (adapted from readImage.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,89 +1,89 @@-{-
-   Robot.hs (adapted from robot.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Robot.hs (adapted from robot.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,73 +1,73 @@-{-
-   Scene.hs (adapted from scene.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Scene.hs (adapted from scene.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,150 +1,150 @@-{-
-   Select.hs (adapted from select.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Select.hs (adapted from select.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,255 +1,255 @@-{-
-   ShadowMap.hs (adapted from shadowmap.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   ShadowMap.hs (adapted from shadowmap.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,65 +1,65 @@-{-
-   Smooth.hs (adapted from smooth.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Smooth.hs (adapted from smooth.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,123 +1,123 @@-{-
-   Stencil.hs (adapted from stencil.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2006 <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
+{-+   Stencil.hs (adapted from stencil.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <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

@@ -1,127 +1,127 @@-{-
-   Stroke.hs (adapted from stroke.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2006 <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
+{-+   Stroke.hs (adapted from stroke.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <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

@@ -1,129 +1,129 @@-{-
-   SurfPoints.hs (adapted from surfpoints.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   SurfPoints.hs (adapted from surfpoints.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,112 +1,112 @@-{-
-   Surface.hs (adapted from surface.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Surface.hs (adapted from surface.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,226 +1,226 @@-{-
-   Teapots.hs (adapted from teapots.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Teapots.hs (adapted from teapots.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,117 +1,117 @@-{-
-   Tess.hs (adapted from tess.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Tess.hs (adapted from tess.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,195 +1,195 @@-{-
-   TessWind.hs (adapted from tesswind.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   TessWind.hs (adapted from tesswind.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,108 +1,108 @@-{-
-   TexBind.hs  (adapted from texbind.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   TexBind.hs  (adapted from texbind.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,132 +1,132 @@-{-
-   TexGen.hs  (adapted from texgen.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   TexGen.hs  (adapted from texgen.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,58 +1,58 @@-{-
-   TexProx.hs (adapted from texprox.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   TexProx.hs (adapted from texprox.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,120 +1,120 @@-{-
-   TexSub.hs  (adapted from texsub.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   TexSub.hs  (adapted from texsub.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,94 +1,94 @@-{-
-   Texture3D.hs  (adapted from texture3d.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Texture3D.hs  (adapted from texture3d.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,99 +1,99 @@-{-
-   TextureSurf.hs (adapted from texturesurf.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   TextureSurf.hs (adapted from texturesurf.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,93 +1,93 @@-{-
-   Torus.hs (adapted from torus.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2006 <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
+{-+   Torus.hs (adapted from torus.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <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

@@ -1,107 +1,107 @@-{-
-   Trim.hs (adapted from trim.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Trim.hs (adapted from trim.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,54 +1,54 @@-{-
-   UnProject.hs (adapted from unproject.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   UnProject.hs (adapted from unproject.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,141 +1,141 @@-{-
-   VArray.hs (adapted from varray.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   VArray.hs (adapted from varray.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <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

@@ -1,114 +1,114 @@-{-
-   Wrap.hs  (adapted from wrap.c which is (c) Silicon Graphics, Inc)
-   Copyright (c) Sven Panne 2002-2005 <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
+{-+   Wrap.hs  (adapted from wrap.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <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/Makefile view

@@ -0,0 +1,2 @@+HC_SEARCH_PATHS := ../common+include ../../examples.mk

+ examples/RedBook8/Chapter01/Triangles.hs view

@@ -0,0 +1,88 @@+{-+   Triangles.hs (adapted from triangles.cpp which is (c) The Red Book Authors.)+   Copyright (c) Sven Panne 2013 <svenpanne@gmail.com>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/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 System.IO+import LoadShaders++-- TODO: Just for debugging, remove me later.+checkError :: String -> IO ()+checkError functionName = get errors >>= mapM_ reportError+  where reportError e =+          hPutStrLn stderr (showError e ++ " detected in " ++ functionName)+        showError (Error category message) =+          "GL error " ++ show category ++ " (" ++ message ++ ")"++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++  arrayBuffer <- genObjectName+  bindBuffer ArrayBuffer $= Just arrayBuffer+  withArray vertices $ \ptr -> do+    let size = fromIntegral (numVertices * sizeOf (head vertices))+    bufferData ArrayBuffer $= (size, ptr, StaticDraw)++  program <- loadShaders [+     ShaderInfo VertexShader (FileSource "triangles.vert"),+     ShaderInfo FragmentShader (FileSource "triangles.frac")]+  currentProgram $= Just program++  let firstIndex = 0+      vPosition = AttribLocation 0+  vertexAttribPointer vPosition $=+    (ToFloat, VertexArrayDescriptor 2 Float 0 (bufferOffset firstIndex))+  vertexAttribArray vPosition $= Enabled++  checkError "init"+  return $ Descriptor triangles firstIndex (fromIntegral numVertices)++display :: Descriptor -> DisplayCallback+display (Descriptor triangles firstIndex numVertices) = do+  clear [ ColorBuffer ]+  bindVertexArrayObject $= Just triangles+  drawArrays Triangles firstIndex numVertices+  flush+  checkError "display"++main :: IO ()+main = do+  (progName, _args) <- getArgsAndInitialize+  initialDisplayMode $= [ RGBAMode ]+  initialWindowSize $= Size 512 512+  initialContextVersion $= (4, 3)++  -- TODO: Just for debugging, remove me later.+  initialContextFlags $= [ DebugContext ]++  initialContextProfile $= [ CoreProfile ]+  _ <- createWindow progName+  descriptor <- init+  displayCallback $= display descriptor+  mainLoop

+ examples/RedBook8/Chapter01/triangles.frac 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/Makefile view

@@ -0,0 +1,2 @@+SUBDIRS := $(wildcard Chapter*)+include ../examples.mk

+ examples/RedBook8/common/LoadShaders.hs view

@@ -0,0 +1,94 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  LoadShaders+-- Copyright   :  (c) Sven Panne 2013+-- 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 qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Graphics.Rendering.OpenGL++--------------------------------------------------------------------------------++-- | 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++packUtf8 :: String -> B.ByteString+packUtf8 = TE.encodeUtf8 . T.pack++--------------------------------------------------------------------------------++-- | 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)

+ examples/RedBook8/common/Makefile view

@@ -0,0 +1,2 @@+include ../../examples.mk+HC := $(HC) -c

examples/examples.mk view

@@ -1,37 +1,37 @@-ALL_DIRS         := $(SUBDIRS:%=all-%)
-CLEAN_DIRS       := $(SUBDIRS:%=clean-%)
-HC               := ghc
-HC_FLAGS         := -v0 -Wall
-HC_PATH_FLAGS    := $(HC_SEARCH_PATHS:%=-i%)
-HS_SOURCES       := $(wildcard *.hs)
-HS_PROG_SOURCES  := $(filter-out $(EXCLUDED_SOURCES), $(HS_SOURCES))
-HS_PROGS         := $(HS_PROG_SOURCES:.hs=)
-
-.PHONY: all $(ALL_DIRS) all-common clean $(CLEAN_DIRS) foo
-
-all: $(ALL_DIRS) $(HS_PROGS)
-
-$(ALL_DIRS): all-common
-	$(MAKE) -C $(@:all-%=%) all
-
-all-common:
-ifneq ($(wildcard common),)
-	$(MAKE) -C common all
-endif
-
-clean: $(CLEAN_DIRS)
-ifneq ($(wildcard common),)
-	$(MAKE) -C common clean
-endif
-ifneq ($(HS_SOURCES),)
-	$(RM) $(HS_SOURCES:.hs=.hi) $(HS_SOURCES:.hs=.o) $(HS_PROG_SOURCES:.hs=.exe) $(HS_PROGS) $(wildcard *~)
-endif
-
-$(CLEAN_DIRS): 
-	$(MAKE) -C $(@:clean-%=%) clean
-
-$(HS_PROGS): %: %.hs
-	$(HC) $(HC_FLAGS) $(HC_PATH_FLAGS) $(EXTRA_HC_FLAGS) $<
-
-%.o: %.hs
-	$(HC) $(HC_FLAGS) $(HC_PATH_FLAGS) $(EXTRA_HC_FLAGS) $<
+ALL_DIRS         := $(SUBDIRS:%=all-%)+CLEAN_DIRS       := $(SUBDIRS:%=clean-%)+HC               := ghc+HC_FLAGS         := -v0 -Wall+HC_PATH_FLAGS    := $(HC_SEARCH_PATHS:%=-i%)+HS_SOURCES       := $(wildcard *.hs)+HS_PROG_SOURCES  := $(filter-out $(EXCLUDED_SOURCES), $(HS_SOURCES))+HS_PROGS         := $(HS_PROG_SOURCES:.hs=)++.PHONY: all $(ALL_DIRS) all-common clean $(CLEAN_DIRS) foo++all: $(ALL_DIRS) $(HS_PROGS)++$(ALL_DIRS): all-common+	$(MAKE) -C $(@:all-%=%) all++all-common:+ifneq ($(wildcard common),)+	$(MAKE) -C common all+endif++clean: $(CLEAN_DIRS)+ifneq ($(wildcard common),)+	$(MAKE) -C common clean+endif+ifneq ($(HS_SOURCES),)+	$(RM) $(HS_SOURCES:.hs=.hi) $(HS_SOURCES:.hs=.o) $(HS_PROG_SOURCES:.hs=.exe) $(HS_PROGS) $(wildcard *~)+endif++$(CLEAN_DIRS): +	$(MAKE) -C $(@:clean-%=%) clean++$(HS_PROGS): %: %.hs+	$(HC) $(HC_FLAGS) $(HC_PATH_FLAGS) $(EXTRA_HC_FLAGS) $<++%.o: %.hs+	$(HC) $(HC_FLAGS) $(HC_PATH_FLAGS) $(EXTRA_HC_FLAGS) $<

include/HsGLUTExt.h view

@@ -1,33 +1,33 @@-/* -----------------------------------------------------------------------------
- *
- * Module      :  GLUT extension support for Graphics.UI.GLUT
- * Copyright   :  (c) Sven Panne 2002-2013
- * License     :  BSD3
- *
- * Maintainer  :  Sven Panne <svenpanne@gmail.com>
- * Stability   :  stable
- * 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
+/* -----------------------------------------------------------------------------+ *+ * Module      :  GLUT extension support for Graphics.UI.GLUT+ * Copyright   :  (c) Sven Panne 2002-2013+ * License     :  BSD3+ *+ * Maintainer  :  Sven Panne <svenpanne@gmail.com>+ * Stability   :  stable+ * 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