packages feed

GLUT 2.1.2.0 → 2.1.2.1

raw patch · 97 files changed

+11433/−14 lines, 97 filesbinary-addedPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

GLUT.cabal view
@@ -1,5 +1,5 @@ name:		GLUT-version:	2.1.2.0+version:	2.1.2.1 license:	BSD3 license-file:	LICENSE maintainer:	Sven Panne <sven.panne@aedion.de>@@ -15,10 +15,109 @@ build-type:     Configure cabal-version:  >=1.2 extra-source-files:-	config.guess config.sub install-sh-	configure.ac configure GLUT.buildinfo.in-	include/HsGLUTConfig.h.in include/HsGLUT.h.in+	GLUT.buildinfo.in+	README+	aclocal.m4+	config.guess+	config.sub+	configure+	configure.ac+	examples/BOGLGP/Chapter01/OnYourOwn1.hs+	examples/BOGLGP/Chapter01/Simple.hs+	examples/BOGLGP/Chapter02/OnYourOwn1.hs+	examples/BOGLGP/Chapter02/OpenGLApplication.hs+	examples/BOGLGP/Chapter03/Lines.hs+	examples/BOGLGP/Chapter03/OnYourOwn1.hs+	examples/BOGLGP/Chapter03/Points.hs+	examples/BOGLGP/Chapter03/Polygons.hs+	examples/BOGLGP/Chapter03/TrianglesQuads.hs+	examples/Misc/ARBOcclude.hs+	examples/Misc/ExtractContours.hs+	examples/Misc/Gears.hs+	examples/Misc/Pitfall14.hs+	examples/Misc/Triangulate.hs+	examples/OrangeBook/3Dlabs-License.txt+	examples/OrangeBook/ogl2brick/Brick.frag+	examples/OrangeBook/ogl2brick/Brick.hs+	examples/OrangeBook/ogl2brick/Brick.vert+	examples/RedBook/00-README+	examples/RedBook/AAIndex.hs+	examples/RedBook/AARGB.hs+	examples/RedBook/AccAnti.hs+	examples/RedBook/AccPersp.hs+	examples/RedBook/Alpha.hs+	examples/RedBook/Alpha3D.hs+	examples/RedBook/BezCurve.hs+	examples/RedBook/BezMesh.hs+	examples/RedBook/BezSurf.hs+	examples/RedBook/BlendEqn.hs+	examples/RedBook/Checker.hs+	examples/RedBook/Clip.hs+	examples/RedBook/ColorMat.hs+	examples/RedBook/ColorMatrix.hs+	examples/RedBook/ColorTable.hs+	examples/RedBook/Combiner.hs+	examples/RedBook/Convolution.hs+	examples/RedBook/Cube.hs+	examples/RedBook/CubeMap.hs+	examples/RedBook/DList.hs+	examples/RedBook/DOF.hs+	examples/RedBook/Data/leeds.bin+	examples/RedBook/Double.hs+	examples/RedBook/DrawF.hs+	examples/RedBook/Feedback.hs+	examples/RedBook/Fog.hs+	examples/RedBook/FogCoord.hs+	examples/RedBook/FogIndex.hs+	examples/RedBook/Font.hs+	examples/RedBook/Hello.hs+	examples/RedBook/Histogram.hs+	examples/RedBook/Image.hs+	examples/RedBook/Light.hs+	examples/RedBook/Lines.hs+	examples/RedBook/MVArray.hs+	examples/RedBook/Material.hs+	examples/RedBook/Minmax.hs+	examples/RedBook/Mipmap.hs+	examples/RedBook/Model.hs+	examples/RedBook/MoveLight.hs+	examples/RedBook/MultiTex.hs+	examples/RedBook/Multisamp.hs+	examples/RedBook/PickDepth.hs+	examples/RedBook/PickSquare.hs+	examples/RedBook/Planet.hs+	examples/RedBook/PointP.hs+	examples/RedBook/PolyOff.hs+	examples/RedBook/Polys.hs+	examples/RedBook/Quadric.hs+	examples/RedBook/ReadImage.hs+	examples/RedBook/Robot.hs+	examples/RedBook/Scene.hs+	examples/RedBook/Select.hs+	examples/RedBook/ShadowMap.hs+	examples/RedBook/Smooth.hs+	examples/RedBook/Stencil.hs+	examples/RedBook/Stroke.hs+	examples/RedBook/SurfPoints.hs+	examples/RedBook/Surface.hs+	examples/RedBook/Teapots.hs+	examples/RedBook/Tess.hs+	examples/RedBook/TessWind.hs+	examples/RedBook/TexBind.hs+	examples/RedBook/TexGen.hs+	examples/RedBook/TexProx.hs+	examples/RedBook/TexSub.hs+	examples/RedBook/Texture3D.hs+	examples/RedBook/TextureSurf.hs+	examples/RedBook/Torus.hs+	examples/RedBook/Trim.hs+	examples/RedBook/UnProject.hs+	examples/RedBook/VArray.hs+	examples/RedBook/Wrap.hs+	include/HsGLUT.h.in+	include/HsGLUTConfig.h.in 	include/HsGLUTExt.h+	install-sh extra-tmp-files: 	config.log config.status autom4te.cache 	GLUT.buildinfo include/HsGLUTConfig.h include/HsGLUT.h
+ README view
@@ -0,0 +1,4 @@+To build this package using Cabal directly from darcs, you must run+"autoreconf" before the usual Cabal build steps (configure/build/install).+autoreconf is included in the GNU autoconf tools.  There is no need to run+the "configure" script: the "setup configure" step will do this for you.
+ aclocal.m4 view
@@ -0,0 +1,346 @@+# Extra autoconf macros for the Glasgow fptools+#+# To be a good autoconf citizen, names of local macros have prefixed with FP_ to+# ensure we don't clash with any pre-supplied autoconf ones.++dnl ** Map an arithmetic C type to a Haskell type.+dnl    Based on autconf's AC_CHECK_SIZEOF.++dnl FPTOOLS_CHECK_HTYPE(TYPE [, DEFAULT_VALUE, [, VALUE-FOR-CROSS-COMPILATION])+AC_DEFUN([FPTOOLS_CHECK_HTYPE],+[changequote(<<, >>)dnl+dnl The name to #define.+define(<<AC_TYPE_NAME>>, translit(htype_$1, [a-z *], [A-Z_P]))dnl+dnl The cache variable name.+define(<<AC_CV_NAME>>, translit(fptools_cv_htype_$1, [ *], [_p]))dnl+define(<<AC_CV_NAME_supported>>, translit(fptools_cv_htype_sup_$1, [ *], [_p]))dnl+changequote([, ])dnl+AC_MSG_CHECKING(Haskell type for $1)+AC_CACHE_VAL(AC_CV_NAME,+[AC_CV_NAME_supported=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+AC_RUN_IFELSE([AC_LANG_SOURCE([[#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef $1 testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}]])],[AC_CV_NAME=`cat conftestval`],+[ifelse([$2], , [AC_CV_NAME=NotReallyAType; AC_CV_NAME_supported=no], [AC_CV_NAME=$2])],+[ifelse([$3], , [AC_CV_NAME=NotReallyATypeCross; AC_CV_NAME_supported=no], [AC_CV_NAME=$3])])+CPPFLAGS="$fp_check_htype_save_cppflags"]) dnl+if test "$AC_CV_NAME_supported" = yes; then+  AC_MSG_RESULT($AC_CV_NAME)+  AC_DEFINE_UNQUOTED(AC_TYPE_NAME, $AC_CV_NAME, [Define to Haskell type for $1])+else+  AC_MSG_RESULT([not supported])+fi+undefine([AC_TYPE_NAME])dnl+undefine([AC_CV_NAME])dnl+undefine([AC_CV_NAME_supported])dnl+])+++# FP_ARG_OPENGL+# -------------+AC_DEFUN([FP_ARG_OPENGL],+[AC_ARG_ENABLE([opengl],+  [AC_HELP_STRING([--enable-opengl],+    [build a Haskell binding for OpenGL (GL/GLU). On Mac OS X, use+     --enable-opengl=x11 to use X11 instead of the "native" libraries.+     (default=autodetect)])],+  [enable_opengl=$enableval],+  [enable_opengl=yes])+])# FP_ARG_OPENGL+++# FP_ARG_GLUT+# -------------+AC_DEFUN([FP_ARG_GLUT],+[AC_REQUIRE([FP_ARG_OPENGL])+AC_ARG_ENABLE([glut],+  [AC_HELP_STRING([--enable-glut],+    [build a Haskell binding for GLUT (default=autodetect)])],+  [enable_glut=$enableval],+  [enable_glut=yes])+])# FP_ARG_GLUT+++# FP_CHECK_QUARTZ_OPENGL+# ----------------------+AC_DEFUN([FP_CHECK_QUARTZ_OPENGL],+[AC_REQUIRE([FP_ARG_OPENGL])+AC_REQUIRE([AC_CANONICAL_TARGET])++use_quartz_opengl=no+if test x"$enable_opengl" = xyes; then+  case $target_os in+  darwin*)+    AC_DEFINE([USE_QUARTZ_OPENGL], [1],+              [Define to 1 if native OpenGL should be used on Mac OS X])+    use_quartz_opengl=yes+    ;;+  esac+fi++GLU_FRAMEWORKS=+GLUT_FRAMEWORKS=+GLUT_EXTRA_LIBS=+if test x"$use_quartz_opengl" = xyes; then+  GLU_FRAMEWORKS=OpenGL+  GLUT_FRAMEWORKS=GLUT+  GLUT_EXTRA_LIBS=objc+fi+AC_SUBST([GLU_FRAMEWORKS])+AC_SUBST([GLUT_FRAMEWORKS])+AC_SUBST([GLUT_EXTRA_LIBS])+])# FP_CHECK_QUARTZ_OPENGL+++# FP_CHECK_WIN32+# --------------+# If Windows is the target platform (e.g. MinGW/MSYS or Cygwin with+# -mno-cygwin), the variable "fp_is_win32" is set to "yes", otherwise (e.g. *nix+# systems or plain Cygwin) it is set to "no".+AC_DEFUN([FP_CHECK_WIN32],+[AC_CACHE_CHECK([for Windows environment], [fp_cv_is_win32],+  [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([], [+#if !_WIN32+   syntax error;+#endif+])], [fp_cv_is_win32=yes], [fp_cv_is_win32=no])])+fp_is_win32="$fp_cv_is_win32"[]dnl+])# FP_CHECK_WIN32+++# FP_PATH_XTRA+# ------------+# Same as AC_PATH_XTRA, but works even for broken Cygwins which try to include+# the non-existant <gl/mesa_wgl.h> header when -mno-cygwin is used.+AC_DEFUN([FP_PATH_XTRA],+[AC_REQUIRE([FP_CHECK_WIN32])+if test x"$fp_is_win32" = xyes; then+  no_x=yes+else+  AC_PATH_XTRA+fi+])# FP_PATH_XTRA+++# FP_CHECK_GL_HELPER(LIBNAME, LIBS, INCLUDES, FUNCTION-BODY)+# ----------------------------------------------------------+# Try each library in LIBS to successfully link INCLUDES plus FUNCTION-BODY,+# setting LIBNAME_CFLAGS and LIBNAME_LIBS to the corresponding values. Sets+# no_LIBNAME to "yes" if no suitable library was found. (LIBNAME_CFLAGS0+# contains the value of LIBNAME_CFLAGS without CPPFLAGS, and LIBNAME_LIBS0+# contains the value of LIBNAME_LIBS without LDFLAGS, but these are only+# used internally.)+AC_DEFUN([FP_CHECK_GL_HELPER],+[AC_CACHE_CHECK([for $1 library], [fp_cv_check_$1_lib],+  [fp_cv_check_$1_lib="no"+  fp_save_CPPFLAGS="$CPPFLAGS"+  CPPFLAGS="$CPPFLAGS ${$1_CFLAGS}"+  fp_save_LIBS="$LIBS"+  for fp_try_lib in $2; do+    # transform "-lfoo" to "foo.lib" when using cl+    if test x"$CC" = xcl; then+      fp_try_lib=`echo $fp_try_lib | sed -e 's/^-l//' -e 's/$/.lib/'`+    fi+    LIBS="$fp_try_lib ${$1_LIBS} $fp_save_LIBS"+    AC_LINK_IFELSE([AC_LANG_PROGRAM([$3], [$4])], [fp_cv_check_$1_lib="$fp_try_lib ${$1_LIBS}"; break])+  done+  LIBS="$fp_save_LIBS"+  CPPFLAGS="$fp_save_CPPFLAGS"])++  if test x"$fp_cv_check_$1_lib" = xno; then+    no_$1=yes+    $1_CFLAGS=+    $1_LIBS=+  else+    $1_CFLAGS0="${$1_CFLAGS}"+    $1_CFLAGS="$CPPFLAGS ${$1_CFLAGS0}"+    $1_LIBS0="$fp_cv_check_$1_lib"+    $1_LIBS="$LDFLAGS ${$1_LIBS0}"+  fi+])# FP_CHECK_GL_HELPER+++# FP_CHECK_GL+# -----------+AC_DEFUN([FP_CHECK_GL],+[AC_REQUIRE([FP_PATH_XTRA])+AC_REQUIRE([FP_CHECK_QUARTZ_OPENGL])+AC_REQUIRE([FP_CHECK_WIN32])++if test x"$use_quartz_opengl" = xno; then+  AC_CHECK_FUNC(atan,[fp_libm_not_needed=yes],[fp_libm_not_needed=dunno])+  if test x"$fp_libm_not_needed" = xdunno; then+     AC_CHECK_LIB([m], [atan], [GL_LIBS="-lm $GL_LIBS"])+  fi++  if test x"$no_x" != xyes; then+    test -n "$x_includes" && GL_CFLAGS="-I$x_includes $GL_CFLAGS"+    test -n "$x_libraries" && GL_LIBS="-L$x_libraries -lX11 $GL_LIBS"+  fi++  FP_CHECK_GL_HELPER([GL], [-lGL -lopengl32], [@%:@include <GL/gl.h>], [glEnd()])++  if test x"$fp_is_win32" = xyes; then+    # Ugly: To get wglGetProcAddress on Windows, we have to link with+    # opengl32.dll, too, even when we are using Cygwin with X11.+    case "$GL_LIBS" in+      *-lopengl32*|*opengl32.lib*) ;;+      *) fp_save_LIBS="$LIBS"+         LIBS="$LIBS -lopengl32"+         AC_LINK_IFELSE([AC_LANG_PROGRAM([[@%:@include <GL/gl.h>]], [[glEnd()]])],+           [GL_LIBS="$GL_LIBS -lopengl32"; GL_LIBS0="$GL_LIBS0 -lopengl32"])+         LIBS="$fp_save_LIBS"+         ;;+    esac+  fi+fi+AC_SUBST([GL_CFLAGS])+AC_SUBST([GL_LIBS])+])# FP_CHECK_GL+++# FP_CHECK_GLU+# ------------+AC_DEFUN([FP_CHECK_GLU],+[AC_REQUIRE([FP_CHECK_GL])dnl+GLU_CFLAGS="$GL_CFLAGS0"+GLU_LIBS="$GL_LIBS0"++if test x"$use_quartz_opengl" = xno; then+  FP_CHECK_GL_HELPER([GLU], [-lglu32 -lGLU], [@%:@include <GL/glu.h>], [gluNewQuadric()])+fi++AC_SUBST([GLU_CFLAGS])+AC_SUBST([GLU_LIBS])+])# FP_CHECK_GLU+++# FP_CHECK_GLUT+# -------------+AC_DEFUN([FP_CHECK_GLUT],+[AC_REQUIRE([FP_CHECK_GLU])+AC_REQUIRE([FP_CHECK_QUARTZ_OPENGL])++if test x"$use_quartz_opengl" = xno; then+  GLUT_CFLAGS="$GLU_CFLAGS0"+  GLUT_LIBS="$GLU_LIBS0"++  if test x"$no_x" != xyes; then+    GLUT_LIBS="$X_PRE_LIBS -lXmu -lXi $X_EXTRA_LIBS $GLUT_LIBS"+  fi++  AC_CHECK_HEADERS([windows.h])++  fp_save_cppflags="$CPPFLAGS"+  CPPFLAGS="$CPPFLAGS $X_CFLAGS"+  AC_CHECK_HEADERS([GL/glut.h])+  CPPFLAGS="$fp_save_cppflags"++  # Note 1: On Cygwin with X11, GL/GLU functions use the "normal" calling+  # convention, but GLUT functions use stdcall. To get this right, it is+  # necessary to include <windows.h> first.+  # Note 2: MinGW/MSYS comes without a GLUT header, so we use Cygwin's one in+  # that case.+  FP_CHECK_GL_HELPER([GLUT], [-lglut32 -lglut], [+#if HAVE_WINDOWS_H+#include <windows.h>+#endif+#if HAVE_GL_GLUT_H+#include <GL/glut.h>+#else+#include "glut_local.h"+#endif+    ], [glutMainLoop()])+fi++AC_SUBST([GLUT_CFLAGS])+AC_SUBST([GLUT_LIBS])+])# FP_CHECK_GLUT+++# FP_ARG_COMPILER+# -------------+AC_DEFUN([FP_ARG_COMPILER],+[AC_ARG_WITH([compiler],+  [AC_HELP_STRING([--with-compiler@<:@=HC@:>@],+    [use the given Haskell compiler (default=ghc)])],+  [with_compiler=$withval],+  [with_compiler=ghc])+])# FP_ARG_COMPILER
configure view
@@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles.-# Generated by GNU Autoconf 2.63 for Haskell GLUT package 2.1.2.0.+# Generated by GNU Autoconf 2.63 for Haskell GLUT package 2.1.2.1. # # Report bugs to <sven.panne@aedion.de>. #@@ -596,8 +596,8 @@ # Identity of this package. PACKAGE_NAME='Haskell GLUT package' PACKAGE_TARNAME='GLUT'-PACKAGE_VERSION='2.1.2.0'-PACKAGE_STRING='Haskell GLUT package 2.1.2.0'+PACKAGE_VERSION='2.1.2.1'+PACKAGE_STRING='Haskell GLUT package 2.1.2.1' PACKAGE_BUGREPORT='sven.panne@aedion.de'  ac_unique_file="include/HsGLUT.h.in"@@ -1285,7 +1285,7 @@   # Omit some internal or obsolete options to make the list less imposing.   # This message is too long to be a string in the A/UX 3.1 sh.   cat <<_ACEOF-\`configure' configures Haskell GLUT package 2.1.2.0 to adapt to many kinds of systems.+\`configure' configures Haskell GLUT package 2.1.2.1 to adapt to many kinds of systems.  Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1355,7 +1355,7 @@  if test -n "$ac_init_help"; then   case $ac_init_help in-     short | recursive ) echo "Configuration of Haskell GLUT package 2.1.2.0:";;+     short | recursive ) echo "Configuration of Haskell GLUT package 2.1.2.1:";;    esac   cat <<\_ACEOF @@ -1453,7 +1453,7 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then   cat <<\_ACEOF-Haskell GLUT package configure 2.1.2.0+Haskell GLUT package configure 2.1.2.1 generated by GNU Autoconf 2.63  Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,@@ -1467,7 +1467,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by Haskell GLUT package $as_me 2.1.2.0, which was+It was created by Haskell GLUT package $as_me 2.1.2.1, which was generated by GNU Autoconf 2.63.  Invocation command line was    $ $0 $@@@ -6687,7 +6687,7 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log="-This file was extended by Haskell GLUT package $as_me 2.1.2.0, which was+This file was extended by Haskell GLUT package $as_me 2.1.2.1, which was generated by GNU Autoconf 2.63.  Invocation command line was    CONFIG_FILES    = $CONFIG_FILES@@ -6746,7 +6746,7 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_version="\\-Haskell GLUT package config.status 2.1.2.0+Haskell GLUT package config.status 2.1.2.1 configured by $0, generated by GNU Autoconf 2.63,   with options \\"`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\"
configure.ac view
@@ -1,4 +1,4 @@-AC_INIT([Haskell GLUT package], [2.1.2.0], [sven.panne@aedion.de], [GLUT])+AC_INIT([Haskell GLUT package], [2.1.2.1], [sven.panne@aedion.de], [GLUT])  # Safety check: Ensure that we are in the correct source directory. AC_CONFIG_SRCDIR([include/HsGLUT.h.in])
+ examples/BOGLGP/Chapter01/OnYourOwn1.hs view
@@ -0,0 +1,111 @@+{-+   OnYourOwn1.hs (adapted from Simple.cpp which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2004-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE+-}++import Control.Monad ( unless )+import 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
@@ -0,0 +1,111 @@+{-+   Simple.hs (adapted from Simple.cpp which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2004-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE+-}++import Control.Monad ( unless )+import 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/OnYourOwn1.hs view
@@ -0,0 +1,230 @@+{-+   OnYourOwn1.hs (adapted from OpenGLApplication which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2004-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE+-}++import Control.Monad ( when, unless )+import Data.IORef ( IORef, newIORef )+import 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
@@ -0,0 +1,230 @@+{-+   OpenGLApplication.hs (adapted from OpenGLApplication which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2004-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE+-}++import Control.Monad ( when, unless )+import Data.IORef ( IORef, newIORef )+import 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
@@ -0,0 +1,210 @@+{-+   Lines.hs (adapted from Lines which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2004-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE+-}++import Control.Monad ( when, unless, 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/OnYourOwn1.hs view
@@ -0,0 +1,217 @@+{-+   OnYourOwn1.hs (adapted from OnYourOwn1 which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE+-}++import Control.Monad ( when, unless )+import Data.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
@@ -0,0 +1,196 @@+{-+   Points.hs (adapted from Points which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2004-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE+-}++import Control.Monad ( when, unless, 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
@@ -0,0 +1,230 @@+{-+   Polygons.hs (adapted from Polygons which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2004-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE+-}++import Control.Monad ( when, unless )+import Data.IORef ( IORef, newIORef )+import 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
@@ -0,0 +1,294 @@+{-+   TrianglesQuads.hs (adapted from TrianglesQuads which is (c) 2004 Astle/Hawkins)+   Copyright (c) Sven Panne 2004-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE+-}++import Control.Monad ( when, unless )+import Data.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/Misc/ARBOcclude.hs view
@@ -0,0 +1,193 @@+{-+   ARBOcclude.hs (adapted from arbocclude.c which is (c) Brian Paul)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE+-}++import Control.Monad ( unless, 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 ] <- genObjectNames 1+   displayCallback $= display occQuery state+   myInit+   mainLoop
+ examples/Misc/ExtractContours.hs view
@@ -0,0 +1,117 @@+{-+   ExtractContours.hs (adapted from tess.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates 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 GLclampf)+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 GLclampf)+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
@@ -0,0 +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 <sven.panne@aedion.de>+   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/Pitfall14.hs view
@@ -0,0 +1,33 @@+{-+   Pitfall14+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates 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/Triangulate.hs view
@@ -0,0 +1,120 @@+{-+   Triangulate.hs (adapted from tess.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates polygon 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++randomColor :: IO ()+randomColor = do+   r <- randomIO+   g <- randomIO+   b <- randomIO+   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+   color3f (Color3 r g b)++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/3Dlabs-License.txt view
@@ -0,0 +1,33 @@+Copyright (C) 2002-2005  3Dlabs Inc. Ltd.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++    Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.++    Redistributions in binary form must reproduce the above+    copyright notice, this list of conditions and the following+    disclaimer in the documentation and/or other materials provided+    with the distribution.++    Neither the name of 3Dlabs Inc. Ltd. nor the names of its+    contributors may be used to endorse or promote products derived+    from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS+FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.++
+ examples/OrangeBook/ogl2brick/Brick.frag view
@@ -0,0 +1,36 @@+//+// Fragment shader for procedural bricks+//+// Authors: Dave Baldwin, Steve Koren, Randi Rost+//          based on a shader by Darwyn Peachey+//+// Copyright (c) 2002-2004 3Dlabs Inc. Ltd.+//+// See 3Dlabs-License.txt for license information+//++uniform vec3  BrickColor, MortarColor;+uniform vec2  BrickSize;+uniform vec2  BrickPct;++varying vec2  MCposition;+varying float LightIntensity;++void main(void)+{+    vec3  color;+    vec2  position, useBrick;++    position = MCposition / BrickSize;++    if (fract(position.y * 0.5) > 0.5)+        position.x += 0.5;++    position = fract(position);++    useBrick = step(position, BrickPct);++    color  = mix(MortarColor, BrickColor, useBrick.x * useBrick.y);+    color *= LightIntensity;+    gl_FragColor = vec4 (color, 1.0);+}
+ examples/OrangeBook/ogl2brick/Brick.hs view
@@ -0,0 +1,377 @@+{-+   Brick.hs (adapted from ogl2brick.c which is (c) 3Dlabs Inc. Ltd.)+   Copyright (c) Sven Panne 2006 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE+-}++import Control.Monad+import Data.IORef+import System.Exit+import Graphics.UI.GLUT++inertiaThreshold, inertiaFactor :: GLfloat+inertiaThreshold = 1+inertiaFactor = 0.5++scaleFactor, scaleIncrement :: GLfloat+scaleFactor = 0.01+scaleIncrement = 0.5++timerFrequencyMillis :: Timeout+timerFrequencyMillis = 20++clearColors :: [Color4 GLfloat]+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 GLfloat],+   modelCycle :: IORef [IO ()],+   modifiers :: IORef Modifiers+   }++makeState :: IO State+makeState = do+   di <- newIORef initialDiff+   li <- newIORef 0+   ia <- newIORef initialInertia+   io <- newIORef 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+      }++instance Num a => Num (Vector3 a) where+   (Vector3 x1 y1 z1) + (Vector3 x2 y2 z2) =+      Vector3 (x1 + x2) (y1 + y2) (z1 + z2)+   (Vector3 x1 y1 z1) - (Vector3 x2 y2 z2) =+      Vector3 (x1 - x2) (y1 - y2) (z1 - z2)+   (Vector3 x1 y1 z1) * (Vector3 x2 y2 z2) =+      Vector3 (x1 * x2) (y1 * y2) (z1 * z2)+   negate (Vector3 x y z) =+      Vector3 (negate x) (negate y) (negate z)+   abs (Vector3 x y z) =+      Vector3 (abs x) (abs y) (abs z)+   signum (Vector3 x y z) =+      Vector3 (signum x) (signum y) (signum z)+   fromInteger i =+      Vector3 (fromInteger i) (fromInteger i) (fromInteger i)++fromScalar :: Num a => a -> Vector3 a+fromScalar s = Vector3 s s s++step :: (Num a, Ord a) => Vector3 a -> Vector3 a -> Vector3 a+step (Vector3 x1 y1 z1) (Vector3 x2 y2 z2) =+   Vector3 (s x1 x2) (s y1 y2) (s z1 z2)+   where s e x = if x < e then 0 else 1++dot :: Num a => Vector3 a -> Vector3 a -> a+dot (Vector3 x1 y1 z1) (Vector3 x2 y2 z2) = x1 * x2 + y1 * y2 + z1 * z2++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 $= 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 = fromScalar inertiaThreshold+       f = fromScalar inertiaFactor+       l = (1 - (step (-t) li)) * ((li + t) * f - ia)+       r = (step t li) * ((li - t) * f - ia)+   inertia state $= l + ia + r+   lastIncr state $= 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 $= 0+         lastIncr state $= 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 :: Shader s => FilePath -> IO s+readAndCompileShader filePath = do+   src <- readFile filePath+   [shader] <- genObjectNames 1+   shaderSource 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 :: [VertexShader] -> [FragmentShader] -> IO ()+installBrickShaders vs fs = do+   [brickProg] <- genObjectNames 1+   attachedShaders brickProg $= (vs, fs)+   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)++   catch+     (do checkGLSLSupport+         vs <- readAndCompileShader "Brick.vert"+         fs <- readAndCompileShader "Brick.frag"+         installBrickShaders [vs] [fs])+     (\exception -> do+         print exception+         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/Brick.vert view
@@ -0,0 +1,41 @@+//+// Vertex shader for procedural bricks+//+// Authors: Dave Baldwin, Steve Koren, Randi Rost+//          based on a shader by Darwyn Peachey+//+// Copyright (c) 2002-2004 3Dlabs Inc. Ltd.+//+// See 3Dlabs-License.txt for license information+//++uniform vec3 LightPosition;++const float SpecularContribution = 0.3;+const float DiffuseContribution  = 1.0 - SpecularContribution;++varying float LightIntensity;+varying vec2  MCposition;++void main(void)+{+    vec3 ecPosition = vec3 (gl_ModelViewMatrix * gl_Vertex);+    vec3 tnorm      = normalize(gl_NormalMatrix * gl_Normal);+    vec3 lightVec   = normalize(LightPosition - ecPosition);+    vec3 reflectVec = reflect(-lightVec, tnorm);+    vec3 viewVec    = normalize(-ecPosition);+    float diffuse   = max(dot(lightVec, tnorm), 0.0);+    float spec      = 0.0;++    if (diffuse > 0.0)+    {+        spec = max(dot(reflectVec, viewVec), 0.0);+        spec = pow(spec, 16.0);+    }++    LightIntensity  = DiffuseContribution * diffuse ++                      SpecularContribution * spec;++    MCposition      = gl_Vertex.xy;+    gl_Position     = ftransform();+}
+ examples/RedBook/00-README view
@@ -0,0 +1,189 @@+This file lists the programs that are referenced in the OpenGL Programming+Guide, Fourth Edition, by chapter. For each program, the version of OpenGL+that is required is listed with the program.++Chapter 1: Introduction to OpenGL++        Hello.hs        (1.0)+        Double.hs       (1.0)++Chapter 2: State Management and Drawing Geometric Objects++        Lines.hs        (1.0)+        Polys.hs        (1.0)+        VArray.hs       (1.1)+        MVArray.hs      (1.4)++Chapter 3: Viewing++        Cube.hs         (1.0)+        Model.hs        (1.0)+        Clip.hs         (1.0)+        Planet.hs       (1.0)+        Robot.hs        (1.0)+        UnProject.hs    (1.1)++Chapter 4: Color++        Smooth.hs       (1.0)++Chapter 5: Lighting++        Light.hs        (1.0)+        MoveLight.hs    (1.0)+        Material.hs     (1.0)+        ColorMat.hs     (1.1)+        Scene.hs        (1.0)++Chapter 6: Blending, Antialiasing, Fog, and Polygon Offset++        BlendEqn.hs     (1.3 or ARB_imaging_subset)+        Alpha.hs        (1.0)+        Alpha3D.hs      (1.1)+        AARGB.hs        (1.1)+        AAIndex.hs      (1.1)+        Multisamp.hs    (1.3)+        Fog.hs          (1.0)+        FogIndex.hs     (1.0)+        FogCoord.hs     (1.4)+        PointP.hs       (1.4)+        PolyOff.hs      (1.1)++Chapter 7: Display Lists++        Torus.hs        (1.0)+        DList.hs        (1.0)+        Stroke.hs       (1.0)++Chapter 8: Drawing Pixels, Bitmaps, Fonts, and Images++        DrawF.hs        (1.0)+        Font.hs         (1.0)+        Image.hs        (1.1)+        ColorTable.hs   (ARB_imaging_subset)+        Convolution.hs  (ARB_imaging_subset)+        ColorMatrix.hs  (ARB_imaging_subset)+        Histogram.hs    (ARB_imaging_subset)+        Minmax.hs       (ARB_imaging_subset)++Chapter 9: Texture Mapping++        Checker.hs      (1.0)+        TexSub.hs       (1.1)+        Texture3D.hs    (1.2)+        Mipmap.hs       (1.0)+        TexBind.hs      (1.1)+        TexGen.hs       (1.1)+        CubeMap.hs      (1.3)+        MultiTex.hs     (1.3 or ARB_multitexture)+        Combiner.hs     (1.3)+        ShadowMap.hs    (1.4)+        Wrap.hs         (1.0)+        TexProx.hs      (1.1)++Chapter 10: The Framebuffer++        Stencil.hs      (1.0)+        AccPersp.hs     (1.0)+        AccAnti.hs      (1.0)+        DOF.hs          (1.0)++Chapter 11: Tessellators and Quadrics++        Tess.hs         (1.1)+        TessWind.hs     (1.1)+        Quadric.hs      (1.1)++Chapter 12: Evaluators and NURBS++        BezCurve.hs     (1.1)+        BezSurf.hs      (1.1)+        BezMesh.hs      (1.1)+        TextureSurf.hs  (1.1)+        Surface.hs      (1.1)+        SurfPoints.hs   (1.2)+        Trim.hs         (1.1)++Chapter 13: Selection and Feedback++        Select.hs       (1.1)+        PickSquare.hs   (1.0)+        PickDepth.hs    (1.0)+        Feedback.hs     (1.0)++Chapter 14: Now That You Know++        <No programs included>++Color Plates:++        Teapots.hs      (1.1)++Some remarks regarding the style of the programs:++To ease comparisons, the Haskell programs in this directory try to stay as+close to the original examples in C as possible. Consequently, they should+not be considered as examples for the best way to implement things in+Haskell.++The Haskell OpenGL binding uses overloading quite extensively, which makes+its use quite flexible, e.g.:++   class Vertex a where+      vertex  ::     a -> IO ()+      vertexv :: Ptr a -> IO ()++This single class subsumes all 24 vertex specification calls in OpenGL's C+binding, i.e. glVertex{234}{sifd}[v](), with the help of the following+class and instances:++   class VertexComponent a  -- an opaque class++   VertexComponent GLshort+   VertexComponent GLint+   VertexComponent GLfloat+   VertexComponent GLdouble++   VertexComponent a => Vertex (Vertex2 a)+   VertexComponent a => Vertex (Vertex3 a)+   VertexComponent a => Vertex (Vertex4 a)++There is a small inconvenience with this when used in "toy" programs:+Haskell's numeric literals are overloaded, too, so the programmer's help is+needed to disambiguate the type of expressions like:++   vertex (Vertex3 0 0 1)++Let's assume we mean the equivalent of glVertex3f() here. One can either+use an explicitly typed helper function:++   let vertex3f = vertex :: Vertex3 GLfloat -> IO ()+   in vertex3f (Vertex3 0 0 1)++This comes in handy when there are a lot of uses of vertex3f. An+alternative is to use a type annotation for the literal:++   vertex (Vertex3 0 0 (1 :: GLfloat))++or a type annotation for the vertex:++   vertex (Vertex3 0 0 1 :: Vertex3 GLfloat)++This is largely a matter of taste and normally not a problem in "real"+programs with type signatures for functions.++Sometimes different callbacks need to share some state, which is done via+global variables in the C examples. To achieve a unified presentation, all+Haskell examples use a `State' type for this purpose, which collects the+different parts of the global state, i.e. one or more IORefs. There are+alternatives for modeling this, which should be considered in own programs,+depending on the use cases:++ * Separate IORefs: This makes it explicit which parts of the program need+   which parts of the state.++ * A single IORef/MVar containing all the state: This enables one to change+   the whole state atomically, which is often quite handy in multithreaded+   programs.++ * A custom monad: This can hide all the state threading behind the scenes.
+ examples/RedBook/AAIndex.hs view
@@ -0,0 +1,104 @@+{-+   AAIndex.hs (adapted from aaindex.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program draws shows how to draw anti-aliased lines in color index+   mode. It draws two diagonal lines to form an X; when 'r' is typed in the+   window, the lines are rotated in opposite directions.+-}++import Data.Char ( toLower )+import Data.IORef ( IORef, newIORef )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++data State = State { rotAngle :: IORef Int }++makeState :: IO State+makeState = do+   r <- newIORef 0+   return $ State { rotAngle = r }++rampSize, ramp1Start, ramp2Start :: GLint+rampSize = 16+ramp1Start = 32+ramp2Start = 48++-- Initialize antialiasing for color index mode, including loading a green color+-- ramp starting at ramp1Start, and a blue color ramp starting at ramp2Start.+-- The ramps must be a multiple of 16.+myInit :: IO ()+myInit = do+   flip mapM_ [ 0 .. rampSize - 1 ] $ \i -> do+      let shade = fromIntegral i / fromIntegral rampSize+      colorMapEntry (Index1 (ramp1Start + i)) $= Color3 0 shade 0+      colorMapEntry (Index1 (ramp2Start + i)) $= Color3 0 0 shade++   lineSmooth $= Enabled+   hint LineSmooth $= DontCare+   lineWidth $= 1.5++   clearIndex $= Index1 (fromIntegral ramp1Start)++-- Draw 2 diagonal lines to form an X+display :: State -> DisplayCallback+display state = do+   r <- get (rotAngle state)+   clear [ ColorBuffer ]++   -- resolve overloading, not needed in "real" programs+   let vertex2f = vertex :: Vertex2 GLfloat -> IO ()++   index (Index1 ramp1Start)+   preservingMatrix $ do+      rotate (-(fromIntegral r :: GLfloat)) (Vector3 0 0 0.1)+      renderPrimitive Lines $ do+         vertex2f (Vertex2 (-0.5) 0.5)+         vertex2f (Vertex2 0.5 (-0.5))++   index (Index1 ramp2Start)+   preservingMatrix $ do+      rotate (fromIntegral r :: GLfloat) (Vector3 0 0 0.1)+      renderPrimitive Lines $ do+         vertex2f (Vertex2 0.5 0.5)+         vertex2f (Vertex2 (-0.5) (-0.5))++   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho2D (-1) 1 (-1*hf/wf) (1*hf/wf)+      else ortho2D (-1*wf/hf) (1*wf/hf) (-1) 1+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: State -> KeyboardMouseCallback+keyboard state (Char c) Down _ _ = case toLower c of+   'r'   -> do rotAngle state  $~ ((`mod` 360) . (+ 30)); postRedisplay Nothing+   '\27' -> exitWith ExitSuccess+   _     -> return ()+keyboard _ _ _ _ _ = return ()++-- Main Loop+-- Open window with initial window size, title bar,+-- color index display mode, and handle input events.+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, IndexMode ]+   initialWindowSize $= Size 200 200+   createWindow progName+   state <- makeState+   myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboard state)+   displayCallback $= display state+   mainLoop
+ examples/RedBook/AARGB.hs view
@@ -0,0 +1,104 @@+{-+   AARGB.hs (adapted from aargb.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program draws shows how to draw anti-aliased lines. It draws two+   diagonal lines to form an X; when 'r' is typed in the window, the lines are+   rotated in opposite directions.+-}++import Data.Char ( toLower )+import Data.IORef ( IORef, newIORef )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++data State = State { rotAngle :: IORef Int }++makeState :: IO State+makeState = do+   r <- newIORef 0+   return $ State { rotAngle = r }++-- Initialize antialiasing for RGBA mode, including alpha blending, hint, and+-- line width. Print out implementation specific info on line width granularity+-- and width.+myInit :: IO ()+myInit = do+   g <- get smoothLineWidthGranularity+   putStrLn ("smoothLineWidthGranularity is " ++ show g)++   r <- get smoothLineWidthRange+   putStrLn ("smoothLineWidthRange is " ++ show r)++   lineSmooth $= Enabled++   blend $= Enabled+   blendFunc $= (SrcAlpha, OneMinusSrcAlpha)+   hint LineSmooth $= DontCare+   lineWidth $= 1.5++   clearColor $= Color4 0 0 0 0++-- Draw 2 diagonal lines to form an X+display :: State -> DisplayCallback+display state = do+   r <- get (rotAngle state)+   clear [ ColorBuffer ]++   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+       vertex2f = vertex :: Vertex2 GLfloat -> IO ()++   color3f (Color3 0 1 0)+   preservingMatrix $ do+      rotate (-(fromIntegral r :: GLfloat)) (Vector3 0 0 0.1)+      renderPrimitive Lines $ do+         vertex2f (Vertex2 (-0.5) 0.5)+         vertex2f (Vertex2 0.5 (-0.5))++   color3f (Color3 0 0 1)+   preservingMatrix $ do+      rotate (fromIntegral r :: GLfloat) (Vector3 0 0 0.1)+      renderPrimitive Lines $ do+         vertex2f (Vertex2 0.5 0.5)+         vertex2f (Vertex2 (-0.5) (-0.5))++   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho2D (-1) 1 (-1*hf/wf) (1*hf/wf)+      else ortho2D (-1*wf/hf) (1*wf/hf) (-1) 1+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: State -> KeyboardMouseCallback+keyboard state (Char c) Down _ _ = case toLower c of+   'r'   -> do rotAngle state  $~ ((`mod` 360) . (+ 30)); postRedisplay Nothing+   '\27' -> exitWith ExitSuccess+   _     -> return ()+keyboard _ _ _ _ _ = return ()++-- Main Loop+-- Open window with initial window size, title bar,+-- RGBA display mode, and handle input events.+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 200 200+   createWindow progName+   state <- makeState+   myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboard state)+   displayCallback $= display state+   mainLoop
+ examples/RedBook/AccAnti.hs view
@@ -0,0 +1,132 @@+{-+   AccAnti.hs (adapted from accanti.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   Use the accumulation buffer to do full-scene antialiasing on a scene with+   orthographic parallel projection.+-}++import Data.List ( genericLength )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++-- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a+-- gaussian distribution around the origin. Use these to do model jittering for+-- scene anti-aliasing and view volume jittering for depth of field effects. Use+-- in conjunction with the accwindow routine.+j8 :: [Vector2 GLdouble]+j8 = [+   Vector2 (-0.334818)   0.435331 ,+   Vector2   0.286438  (-0.393495),+   Vector2   0.459462    0.141540 ,+   Vector2 (-0.414498) (-0.192829),+   Vector2 (-0.183790)   0.082102 ,+   Vector2 (-0.079263) (-0.317383),+   Vector2   0.102254    0.299133 ,+   Vector2   0.164216  (-0.054399) ]++-- Initialize lighting and other values.+myInit :: IO ()+myInit = do+   materialAmbient Front $= Color4 1 1 1 1+   materialSpecular Front $= Color4 1 1 1 1+   materialShininess Front $= 50+   position (Light 0) $= Vertex4 0 0 10 1+   lightModelAmbient $= Color4 0.2 0.2 0.2 1++   lighting $= Enabled+   light (Light 0) $= Enabled+   depthFunc $= Just Less+   shadeModel $= Flat++   clearColor $= Color4 0 0 0 0+   clearAccum $= Color4 0 0 0 0++displayObjects :: IO ()+displayObjects = do+   -- resolve overloading, not needed in "real" programs+   let translatef = translate :: Vector3 GLfloat -> IO ()+       rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO ()++   preservingMatrix $ do+      rotatef 30 (Vector3 1 0 0)++      preservingMatrix $ do+         translatef (Vector3 (-0.80) 0.35 0)+         rotatef 100 (Vector3 1 0 0)+         materialDiffuse Front $= Color4 0.7 0.7 0 1+         renderObject Solid (Torus 0.275 0.85 16 16)++      preservingMatrix $ do+         translatef (Vector3 (-0.75) (-0.50) 0)+         rotatef 45 (Vector3 0 0 1)+         rotatef 45 (Vector3 1 0 0)+         materialDiffuse Front $= Color4 0 0.7 0.7 1+         renderObject Solid (Cube 1.5)++      preservingMatrix $ do+         translatef (Vector3 0.75 0.60 0)+         rotatef 30 (Vector3 1 0 0)+         materialDiffuse Front $= Color4 0.7 0 0.7 1+         renderObject Solid (Sphere' 1 16 16)++      preservingMatrix $ do+         translatef (Vector3 0.70 (-0.90) 0.25)+         materialDiffuse Front $= Color4 0.7 0.4 0.4 1+         renderObject Solid Octahedron++-- display draws 5 teapots into the accumulation buffer several times; each time+-- with a jittered perspective. The focal point is at z = 5.0, so the gold+-- teapot will stay in focus. The amount of jitter is adjusted by the magnitude+-- of the accPerspective jitter; in this example, 0.33. In this example, the+-- teapots are drawn 8 times.+display :: DisplayCallback+display = do+   (_, Size w h) <- get viewport+   clear [ AccumBuffer ]++   flip mapM_ j8 $ \(Vector2 x y) -> do+      clear [ ColorBuffer, DepthBuffer ]+      preservingMatrix $ do+         -- Note that 4.5 is the distance in world space between left and right+         -- and bottom and top. This formula converts fractional pixel movement+         -- to world coordinates.+         translate (Vector3 (x*4.5/fromIntegral w) (y*4.5/fromIntegral h) 0)+         displayObjects+      accum Accum (recip (genericLength j8))++   accum Return 1+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho (-2.25) 2.25 (-2.25*hf/wf) (2.25*hf/wf) (-10) 10+      else ortho (-2.25*wf/hf) (2.25*wf/hf) (-2.25) 2.25 (-10) 10+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++-- Main Loop: Be certain to request an accumulation buffer.+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ]+   initialWindowSize $= Size 250 250+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   reshapeCallback $= Just reshape+   displayCallback $= display+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/AccPersp.hs view
@@ -0,0 +1,166 @@+{-+   AccPersp.hs (adapted from accpersp.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   Use the accumulation buffer to do full-scene antialiasing on a scene with+   perspective projection, using the special routines accFrustum and+   accPerspective.+-}++import Data.List ( genericLength )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++-- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a+-- gaussian distribution around the origin. Use these to do model jittering for+-- scene anti-aliasing and view volume jittering for depth of field effects. Use+-- in conjunction with the accwindow routine.+j8 :: [Vector2 GLdouble]+j8 = [+   Vector2 (-0.334818)   0.435331 ,+   Vector2   0.286438  (-0.393495),+   Vector2   0.459462    0.141540 ,+   Vector2 (-0.414498) (-0.192829),+   Vector2 (-0.183790)   0.082102 ,+   Vector2 (-0.079263) (-0.317383),+   Vector2   0.102254    0.299133 ,+   Vector2   0.164216  (-0.054399) ]++-- The first 6 arguments are identical to the frustum call. pixD is anti-alias+-- jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD is+-- depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field+-- effects. focus is distance from eye to plane in focus. focus must be greater+-- than, but not equal to 0. Note that accFrustum calls translate. You will+-- probably want to insure that your ModelView matrix has been initialized to+-- identity before calling accFrustum.+accFrustum :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble+           -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO ()+accFrustum left right bottom top zNear zFar+           (Vector2 pixDx pixDy) (Vector2 eyeDx eyeDy) focus = do+   (_, Size w h) <- get viewport+	+   let xWSize = right - left;+       yWSize = top - bottom;+	+       dx = -(pixDx * xWSize / fromIntegral w + eyeDx * zNear / focus)+       dy = -(pixDy * yWSize / fromIntegral h + eyeDy * zNear / focus)+	+   matrixMode $= Projection+   loadIdentity+   frustum (left + dx) (right + dx) (bottom + dy) (top + dy) zNear zFar+   matrixMode $= Modelview 0+   loadIdentity+   translate (Vector3 (-eyeDx) (-eyeDy) 0)++-- The first 4 arguments are identical to the perspective call. pixD is+-- anti-alias jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD+-- is depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field+-- effects. focus is distance from eye to plane in focus. focus must be greater+-- than, but not equal to 0. Note that accPerspective calls accFrustum.+accPerspective :: GLdouble -> GLdouble -> GLdouble -> GLdouble+               -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO ()+accPerspective fovY aspect zNear zFar  pixD eyeD focus = do+   let fov2 = ((fovY * pi) / 180) / 2++       top = zNear / (cos fov2 / sin fov2)+       bottom = -top++       right = top * aspect+       left = -right++   accFrustum left right bottom top zNear zFar pixD eyeD focus++-- Initialize lighting and other values.+myInit :: IO ()+myInit = do+   materialAmbient Front $= Color4 1 1 1 1+   materialSpecular Front $= Color4 1 1 1 1+   materialShininess Front $= 50+   position (Light 0) $= Vertex4 0 0 10 1+   lightModelAmbient $= Color4 0.2 0.2 0.2 1++   lighting $= Enabled+   light (Light 0) $= Enabled+   depthFunc $= Just Less+   shadeModel $= Flat++   clearColor $= Color4 0 0 0 0+   clearAccum $= Color4 0 0 0 0++displayObjects :: IO ()+displayObjects = do+   -- resolve overloading, not needed in "real" programs+   let translatef = translate :: Vector3 GLfloat -> IO ()+       rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO ()++   preservingMatrix $ do+      translatef (Vector3 0 0 (-5))+      rotatef 30 (Vector3 1 0 0)++      preservingMatrix $ do+         translatef (Vector3 (-0.80) 0.35 0)+         rotatef 100 (Vector3 1 0 0)+         materialDiffuse Front $= Color4 0.7 0.7 0 1+         renderObject Solid (Torus 0.275 0.85 16 16)++      preservingMatrix $ do+         translatef (Vector3 (-0.75) (-0.50) 0)+         rotatef 45 (Vector3 0 0 1)+         rotatef 45 (Vector3 1 0 0)+         materialDiffuse Front $= Color4 0 0.7 0.7 1+         renderObject Solid (Cube 1.5)++      preservingMatrix $ do+         translatef (Vector3 0.75 0.60 0)+         rotatef 30 (Vector3 1 0 0)+         materialDiffuse Front $= Color4 0.7 0 0.7 1+         renderObject Solid (Sphere' 1 16 16)++      preservingMatrix $ do+         translatef (Vector3 0.70 (-0.90) 0.25)+         materialDiffuse Front $= Color4 0.7 0.4 0.4 1+         renderObject Solid Octahedron++-- display draws 5 teapots into the accumulation buffer several times; each time+-- with a jittered perspective. The focal point is at z = 5.0, so the gold+-- teapot will stay in focus. The amount of jitter is adjusted by the magnitude+-- of the accPerspective jitter; in this example, 0.33. In this example, the+-- teapots are drawn 8 times.+display :: DisplayCallback+display = do+   (_, Size w h) <- get viewport+   clear [ AccumBuffer ]++   flip mapM_ j8 $ \(Vector2 x y) -> do+      clear [ ColorBuffer, DepthBuffer ]+      accPerspective 50 (fromIntegral w / fromIntegral h) 1 15+                     (Vector2 x y) (Vector2 0 0) 1+      displayObjects+      accum Accum (recip (genericLength j8))++   accum Return 1+   flush++reshape :: ReshapeCallback+reshape size = do+   viewport $= (Position 0 0, size)++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++-- Main Loop: Be certain you request an accumulation buffer.+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ]+   initialWindowSize $= Size 250 250+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   reshapeCallback $= Just reshape+   displayCallback $= display+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/Alpha.hs view
@@ -0,0 +1,91 @@+{-+   Alpha.hs (adapted from alpha.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program draws several overlapping filled polygons to demonstrate the+   effect order has on alpha blending results. Use the 't' key to toggle the+   order of drawing polygons.+-}++import Data.Char ( toLower )+import Data.IORef ( IORef, newIORef )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++data State = State { leftFirst :: IORef Bool }++makeState :: IO State+makeState = do+   l <- newIORef True+   return $ State { leftFirst = l }++-- Initialize alpha blending function.+myInit :: IO ()+myInit = do+   blend $= Enabled+   blendFunc $= (SrcAlpha, OneMinusSrcAlpha)+   shadeModel $= Flat+   clearColor $= Color4 0 0 0 0++drawLeftTriangle :: IO ()+drawLeftTriangle =+   -- draw yellow triangle on LHS of screen+   renderPrimitive Triangles $ do+      color (Color4 1 1 0 (0.75 :: GLfloat))+      vertex (Vertex3 0.1 0.9 (0 :: GLfloat))+      vertex (Vertex3 0.1 0.1 (0 :: GLfloat))+      vertex (Vertex3 0.7 0.5 (0 :: GLfloat))++drawRightTriangle :: IO ()+drawRightTriangle =+   -- draw cyan triangle on RHS of screen+   renderPrimitive Triangles $ do+      color (Color4 0 1 1 (0.75 :: GLfloat))+      vertex (Vertex3 0.9 0.9 (0 :: GLfloat))+      vertex (Vertex3 0.3 0.5 (0 :: GLfloat))+      vertex (Vertex3 0.9 0.1 (0 :: GLfloat))++display :: State -> DisplayCallback+display state = do+   clear [ ColorBuffer ]+   l <- get (leftFirst state)+   if l+      then do drawLeftTriangle; drawRightTriangle+      else do drawRightTriangle; drawLeftTriangle+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho2D 0 1 0 (hf/wf)+      else ortho2D 0 (wf/hf) 0 1++keyboard :: State -> KeyboardMouseCallback+keyboard state (Char c) Down _ _ = case toLower c of+   't'   -> do leftFirst state $~ not; postRedisplay Nothing+   '\27' -> exitWith ExitSuccess   -- Escape key+   _     -> return ()+keyboard _ _ _ _ _ = return ()++-- Main Loop+-- Open window with initial window size, title bar, RGBA display mode, and+-- handle input events.+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 200 200+   createWindow progName+   state <- makeState+   myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboard state)+   displayCallback $= display state+   mainLoop
+ examples/RedBook/Alpha3D.hs view
@@ -0,0 +1,124 @@+{-+   Alpha3D.hs (adapted from alpha3D.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates how to intermix opaque and alpha blended polygons+   in the same scene, by using depthMask. Press the 'a' key to animate moving+   the transparent object through the opaque object.  Press the 'r' key to reset+   the scene.+-}++import Data.Char ( toLower )+import Data.IORef ( IORef, newIORef )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++maxZ, minZ, zInc :: GLfloat+maxZ = 8+minZ = -8+zInc = 0.4++-- We don't animate via the idle callback, because this is way too fast on+-- modern computers. A timer with the delay below is used instead for redraw.+delay :: Timeout+delay = 100++data State = State { solidZ, transparentZ :: IORef GLfloat }++makeState :: IO State+makeState = do+   s <- newIORef maxZ+   t <- newIORef minZ+   return $ State { solidZ = s, transparentZ = t }++data DisplayLists = DisplayLists { sphereList, cubeList :: DisplayList }++myInit :: IO DisplayLists+myInit = do+   materialSpecular Front $= Color4 1 1 1 0.15+   materialShininess Front $= 100+   position (Light 0) $= Vertex4 0.5 0.5 1 0++   lighting $= Enabled+   light (Light 0) $= Enabled+   depthFunc $= Just Less++   s <- defineNewList Compile $ renderObject Solid (Sphere' 0.4 16 16)+   c <- defineNewList Compile $ renderObject Solid (Cube 0.6)+   return $ DisplayLists { sphereList = s, cubeList = c }++display :: State -> DisplayLists -> DisplayCallback+display state displayLists = do+   clear [ ColorBuffer, DepthBuffer ]++   preservingMatrix $ do+      s <- get (solidZ state)+      translate (Vector3 (-0.15) (-0.15) s)+      materialEmission Front $= Color4 0 0 0 1+      materialDiffuse Front $= Color4 0.75 0.75 0 1+      callList (sphereList displayLists)++   preservingMatrix $ do+      t <- get (transparentZ state)+      translate (Vector3 (0.15) (0.15) t)+      rotate (15 :: GLfloat) (Vector3 1 1 0)+      rotate (30 :: GLfloat) (Vector3 0 1 0)+      materialEmission Front $= Color4 0 0.3 0.3 0.6+      materialDiffuse Front $= Color4 0 0.8 0.8 0.6+      blend $= Enabled+      depthMask $= Disabled+      blendFunc $= (SrcAlpha, One)+      callList (cubeList displayLists)+      depthMask $= Enabled+      blend $= Disabled++   swapBuffers++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho (-1.5) 1.5 (-1.5*hf/wf) (1.5*hf/wf) (-10) 10+      else ortho (-1.5*wf/hf) (1.5*wf/hf) (-1.5) 1.5 (-10) 10+   matrixMode $= Modelview 0+   loadIdentity++animate :: State -> TimerCallback+animate state = do+   s <- get (solidZ state)+   t <- get (transparentZ state)+   if (s <= minZ || t >= maxZ)+      then idleCallback $= Nothing+      else do+         solidZ state $~ (+ (- zInc))+         transparentZ state $~ (+ zInc)+         addTimerCallback delay (animate state)+         postRedisplay Nothing++keyboard :: State -> KeyboardMouseCallback+keyboard state (Char c) Down _ _ = case toLower c of+   'a'   -> do solidZ state $= maxZ; transparentZ state $= minZ; addTimerCallback delay (animate state)+   'r'   -> do solidZ state $= maxZ; transparentZ state $= minZ; postRedisplay Nothing+   '\27' -> exitWith ExitSuccess+   _     -> return ()+keyboard _ _ _ _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   -- The original C example uses single buffering, which flickers a lot.+   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 500 500+   createWindow progName+   state <- makeState+   displayLists <- myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboard state)+   displayCallback $= display state displayLists+   mainLoop
+ examples/RedBook/BezCurve.hs view
@@ -0,0 +1,67 @@+{-+   BezCurve.hs (adapted from bezcurve.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program uses evaluators to draw a Bezier curve.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++ctrlPoints :: [Vertex3 GLfloat]+ctrlPoints = [ Vertex3 (-4)(-4) 0, Vertex3 (-2) 4 0,+               Vertex3   2 (-4) 0, Vertex3   4  4 0 ]++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Flat+   m <- newMap1 (0, 1) ctrlPoints+   map1 $= Just (m :: GLmap1 Vertex3 GLfloat)++display :: DisplayCallback+display = do+   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+   color3f (Color3 1 1 1)+   renderPrimitive LineStrip $+      mapM_ evalCoord1 [ i/30.0 :: GLfloat | i <- [0..30] ]+   -- The following code displays the control points as dots.+   pointSize $= 5+   color3f (Color3 1 1 0)+   renderPrimitive Points $+      mapM_ vertex ctrlPoints+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho (-5.0) 5.0 (-5.0*hf/wf) (5.0*hf/wf) (-5.0) 5.0+      else ortho (-5.0*wf/hf) (5.0*wf/hf) (-5.0) 5.0 (-5.0) 5.0+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   displayCallback $= display+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/BezMesh.hs view
@@ -0,0 +1,84 @@+{-+   BezMesh.hs (adapted from bezmesh.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program renders a lighted, filled Bezier surface, using two-dimensional+   evaluators.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Data.List ( transpose )+import Graphics.UI.GLUT++ctrlPoints :: [[Vertex3 GLfloat]]+ctrlPoints = [+   [ Vertex3 (-1.5) (-1.5)   4.0,  Vertex3 (-0.5) (-1.5)   2.0,+     Vertex3   0.5  (-1.5) (-1.0), Vertex3   1.5  (-1.5)   2.0 ],+   [ Vertex3 (-1.5) (-0.5)   1.0,  Vertex3 (-0.5) (-0.5)   3.0,+     Vertex3   0.5  (-0.5)   0.0,  Vertex3   1.5  (-0.5) (-1.0) ],+   [ Vertex3 (-1.5)   0.5    4.0,  Vertex3 (-0.5)   0.5    0.0,+     Vertex3   0.5    0.5    3.0,  Vertex3   1.5    0.5    4.0 ],+   [ Vertex3 (-1.5)   1.5  (-2.0), Vertex3 (-0.5)   1.5  (-2.0),+     Vertex3   0.5    1.5    0.0,  Vertex3   1.5    1.5  (-1.0) ]]++initlights :: IO ()+initlights = do+   lighting $= Enabled+   light (Light 0) $= Enabled++   ambient  (Light 0) $= Color4 0.2 0.2 0.2 1.0+   position (Light 0) $= Vertex4 0 0 2 1++   materialDiffuse   Front $= Color4 0.6 0.6 0.6 1.0+   materialSpecular  Front $= Color4 1.0 1.0 1.0 1.0+   materialShininess Front $= 50++display :: DisplayCallback+display = do+   clear [ ColorBuffer, DepthBuffer ]+   preservingMatrix $ do+      rotate (85 :: GLfloat) (Vector3 1 1 1)+      evalMesh2 Fill (0, 20) (0, 20)+   flush++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   depthFunc $= Just Less+   m <- newMap2 (0, 1) (0, 1) (transpose ctrlPoints)+   map2 $= Just (m :: GLmap2 Vertex3 GLfloat)+   autoNormal $= Enabled+   mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat)))+   initlights  -- for lighted version only++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0+      else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   reshapeCallback $= Just reshape+   displayCallback $= display+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/BezSurf.hs view
@@ -0,0 +1,79 @@+{-+   BezSurf.hs (adapted from bezsurf.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program renders a wireframe Bezier surface, using two-dimensional+   evaluators.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++ctrlPoints :: [[Vertex3 GLfloat]]+ctrlPoints = [+   [ Vertex3 (-1.5) (-1.5)   4.0,  Vertex3 (-0.5) (-1.5)   2.0,+     Vertex3   0.5  (-1.5) (-1.0), Vertex3   1.5  (-1.5)   2.0 ],+   [ Vertex3 (-1.5) (-0.5)   1.0,  Vertex3 (-0.5) (-0.5)   3.0,+     Vertex3   0.5  (-0.5)   0.0,  Vertex3   1.5  (-0.5) (-1.0) ],+   [ Vertex3 (-1.5)   0.5    4.0,  Vertex3 (-0.5)   0.5    0.0,+     Vertex3   0.5    0.5    3.0,  Vertex3   1.5    0.5    4.0 ],+   [ Vertex3 (-1.5)   1.5  (-2.0), Vertex3 (-0.5)   1.5  (-2.0),+     Vertex3   0.5    1.5    0.0,  Vertex3   1.5    1.5  (-1.0) ]]++-- Hey mom, look, it's C!  ;-)+for :: GLfloat -> GLfloat -> (GLfloat -> IO ()) -> IO ()+for s e f = mapM_ f [ i | i <- [ s, if s <= e then s + 1 else s - 1 .. e ] ]++display :: DisplayCallback+display = do+   clear [ ColorBuffer, DepthBuffer ]+   color (Color3 1 1 1 :: Color3 GLfloat)+   preservingMatrix $ do+      rotate (85 :: GLfloat) (Vector3 1 1 1)+      for 0 8 $ \j -> do+         renderPrimitive LineStrip $ do+            for 0 30 $ \i -> evalCoord2 (i/30, j/ 8)+         renderPrimitive LineStrip $ do+            for 0 30 $ \i -> evalCoord2 (j/ 8, i/30)+   flush++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   m <- newMap2 (0, 1) (0, 1) ctrlPoints+   map2 $= Just (m :: GLmap2 Vertex3 GLfloat)+   mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat)))+   depthFunc $= Just Less+   shadeModel $= Flat++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0+      else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   displayCallback $= display+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/BlendEqn.hs view
@@ -0,0 +1,95 @@+{-+   BlendEqn.hs (adapted from blendeqn.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   Demonstrate the different blending functions available with the OpenGL+   imaging subset. This program demonstrates use of blendEquation.++   The following keys change the selected blend equation function:++       'a'  ->  FuncAdd+       's'  ->  FuncSubtract+       'r'  ->  FuncReverseSubtract+       'm'  ->  Min+       'x'  ->  Max+-}++import Data.Char ( toLower )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++myInit :: IO ()+myInit = do+   clearColor $= Color4 1 1 0 0+   blendFunc $= (One, One)+   blend $= Enabled++display :: DisplayCallback+display = do+   clear [ ColorBuffer ]++   color (Color3 0 0 (1 :: GLfloat))+   rect (Vertex2 (-0.5) (-0.5)) (Vertex2 0.5 (0.5 :: GLfloat))++   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   let aspect = fromIntegral w / fromIntegral h++   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   if aspect < 1+      then let aspect' = recip aspect+           in ortho (-aspect') aspect' (-1) 1 (-1) 1+      else ortho (-1) 1 (-aspect) aspect (-1) 1+   matrixMode $= Modelview 0++keyboard :: KeyboardMouseCallback+keyboard (Char c) Down _ _ = case toLower c of+   -- Colors are added as: (0, 0, 1) + (1, 1, 0) = (1, 1, 1)+   -- which will produce a white square on a yellow background.+   'a'   -> setBlendEquation FuncAdd++   -- Colors are subtracted as: (0, 0, 1) - (1, 1, 0) = (-1, -1, 1)+   -- which is clamped to (0, 0, 1), producing a blue square on a+   -- yellow background+   's'   -> setBlendEquation FuncSubtract++   -- Colors are subtracted as: (1, 1, 0) - (0, 0, 1) = (1, 1, -1)+   -- which is clamed to (1, 1, 0). This produces yellow for both+   -- the square and the background.+   'r'   -> setBlendEquation FuncReverseSubtract++   -- The minimum of each component is computed, as+   -- [min(0, 1), min(0, 1), min(1, 0)] which equates to (0, 0, 0).+   -- This will produce a black square on the yellow background.+   'm'   -> setBlendEquation Min++   -- The minimum of each component is computed, as+   -- [max(0, 1), max(0, 1), max(1, 0)] which equates to (1, 1, 1)+   -- This will produce a white square on the yellow background.+   'x'   -> setBlendEquation Max++   '\27' -> exitWith ExitSuccess+   _     -> return ()+   where setBlendEquation e = do+            blendEquation $= e+            postRedisplay Nothing+keyboard _ _ _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 512 512+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   displayCallback $= display+   mainLoop
+ examples/RedBook/Checker.hs view
@@ -0,0 +1,101 @@+{-+   Checker.hs  (adapted from checker.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program texture maps a checkerboard image onto two rectangles.++   Texture objects are only used when GL_EXT_texture_object is supported.+-}++import Control.Monad ( when )+import Data.Maybe ( isJust, listToMaybe )+import Data.Bits ( (.&.) )+import Foreign ( withArray )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++-- Create checkerboard image+checkImageSize :: TextureSize2D+checkImageSize = TextureSize2D 64 64++withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte))+               -> (PixelData (Color4 GLubyte) -> IO ()) -> IO ()+withCheckImage (TextureSize2D w h) n f act =+   withArray [ f c |+               i <- [ 0 .. w - 1 ],+               j <- [ 0 .. h - 1 ],+               let c | (i .&. n) == (j .&. n) = 0+                     | otherwise              = 255 ] $+   act. PixelData RGBA UnsignedByte++myInit :: IO (Maybe TextureObject)+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Flat+   depthFunc $= Just Less+   rowAlignment Unpack $= 1++   exts <- get glExtensions+   mbTexName <- if "GL_EXT_texture_object" `elem` exts+                   then fmap listToMaybe $ genObjectNames 1+                   else return Nothing+   when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName++   textureWrapMode Texture2D S $= (Repeated, Repeat)+   textureWrapMode Texture2D T $= (Repeated, Repeat)+   textureFilter Texture2D $= ((Nearest, Nothing), Nearest)+   withCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) $+      texImage2D Nothing NoProxy 0  RGBA' checkImageSize 0+   return mbTexName++display ::  Maybe TextureObject -> DisplayCallback+display mbTexName = do+   clear [ ColorBuffer, DepthBuffer ]+   texture Texture2D $= Enabled+   textureFunction $= Decal+   when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName++   -- resolve overloading, not needed in "real" programs+   let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()+       vertex3f = vertex :: Vertex3 GLfloat -> IO ()+   renderPrimitive Quads $ do+      texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0)    (-1.0)   0.0     )+      texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0)      1.0    0.0     )+      texCoord2f (TexCoord2 1 1); vertex3f (Vertex3   0.0       1.0    0.0     )+      texCoord2f (TexCoord2 1 0); vertex3f (Vertex3   0.0     (-1.0)   0.0     )++      texCoord2f (TexCoord2 0 0); vertex3f (Vertex3   1.0     (-1.0)   0.0     )+      texCoord2f (TexCoord2 0 1); vertex3f (Vertex3   1.0       1.0    0.0     )+      texCoord2f (TexCoord2 1 1); vertex3f (Vertex3   2.41421   1.0  (-1.41421))+      texCoord2f (TexCoord2 1 0); vertex3f (Vertex3   2.41421 (-1.0) (-1.41421))+   flush+   texture Texture2D $= Disabled++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective 60 (fromIntegral w / fromIntegral h) 1 30+   matrixMode $= Modelview 0+   loadIdentity+   translate (Vector3 0 0 (-3.6 :: GLfloat))++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 250 250+   initialWindowPosition $= Position 100 100+   createWindow progName+   mbTexName <- myInit+   displayCallback $= display mbTexName+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/Clip.hs view
@@ -0,0 +1,63 @@+{-+   Clip.hs (adapted from clip.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates arbitrary clipping planes.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Flat++display :: DisplayCallback+display = do+   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+       translatef = translate :: Vector3 GLfloat -> IO ()+       rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO ()+   color3f (Color3 1 1 1)++   preservingMatrix $ do+      translatef (Vector3 0 0 (-5))++      -- clip lower half -- y < 0+      clipPlane (ClipPlaneName 0) $= Just (Plane 0 1 0 0)+      -- clip left half -- x < 0+      clipPlane (ClipPlaneName 1) $= Just (Plane 1 0 0 0)++      rotatef 90 (Vector3 1 0 0)+      renderObject Wireframe (Sphere' 1 20 16)++   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective 60 (fromIntegral w / fromIntegral h) 1 20+   matrixMode $= Modelview 0++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   displayCallback $= display+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/ColorMat.hs view
@@ -0,0 +1,94 @@+{-+   Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   After initialization, the program will be in ColorMaterial mode.+   Interaction: pressing the mouse buttons will change the diffuse+   reflection values.+-}++import Data.IORef ( IORef, newIORef )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++data State = State { r, g, b :: IORef GLfloat }++diffuseMaterial :: State -> IO (Color4 GLfloat)+diffuseMaterial state = do+   r' <- get (r state)+   g' <- get (g state)+   b' <- get (b state)+   return $ Color4 r' g' b' 1++makeState :: IO State+makeState = do+   r' <- newIORef 0.5+   g' <- newIORef 0.5+   b' <- newIORef 0.5+   return $ State { r = r', g = g', b = b' }++-- Initialize material property, light source, lighting model,+-- and depth buffer.+myInit :: State -> IO ()+myInit state = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Smooth+   depthFunc $= Just Less+   dm <- diffuseMaterial state+   materialDiffuse Front $= dm+   materialSpecular Front $= Color4 1 1 1 1+   materialShininess Front $= 25+   position (Light 0) $= Vertex4 1 1 1 0+   lighting $= Enabled+   light (Light 0) $= Enabled+   colorMaterial $= Just (Front, Diffuse)++display :: DisplayCallback+display = do+   clear [ ColorBuffer, DepthBuffer ]+   renderObject Solid (Sphere' 1 20 16)+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho (-1.5) 1.5 (-1.5 * hf/wf) (1.5 * hf/wf) (-10) 10+      else ortho (-1.5 * wf/hf) (1.5 * wf/hf) (-1.5) 1.5 (-10) 10+   matrixMode $= Modelview 0+   loadIdentity++keyboardMouse :: State -> KeyboardMouseCallback+keyboardMouse state (MouseButton button) Down _ _ = case button of+   LeftButton   -> update r+   MiddleButton -> update g+   RightButton  -> update b+   _ -> return ()+   where update component = do+            component state $~ inc+            dm <- diffuseMaterial state+            color dm+            postRedisplay Nothing+         inc x = let s = x + 0.1 in if s > 1 then 0 else s+keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess+keyboardMouse _ _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   state <- makeState+   myInit state+   displayCallback $= display+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboardMouse state)+   mainLoop
+ examples/RedBook/ColorMatrix.hs view
@@ -0,0 +1,65 @@+{-+   ColorMatrix.hs (adapted from colormatrix.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program uses the color matrix to exchange the color channels of an image.++     Red   -> Green+     Green -> Blue+     Blue  -> Red+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT+import ReadImage++myInit :: IO ()+myInit = do+   m <- newMatrix ColumnMajor [ 0, 1, 0, 0,+                                0, 0, 1, 0,+                                1, 0, 0, 0,+                                0, 0, 0, 1 ]+   rowAlignment Unpack $= 1+   clearColor $= Color4 0 0 0 0+   matrixMode $= Color+   matrix Nothing $= (m :: GLmatrix GLfloat)+   matrixMode $= Modelview 0++display :: Size -> PixelData a -> DisplayCallback+display size pixels = do+   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let rasterPos2i = rasterPos :: Vertex2 GLint -> IO ()+   rasterPos2i (Vertex2 1 1)+   drawPixels size pixels+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1+   matrixMode $= Modelview 0++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++-- Main Loop: Open window with initial window size, title bar, RGBA display+-- mode, and handle input events.+main :: IO ()+main = do+   (progName, args) <- getArgsAndInitialize+   (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args)+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= size+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   displayCallback $= display size pixels+   mainLoop
+ examples/RedBook/ColorTable.hs view
@@ -0,0 +1,62 @@+{-+   ColorTable.hs (adapted from colortable.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   Invert a passed block of pixels.  This program illustrates the use of the+   colorTable function.+-}++import Foreign ( withArray )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT+import ReadImage++myInit :: IO ()+myInit = do+   rowAlignment Unpack $= 1+   clearColor $= Color4 0 0 0 0+   -- Set up an inverse color table+   let tableSize = 256+       t = fromIntegral (tableSize - 1) :: GLubyte+   withArray [ Color3 i i i | i <- [ t, t - 1 .. 0 ] ] $ \buf ->+      colorTable NoProxy ColorTable RGB' tableSize (PixelData RGB UnsignedByte buf)+   colorTableStage ColorTableStage $= Enabled++display :: Size -> PixelData a -> DisplayCallback+display size pixels = do+   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let rasterPos2i = rasterPos :: Vertex2 GLint -> IO ()+   rasterPos2i (Vertex2 1 1)+   drawPixels size pixels+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1+   matrixMode $= Modelview 0++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++-- Main Loop: Open window with initial window size, title bar, RGBA display+-- mode, and handle input events.+main :: IO ()+main = do+   (progName, args) <- getArgsAndInitialize+   (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args)+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= size+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   displayCallback $= display size pixels+   mainLoop
+ examples/RedBook/Combiner.hs view
@@ -0,0 +1,236 @@+{-+   Combiner.hs  (adapted from combiner.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program renders a variety of quads showing different effects of+   texture combiner functions.++   The first row renders an untextured polygon (so you can compare the+   fragment colors) and then the 2 textures.++   The second row shows several different combiner functions on a single+   texture: replace, modulate, add, add-signed, and subtract.++   The third row shows the interpolate combiner function on a single texture+   with a constant color/alpha value, varying the amount of interpolation.++   The fourth row uses multitexturing with two textures and different+   combiner functions.++   The fifth row are some combiner experiments: using the scaling factor and+   reversing the order of subtraction for a combination function.+-}++import Data.Bits ( (.&.) )+import Foreign ( withArray )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++-- Create checkerboard image+imageSize :: TextureSize2D+imageSize = TextureSize2D 8 8++makeImage :: TextureSize2D -> (GLsizei -> GLsizei -> Color4 GLubyte)+               -> (PixelData (Color4 GLubyte) -> IO ()) -> IO ()+makeImage (TextureSize2D w h) f act =+   withArray [ f i j |+               i <- [ 0 .. w - 1 ],+               j <- [ 0 .. h - 1 ] ] $+   act . PixelData RGBA UnsignedByte++myInit :: IO (TextureObject, TextureObject, DisplayList)+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Smooth++   rowAlignment Unpack $= 1++   [texName0, texName1] <- genObjectNames 2++   textureBinding Texture2D $= Just texName0+   textureWrapMode Texture2D S $= (Repeated, Repeat)+   textureWrapMode Texture2D T $= (Repeated, Repeat)+   textureFilter Texture2D $= ((Nearest, Nothing), Nearest)+   -- horiz b & w stripes+   makeImage imageSize (\i _ -> let c = if i .&. 2 == 0 then 255 else 0 in Color4 c c c 255) $+      texImage2D Nothing NoProxy 0  RGBA' imageSize 0++   textureBinding Texture2D $= Just texName1+   textureWrapMode Texture2D S $= (Repeated, Repeat)+   textureWrapMode Texture2D T $= (Repeated, Repeat)+   textureFilter Texture2D $= ((Nearest, Nothing), Nearest)+   textureFunction $= Decal+   -- wider vertical 50% cyan and black stripes+   makeImage imageSize (\_ j -> let c = if j .&. 4 /= 0 then 128 else 0 in Color4 0 c c 255) $+      texImage2D Nothing NoProxy 0  RGBA' imageSize 0++   -- smooth-shaded polygon with multiple texture coordinates+   let vert :: TexCoord2 GLfloat -> Color3 GLfloat -> Vertex3 GLfloat -> IO ()+       vert t c v = do+          multiTexCoord (TextureUnit 0) t+          multiTexCoord (TextureUnit 1) t+          color c+          vertex v++   dl <- defineNewList Compile $+      renderPrimitive Quads $ do+         vert (TexCoord2 0 0) (Color3 0.5 1   0.25) (Vertex3 0 0 0)+         vert (TexCoord2 0 2) (Color3 1   1   1   ) (Vertex3 0 1 0)+         vert (TexCoord2 2 2) (Color3 1   1   1   ) (Vertex3 1 1 0)+         vert (TexCoord2 2 0) (Color3 1   0.5 0.25) (Vertex3 1 0 0)++   return (texName0, texName1, dl)++display ::  (TextureObject, TextureObject, DisplayList) -> DisplayCallback+display (texName0, texName1, dl) = do+   clear [ ColorBuffer ]++   let drawAt :: GLfloat -> GLfloat -> IO ()+       drawAt x y = preservingMatrix $ do+                   translate (Vector3 x y 0)+                   callList dl++   -- untextured polygon -- see the "fragment" colors+   texture Texture2D $= Disabled+   drawAt 0 5++   texture Texture2D $= Enabled+   -- draw ordinary textured polys; 1 texture unit; combine mode disabled+   textureFunction $= Modulate+   textureBinding Texture2D $= Just texName0+   drawAt 1 5++   textureBinding Texture2D $= Just texName1+   drawAt 2 5++   -- different combine modes enabled; 1 texture unit+   -- defaults are:+   -- argRGB Arg0 $= Arg SrcColor CurrentUnit+   -- argRGB Arg1 $= Arg SrcColor Previous++   textureBinding Texture2D $= Just texName0+   textureFunction $= Combine+   combineRGB $= Replace'+   argRGB Arg0 $= Arg SrcColor CurrentUnit+   drawAt 1 4++   combineRGB $= Modulate'+   argRGB Arg1 $= Arg SrcColor Previous+   drawAt 2 4++   combineRGB $= AddUnsigned'+   drawAt 3 4++   combineRGB $= AddSigned+   drawAt 4 4++   combineRGB $= Subtract+   drawAt 5 4++   -- interpolate combine with constant color; 1 texture unit+   -- use different alpha values for constant color+   -- defaults are:+   -- argRGB Arg0 $= Arg SrcColor CurrentUnit+   -- argRGB Arg1 $= Arg SrcColor Previous+   -- argRGB Arg2 $= Arg SrcAlpha Constant++   constantColor $= Color4 0 0 0 0.2+   textureBinding Texture2D $= Just texName0+   textureFunction $= Combine+   combineRGB $= Interpolate+   argRGB Arg0 $= Arg SrcColor CurrentUnit+   argRGB Arg1 $= Arg SrcColor Previous+   argRGB Arg2 $= Arg SrcAlpha Constant+   drawAt 1 3++   constantColor $= Color4 0 0 0 0.4+   drawAt 2 3++   constantColor $= Color4 0 0 0 0.6+   drawAt 3 3++   constantColor $= Color4 0 0 0 0.8+   drawAt 4 3++   -- combine textures 0 & 1+   -- defaults are:+   -- argRGB Arg0 $= Arg SrcColor CurrentUnit+   -- argRGB Arg1 $= Arg SrcColor Previous++   activeTexture $= TextureUnit 0+   texture Texture2D $= Enabled+   textureBinding Texture2D $= Just texName0+   textureFunction $= Modulate++   activeTexture $= TextureUnit 1+   texture Texture2D $= Enabled+   textureBinding Texture2D $= Just texName1+   textureFunction $= Combine+   combineRGB $= Replace'+   drawAt 1 2++   -- try different combiner modes of texture unit 1+   combineRGB $= Modulate'+   drawAt 2 2++   combineRGB $= AddUnsigned'+   drawAt 3 2++   combineRGB $= AddSigned+   drawAt 4 2++   combineRGB $= Subtract+   drawAt 5 2++   -- some experiments++   -- see the effect of rgbScale+   rgbScale $= 2+   combineRGB $= Replace'+   drawAt 1 1++   combineRGB $= Modulate'+   drawAt 2 1+   rgbScale $= 1++   -- reverse the order of subtraction Arg1-Arg0++   textureFunction $= Combine+   combineRGB $= Subtract+   argRGB Arg0 $= Arg SrcColor Previous+   argRGB Arg1 $= Arg SrcColor CurrentUnit+   drawAt 5 1++   activeTexture $= TextureUnit 1   -- deactivate multitexturing+   texture Texture2D $= Disabled+   activeTexture $= TextureUnit 0   -- activate single texture unit++   flush++reshape :: ReshapeCallback+reshape size = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho2D 0 7 0 7+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 400 400+   initialWindowPosition $= Position 100 100+   createWindow progName+   texNamesAndDL <- myInit+   displayCallback $= display texNamesAndDL+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/Convolution.hs view
@@ -0,0 +1,83 @@+{-+   Convolution.hs (adapted from convolution.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   Use various 2D convolutions filters to find edges in an image.+-}++import Foreign ( withArray )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT+import ReadImage++data Filter = Filter String [GLfloat]++filterTable :: [(Key,Filter)]+filterTable = [+   (Char 'h', Filter "horizontal" [ 0, -1, 0,+                                    0,  1, 0,+                                    0,  0, 0 ]),++   (Char 'v', Filter "vertical" [ 0, 0, 0,+                                 -1, 1, 0,+                                  0, 0, 0 ]),++   (Char 'l', Filter "laplacian" [ -0.125, -0.125, -0.125,+                                   -0.125,  1.0  , -0.125,+                                   -0.125, -0.125, -0.125 ])]++setFilter :: Filter -> IO ()+setFilter (Filter filterName filterData) = do+   putStrLn ("Using the " ++ filterName ++ " filter")+   withArray filterData $ \buf ->+      convolutionFilter2D Luminance' (Size 3 3) (PixelData Luminance Float buf)++myInit :: IO ()+myInit = do+   rowAlignment Unpack $= 1+   clearColor $= Color4 0 0 0 0+   setFilter (snd (head filterTable))+   convolution Convolution2D $= Enabled++display :: Size -> PixelData a -> DisplayCallback+display size pixels = do+   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let rasterPos2i = rasterPos :: Vertex2 GLint -> IO ()+   rasterPos2i (Vertex2 1 1)+   drawPixels size pixels+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1+   matrixMode $= Modelview 0++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard key          Down _ _ =+   maybe (return ())+         (\f -> do setFilter f; postRedisplay Nothing)+         (lookup key filterTable)+keyboard _            _    _ _ = return ()++-- Main Loop: Open window with initial window size, title bar, RGBA display+-- mode, and handle input events.+main :: IO ()+main = do+   (progName, args) <- getArgsAndInitialize+   (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args)+   initialDisplayMode $= [ SingleBuffered, RGBAMode ]+   initialWindowSize $= size+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   displayCallback $= display size pixels+   mainLoop
+ examples/RedBook/Cube.hs view
@@ -0,0 +1,56 @@+{-+   Cube.hs (adapted from cube.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates a single modeling transformation, scale and a+   single viewing transformation, lookAt. A wireframe cube is rendered.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Flat++display :: DisplayCallback+display = do+   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+       scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO ()+   color3f (Color3 1 1 1)+   loadIdentity   -- clear the matrix+   -- viewing transformation+   lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0)+   scalef 1 2 1   -- modeling transformation+   renderObject Wireframe (Cube 1)+   flush++reshape :: ReshapeCallback+reshape size = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   frustum (-1) 1 (-1) 1 1.5 20+   matrixMode $= Modelview 0++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   displayCallback $= display+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/CubeMap.hs view
@@ -0,0 +1,118 @@+{-+   CubeMap.hs  (adapted from CubeMap.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates cube map textures. Six different colored checker+   board textures are created and applied to a lit sphere.++   Pressing the 'f' and 'b' keys translate the viewer forward and backward.+-}++import Data.Bits ( (.&.) )+import Data.IORef ( IORef, newIORef )+import Foreign ( withArray )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++data State = State { zTrans :: IORef GLfloat }++makeState :: IO State+makeState = do+   z <- newIORef 0+   return $ State { zTrans = z }++imageSize :: TextureSize2D+imageSize = TextureSize2D 4 4++withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte))+               -> (PixelData (Color4 GLubyte) -> IO ()) -> IO ()+withCheckImage (TextureSize2D w h) n f act =+   withArray [ f c |+               i <- [ 0 .. w - 1 ],+               j <- [ 0 .. h - 1 ],+               let c | (i .&. n) == (j .&. n) = 0+                     | otherwise              = 255 ] $+   act. PixelData RGBA UnsignedByte++makeImage :: CubeMapTarget -> (GLubyte -> (Color4 GLubyte)) -> IO ()+makeImage target f =+   withCheckImage imageSize 0x1 f $+      texImage2D (Just target) NoProxy 0  RGBA' imageSize 0++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   depthFunc $= Just Less+   shadeModel $= Smooth++   rowAlignment Unpack $= 1+   textureWrapMode TextureCubeMap S $= (Repeated, Repeat)+   textureWrapMode TextureCubeMap T $= (Repeated, Repeat)+   textureWrapMode TextureCubeMap R $= (Repeated, Repeat)+   textureFilter TextureCubeMap $= ((Nearest, Nothing), Nearest)++   makeImage TextureCubeMapPositiveX (\c -> Color4   c c   c 255)+   makeImage TextureCubeMapNegativeX (\c -> Color4   0 c   c 255)+   makeImage TextureCubeMapPositiveY (\c -> Color4   c c   0 255)+   makeImage TextureCubeMapNegativeY (\c -> Color4 255 c   c 255)+   makeImage TextureCubeMapPositiveZ (\c -> Color4   c 0   c 255)+   makeImage TextureCubeMapNegativeZ (\c -> Color4   c c 255 255)++   textureGenMode S $= Just NormalMap+   textureGenMode T $= Just NormalMap+   textureGenMode R $= Just NormalMap++   textureFunction $= Modulate++   texture TextureCubeMap $= Enabled+   lighting $= Enabled+   light (Light 0) $= Enabled+   autoNormal $= Enabled+   normalize $= Enabled+   materialDiffuse Front $= Color4 1 1 1 1++display :: State -> DisplayCallback+display state = do+   clear [ ColorBuffer, DepthBuffer ]+   preservingMatrix $ do+      z <- get (zTrans state)+      translate (Vector3 0 0 z)+      renderObject Solid (Sphere' 5 20 10)+   swapBuffers++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective 40 (fromIntegral w / fromIntegral h) 1 300+   matrixMode $= Modelview 0+   loadIdentity+   translate (Vector3 0 0 (-20 :: GLfloat))++keyboard :: State -> KeyboardMouseCallback+keyboard state (Char 'f')   Down _ _ = move state (-0.2)+keyboard state (Char 'b')   Down _ _ = move state   0.2+keyboard _     (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _     _            _    _ _ = return ()++move :: State -> GLfloat -> IO ()+move state inc = do+   zTrans state $~ (+ inc)+   postRedisplay Nothing++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 400 400+   initialWindowPosition $= Position 50 50+   createWindow progName+   state <- makeState+   myInit+   displayCallback $= display state+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboard state)+   mainLoop
+ examples/RedBook/DList.hs view
@@ -0,0 +1,85 @@+{-+   DList.hs (adapted from list.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates how to make and execute a+   display list.  Note that attributes, such as current+   color and matrix, are changed.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++myInit :: IO DisplayList+myInit = do+   [listName] <- genObjectNames 1+   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+       vertex2f = vertex :: Vertex2 GLfloat -> IO ()+       translatef = translate :: Vector3 GLfloat -> IO ()+   defineList listName Compile $ do+      color3f (Color3 1 0 0) -- current color red+      renderPrimitive Triangles $ do+         vertex2f (Vertex2 0 0)+         vertex2f (Vertex2 1 0)+         vertex2f (Vertex2 0 1)+      translatef (Vector3 1.5 0.0 0.0) -- move position+   shadeModel $= Flat+   return listName++drawLine :: IO ()+drawLine = do+   -- resolve overloading, not needed in "real" programs+   let vertex2f = vertex :: Vertex2 GLfloat -> IO ()+   renderPrimitive Lines $ do+      vertex2f (Vertex2  0.0 0.5)+      vertex2f (Vertex2 15.0 0.5)++display :: DisplayList -> DisplayCallback+display listName = do+   -- NOTE: The following 'loadIdentity' is missing in the original+   -- example, but without it the translatef calls accumulate and+   -- the graphics wander out of the window after a few redraws...+   loadIdentity++   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+   color3f (Color3 0 1 0) -- current color green+   sequence_ (replicate 10 (callList listName)) -- draw 10 triangles+   drawLine -- is this line green? NO!+            -- where is the line drawn?+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho2D 0.0 2.0 (-0.5*hf/wf) (1.5*hf/wf)+      else ortho2D 0.0 (2.0*wf/hf) (-0.5) 1.5+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++-- Open window with initial window size, title bar,+-- RGBA display mode, and handle input events.+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 650 50+   createWindow progName+   listName <- myInit+   reshapeCallback $= Just reshape+   displayCallback $= display listName+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/DOF.hs view
@@ -0,0 +1,182 @@+{-+   DOF.hs (adapted from dof.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates use of the accumulation buffer to create an+   out-of-focus depth-of-field effect. The teapots are drawn several times into+   the accumulation buffer. The viewing volume is jittered, except at the focal+   point, where the viewing volume is at the same position, each time. In this+   case, the gold teapot remains in focus.+-}++import Data.List ( genericLength )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++-- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a+-- gaussian distribution around the origin. Use these to do model jittering for+-- scene anti-aliasing and view volume jittering for depth of field effects. Use+-- in conjunction with the accwindow routine.+j8 :: [Vector2 GLdouble]+j8 = [+   Vector2 (-0.334818)   0.435331 ,+   Vector2   0.286438  (-0.393495),+   Vector2   0.459462    0.141540 ,+   Vector2 (-0.414498) (-0.192829),+   Vector2 (-0.183790)   0.082102 ,+   Vector2 (-0.079263) (-0.317383),+   Vector2   0.102254    0.299133 ,+   Vector2   0.164216  (-0.054399) ]++-- The first 6 arguments are identical to the frustum call. pixD is anti-alias+-- jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD is+-- depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field+-- effects. focus is distance from eye to plane in focus. focus must be greater+-- than, but not equal to 0. Note that accFrustum calls translate. You will+-- probably want to insure that your ModelView matrix has been initialized to+-- identity before calling accFrustum.+accFrustum :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble+           -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO ()+accFrustum left right bottom top zNear zFar+           (Vector2 pixDx pixDy) (Vector2 eyeDx eyeDy) focus = do+   (_, Size w h) <- get viewport+	+   let xWSize = right - left;+       yWSize = top - bottom;+	+       dx = -(pixDx * xWSize / fromIntegral w + eyeDx * zNear / focus)+       dy = -(pixDy * yWSize / fromIntegral h + eyeDy * zNear / focus)+	+   matrixMode $= Projection+   loadIdentity+   frustum (left + dx) (right + dx) (bottom + dy) (top + dy) zNear zFar+   matrixMode $= Modelview 0+   loadIdentity+   translate (Vector3 (-eyeDx) (-eyeDy) 0)++-- The first 4 arguments are identical to the perspective call. pixD is+-- anti-alias jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD+-- is depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field+-- effects. focus is distance from eye to plane in focus. focus must be greater+-- than, but not equal to 0. Note that accPerspective calls accFrustum.+accPerspective :: GLdouble -> GLdouble -> GLdouble -> GLdouble+               -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO ()+accPerspective fovY aspect zNear zFar  pixD eyeD focus = do+   let fov2 = ((fovY * pi) / 180) / 2++       top = zNear / (cos fov2 / sin fov2)+       bottom = -top++       right = top * aspect+       left = -right++   accFrustum left right bottom top zNear zFar pixD eyeD focus++myInit :: IO DisplayList+myInit = do+   ambient (Light 0) $= Color4 0 0 0 1+   diffuse (Light 0) $= Color4 1 1 1 1+   position (Light 0) $= Vertex4 0 3 3 0++   lightModelAmbient $= Color4 0.2 0.2 0.2 1+   lightModelLocalViewer $= Disabled++   frontFace $= CW+   lighting $= Enabled+   light (Light 0) $= Enabled+   autoNormal $= Enabled+   normalize $= Enabled+   depthFunc $= Just Less++   clearColor $= Color4 0 0 0 0+   clearAccum $= Color4 0 0 0 0+   -- make teapot display list+   defineNewList Compile $+      renderObject Solid (Teapot 0.5)++-- Move object into position, specify the material properties, draw a teapot.+renderTeapot :: DisplayList -> Vector3 GLfloat -> Color4 GLfloat+             -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> IO ()+renderTeapot teapotList pos amb dif spec shine =+   preservingMatrix $ do+      translate pos+      materialAmbient Front $= amb+      materialDiffuse Front $= dif+      materialSpecular Front $= spec+      materialShininess Front $= shine * 128+      callList teapotList++-- display draws 5 teapots into the accumulation buffer several times; each time+-- with a jittered perspective. The focal point is at z = 5.0, so the gold+-- teapot will stay in focus. The amount of jitter is adjusted by the magnitude+-- of the accPerspective jitter; in this example, 0.33. In this example, the+-- teapots are drawn 8 times.+display :: DisplayList -> DisplayCallback+display teapotList = do+   (_, Size w h) <- get viewport+   clear [ AccumBuffer ]++   flip mapM_ j8 $ \(Vector2 x y) -> do+      clear [ ColorBuffer, DepthBuffer ]+      accPerspective 45 (fromIntegral w / fromIntegral h) 1 15+                     (Vector2 0 0) (Vector2 (0.33 * x) (0.33 * y)) 5++      -- ruby, gold, silver, emerald, and cyan teapots+      renderTeapot teapotList+                   (Vector3 (-1.1) (-0.5) (-4.5))+                   (Color4 0.1745     0.01175    0.01175    1)+                   (Color4 0.61424    0.04136    0.04136    1)+                   (Color4 0.727811   0.626959   0.626959   1)+                   0.6+      renderTeapot teapotList+                   (Vector3 (-0.5) (-0.5) (-5.0))+                   (Color4 0.24725    0.1995     0.0745     1)+                   (Color4 0.75164    0.60648    0.22648    1)+                   (Color4 0.628281   0.555802   0.366065   1)+                   0.4+      renderTeapot teapotList+                   (Vector3   0.2  (-0.5) (-5.5))+                   (Color4 0.19225    0.19225    0.19225    1)+                   (Color4 0.50754    0.50754    0.50754    1)+                   (Color4 0.508273   0.508273   0.508273   1)+                   0.4+      renderTeapot teapotList+                   (Vector3   1.0  (-0.5) (-6.0))+                   (Color4 0.0215     0.1745     0.0215     1)+                   (Color4 0.07568    0.61424    0.07568    1)+                   (Color4 0.633      0.727811   0.633      1)+                   0.6+      renderTeapot teapotList+                   (Vector3   1.8  (-0.5) (-6.5))+                   (Color4 0.0        0.1        0.06       1)+                   (Color4 0.0        0.50980392 0.50980392 1)+                   (Color4 0.50196078 0.50196078 0.50196078 1)+                    0.25+      accum Accum (recip (genericLength j8))++   accum Return 1+   flush++reshape :: ReshapeCallback+reshape size = do+   viewport $= (Position 0 0, size)++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++-- Main Loop: Be certain you request an accumulation buffer.+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ]+   initialWindowSize $= Size 400 400+   initialWindowPosition $= Position 100 100+   createWindow progName+   teapotList <- myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   displayCallback $= display teapotList+   mainLoop
+ examples/RedBook/Data/leeds.bin view

binary file changed (absent → 720605 bytes)

+ examples/RedBook/Double.hs view
@@ -0,0 +1,76 @@+{-+   Double.hs (adapted from double.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This is a simple double buffered program.+   Pressing the left mouse button rotates the rectangle.+   Pressing the middle mouse button stops the rotation.+-}++import Data.IORef ( IORef, newIORef )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++data State = State { spin :: IORef GLfloat }++makeState :: IO State+makeState = do+   s <- newIORef 0+   return $ State { spin = s }++display :: State -> DisplayCallback+display state = do+   clear [ ColorBuffer ]+   preservingMatrix $ do+      s <- get (spin state)+      rotate s (Vector3 0 0 1)+      color (Color3 1 1 1 :: Color3 GLfloat)+      rect (Vertex2 (-25) (-25)) (Vertex2 25 25 :: Vertex2 GLfloat)+   swapBuffers++spinDisplay :: State -> IdleCallback+spinDisplay state = do+   let wrap n s = if s > n then s - n else s+   spin state $~ (wrap 360 . (+ 2))+   postRedisplay Nothing++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Flat++reshape :: ReshapeCallback+reshape size = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho (-50) 50 (-50) 50 (-1) 1+   matrixMode $= Modelview 0+   loadIdentity++keyboardMouse :: State -> KeyboardMouseCallback+keyboardMouse state (MouseButton b) Down _ _ =+   idleCallback $= case b of+      LeftButton -> Just (spinDisplay state)+      _ -> Nothing+-- ESC not handled in the original example, but useful nevertheless+keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess+keyboardMouse _ _ _ _ _ = return ()++--  Request double buffer display mode.+--  Register mouse input callback functions+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ DoubleBuffered, RGBMode ]+   initialWindowSize $= Size 250 250+   initialWindowPosition $= Position 100 100+   createWindow progName+   state <- makeState+   myInit+   displayCallback $= display state+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboardMouse state)+   mainLoop
+ examples/RedBook/DrawF.hs view
@@ -0,0 +1,62 @@+{-+   DrawF.hs  (adapted from drawf.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   Draws the bitmapped letter F on the screen (several times).+   This demonstrates use of the bitmap call.+-}++import Foreign ( Ptr, newArray )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++myInit :: IO (Ptr GLubyte)+myInit = do+   rowAlignment Unpack $= 1+   clearColor $= Color4 0 0 0 0+   newArray [+      0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00,+      0xff, 0x00, 0xff, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00,+      0xff, 0xc0, 0xff, 0xc0 ]++display :: Ptr GLubyte -> DisplayCallback+display rasters = do+   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+       rasterPos2i = rasterPos :: Vertex2 GLint -> IO ()+   color3f (Color3 1 1 1)+   rasterPos2i (Vertex2 20 20)+   sequence_ $ replicate 3 $+      bitmap (Size 10 12) (Vertex2 0 0) (Vector2 11 0) rasters+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1+   matrixMode $= Modelview 0++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++-- Main Loop+-- Open window with initial window size, title bar,+-- RGBA display mode, and handle input events.+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 100 100+   initialWindowPosition $= Position 100 100+   createWindow progName+   rasters <- myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   displayCallback $= display rasters+   mainLoop
+ examples/RedBook/Feedback.hs view
@@ -0,0 +1,77 @@+{-+   Feedback.hs (adapted from feedback.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates use of OpenGL feedback. First, a lighting+   environment is set up and a few lines are drawn. Then feedback mode is+   entered, and the same lines are drawn. The results in the feedback buffer are+   printed.+-}++import Control.Monad ( when )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++-- Initialize lighting.+myInit :: IO ()+myInit = do+   lighting $= Enabled+   light (Light 0) $= Enabled++-- Draw a few lines and two points, one of which will be clipped. If in feedback+-- mode, a passthrough token is issued between each primitive+drawGeometry :: IO ()+drawGeometry = do+   mode <- get renderMode+   -- resolve overloading, not needed in "real" programs+   let normal3f = normal :: Normal3 GLfloat -> IO ()+       vertex3f = vertex :: Vertex3 GLfloat -> IO ()+   renderPrimitive LineStrip $ do+      normal3f (Normal3 0 0 1)+      vertex3f (Vertex3 30 30 0)+      vertex3f (Vertex3 50 60 0)+      vertex3f (Vertex3 70 40 0)+   when (mode == Feedback) $+      passThrough (PassThroughValue 1)+   renderPrimitive Points $+      vertex3f (Vertex3 (-100) (-100) (-100))   -- will be clipped+   when (mode == Feedback) $+      passThrough (PassThroughValue 2)+   renderPrimitive Points $ do+      normal3f (Normal3 0 0 1)+      vertex3f (Vertex3 50 50 0)+   flush   -- not in original example++printBuffer :: Maybe [FeedbackToken] -> IO ()+printBuffer = maybe (putStrLn "feedback buffer overflow") (mapM_ print)++display :: DisplayCallback+display = do+   matrixMode $= Projection+   loadIdentity+   ortho 0 100 0 100 0 1++   clearColor $= Color4 0 0 0 0+   clear [ ColorBuffer ]+   drawGeometry++   (_, tokens) <- getFeedbackTokens 1024 ThreeDColor drawGeometry+   printBuffer tokens++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 100 100+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   displayCallback $= display+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/Fog.hs view
@@ -0,0 +1,90 @@+{-+   Fog.hs (adapted from fog.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program draws 5 red spheres, each at a different z distance from the+   eye, in different types of fog. Pressing the f key chooses between 3 types+   of fog: exponential, exponential squared, and linear. In this program, there+   is a fixed density value, as well as fixed start and end values for the+   linear fog.+-}++import Data.Char ( toLower )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++myInit :: IO ()+myInit = do+   depthFunc $= Just Less++   position (Light 0) $= Vertex4 0.5 0.5 3.0 0.0+   lighting $= Enabled+   light (Light 0) $= Enabled++   -- NOTE: The alpha values are missing from fog.c!+   materialAmbient   Front $= Color4 0.1745   0.01175  0.01175  1.0+   materialDiffuse   Front $= Color4 0.61424  0.04136  0.04136  1.0+   materialSpecular  Front $= Color4 0.727811 0.626959 0.626959 1.0+   materialShininess Front $= 0.6 * 128++   fog $= Enabled+   let c = Color4 0.5 0.5 0.5 1.0+   fogMode $= Exp 0.35+   fogColor $= c+   hint Fog $= DontCare+   clearColor $= c++renderSpehere :: Vector3 GLfloat -> IO ()+renderSpehere xyz =+   preservingMatrix $ do+      translate xyz+      renderObject Solid (Sphere' 0.4 16 16)++-- display draws 5 spheres at different z positions.+display :: DisplayCallback+display = do+   clear [ ColorBuffer, DepthBuffer ]+   mapM_ renderSpehere [ Vector3 x (-0.5) (-3 - x) | x <- [-2 .. 2] ]+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10.0) 10.0+      else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10.0) 10.0+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: KeyboardMouseCallback+keyboard (Char c) Down _ _ = case toLower c of+   'f'   -> do+      mode <- get fogMode+      case mode of+         Linear _ _    -> do fogMode $= Exp   0.35; putStrLn "Fog mode is Exp"+         Exp _         -> do fogMode $= Exp2  0.35; putStrLn "Fog mode is Exp2"+         Exp2 _        -> do fogMode $= Linear 1 5; putStrLn "Fog mode is Linear"+      postRedisplay Nothing+   '\27' -> exitWith ExitSuccess+   _     -> return ()+keyboard _ _ _ _ = return ()++-- Main Loop: Open window with initial window size, title bar, RGBA display+-- mode, depth buffer, and handle input events.+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 500 500+   createWindow progName+   myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   displayCallback $= display+   mainLoop
+ examples/RedBook/FogCoord.hs view
@@ -0,0 +1,122 @@+{-+   FogCoord.hs (adapted from fogcoord.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates the use of explicit fog coordinates. You can press+   the keyboard and change the fog coordinate value at any vertex. You can also+   switch between using explicit fog coordinates and the default fog generation+   mode.++   Pressing the 'f' and 'b' keys move the viewer forward and backwards. Pressing+   'c' initiates the default fog generation.  Pressing capital 'C' restores+   explicit fog coordinates.  Pressing '1', '2', '3', '8', '9', and '0' add or+   subtract from the fog coordinate values at one of the three vertices of the+   triangle.+-}++import Control.Monad ( when )+import Data.IORef ( IORef, newIORef )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++data State = State { f1, f2, f3 :: IORef (FogCoord1 GLfloat)   }++makeState :: IO State+makeState = do+   f1' <- newIORef (FogCoord1  1)+   f2' <- newIORef (FogCoord1  5)+   f3' <- newIORef (FogCoord1 10)+   return $ State { f1 = f1', f2 = f2', f3 = f3' }++-- Initialize fog+myInit :: IO ()+myInit = do+   let theFogColor = Color4 0 0.25 0.25 1+   fog $= Enabled+   fogMode $= Exp 0.25+   fogColor $= theFogColor+   hint Fog $= DontCare+   fogCoordSrc $= FogCoord+   clearColor $= theFogColor++drawTriangle :: State -> (State -> IORef (FogCoord1 GLfloat)) -> Vertex3 GLfloat -> IO ()+drawTriangle state f v = do+   fc <- get (f state)+   fogCoord fc+   vertex v++-- display draws a triangle at an angle.+display :: State -> DisplayCallback+display state = do+   clear [ ColorBuffer ]++   color (Color3 1 0.75 (0 :: GLfloat))+   renderPrimitive Triangles $ do+      drawTriangle state f1 (Vertex3   2  (-2)   0 )+      drawTriangle state f2 (Vertex3 (-2)   0  (-5))+      drawTriangle state f3 (Vertex3   0    2 (-10))++   swapBuffers++reshape :: ReshapeCallback+reshape size = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective 45 1 0.25 25+   matrixMode $= Modelview 0+   loadIdentity+   translate (Vector3 0 0 (-5 :: GLfloat))++keyboard :: State -> KeyboardMouseCallback+keyboard state (Char c) Down _ _ = case c of+   'c'   -> setSrc FragmentDepth+   'C'   -> setSrc FogCoord+   '1'   -> inc f1   0.25+   '2'   -> inc f2   0.25+   '3'   -> inc f3   0.25+   '8'   -> inc f1 (-0.25)+   '9'   -> inc f2 (-0.25)+   '0'   -> inc f3 (-0.25)+   'b'   -> trans  (-0.25)+   'f'   -> trans    0.25+   '\27' -> exitWith ExitSuccess+   _     -> return ()+   where setSrc :: FogCoordSrc -> IO ()+         setSrc s = do+            fogCoordSrc $= s+            postRedisplay Nothing++         inc :: (State -> IORef (FogCoord1 GLfloat)) -> GLfloat -> IO ()+         inc f x = do+            FogCoord1 oldValue <- get (f state)+            let newValue = oldValue + x+            when (newValue > 0) $ do+               f state $= FogCoord1 newValue+               postRedisplay Nothing++         trans :: GLfloat -> IO ()+         trans x = do+            matrixMode $= Modelview 0+            translate (Vector3 0 0 x)+            postRedisplay Nothing+keyboard _ _ _ _ _ = return ()++-- Main Loop: Open window with initial window size, title bar, RGBA display+-- mode, and handle input events.+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ DoubleBuffered, RGBMode ]+   initialWindowSize $= Size 500 500+   createWindow progName+   state <- makeState+   myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboard state)+   displayCallback $= display state+   mainLoop++
+ examples/RedBook/FogIndex.hs view
@@ -0,0 +1,76 @@+{-+   FogIndex.hs (adapted from fogindex.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program draws 5 wireframe spheres, each at a different z distance from+   the eye, in linear fog.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++-- Initialize color map and fog. Set screen clear color to end of color ramp.+numColors, rampStart :: GLint+numColors = 32+rampStart = 16++myInit :: IO ()+myInit = do+   depthFunc $= Just Less++   flip mapM_ [ 0 .. numColors - 1 ] $ \i -> do+      let shade = fromIntegral (numColors - i) / fromIntegral numColors+      colorMapEntry (Index1 (rampStart + i)) $= Color3 shade shade shade+   fog $= Enabled++   fogMode $= Linear 1 6+   fogIndex $= Index1 numColors+   hint Fog $= Nicest+   clearIndex $= Index1 (fromIntegral (numColors + rampStart - 1))++renderSpehere :: Vector3 GLfloat -> IO ()+renderSpehere xyz =+   preservingMatrix $ do+      translate xyz+      renderObject Wireframe (Sphere' 0.4 16 16)++-- display draws 5 spheres at different z positions.+display :: DisplayCallback+display = do+   clear [ ColorBuffer, DepthBuffer ]+   index (Index1 rampStart)+   mapM_ renderSpehere [ Vector3 x (-0.5) (-3 - x) | x <- [-2 .. 2] ]+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10.0) 10.0+      else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10.0) 10.0+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _ _ _ _ = return ()++-- Main Loop: Open window with initial window size, title bar, color index+-- display mode, depth buffer, and handle input events.+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, IndexMode, WithDepthBuffer ]+   initialWindowSize $= Size 500 500+   createWindow progName+   myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   displayCallback $= display+   mainLoop
+ examples/RedBook/Font.hs view
@@ -0,0 +1,127 @@+{-+   Font.hs  (adapted from font.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   Draws some text in a bitmapped font. Uses bitmap and other pixel routines.+   Also demonstrates use of display lists.+-}++import Control.Monad ( zipWithM_ )+import Data.List ( genericDrop, genericLength )+import Foreign.C.String ( castCharToCChar )+import Foreign.Marshal.Array ( withArray )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++space :: [GLubyte]+space = [+     0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 ]++letters :: [[GLubyte]]+letters = [+   [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xff, 0xc3, 0xc3, 0xc3, 0x66, 0x3c, 0x18 ],+   [ 0x00, 0x00, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ],+   [ 0x00, 0x00, 0x7e, 0xe7, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xe7, 0x7e ],+   [ 0x00, 0x00, 0xfc, 0xce, 0xc7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc7, 0xce, 0xfc ],+   [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0xc0, 0xc0, 0xfc, 0xc0, 0xc0, 0xc0, 0xc0, 0xff ],+   [ 0x00, 0x00, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xfc, 0xc0, 0xc0, 0xc0, 0xff ],+   [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xcf, 0xc0, 0xc0, 0xc0, 0xc0, 0xe7, 0x7e ],+   [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xff, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ],+   [ 0x00, 0x00, 0x7e, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x7e ],+   [ 0x00, 0x00, 0x7c, 0xee, 0xc6, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06 ],+   [ 0x00, 0x00, 0xc3, 0xc6, 0xcc, 0xd8, 0xf0, 0xe0, 0xf0, 0xd8, 0xcc, 0xc6, 0xc3 ],+   [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0 ],+   [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xdb, 0xff, 0xff, 0xe7, 0xc3 ],+   [ 0x00, 0x00, 0xc7, 0xc7, 0xcf, 0xcf, 0xdf, 0xdb, 0xfb, 0xf3, 0xf3, 0xe3, 0xe3 ],+   [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xe7, 0x7e ],+   [ 0x00, 0x00, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ],+   [ 0x00, 0x00, 0x3f, 0x6e, 0xdf, 0xdb, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0x66, 0x3c ],+   [ 0x00, 0x00, 0xc3, 0xc6, 0xcc, 0xd8, 0xf0, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ],+   [ 0x00, 0x00, 0x7e, 0xe7, 0x03, 0x03, 0x07, 0x7e, 0xe0, 0xc0, 0xc0, 0xe7, 0x7e ],+   [ 0x00, 0x00, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0xff ],+   [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ],+   [ 0x00, 0x00, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ],+   [ 0x00, 0x00, 0xc3, 0xe7, 0xff, 0xff, 0xdb, 0xdb, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ],+   [ 0x00, 0x00, 0xc3, 0x66, 0x66, 0x3c, 0x3c, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3 ],+   [ 0x00, 0x00, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3 ],+   [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0x60, 0x30, 0x7e, 0x0c, 0x06, 0x03, 0x03, 0xff ]]++charToGLubyte :: Char -> GLubyte+charToGLubyte = fromIntegral . castCharToCChar++makeRasterFont :: IO DisplayList+makeRasterFont = do+   rowAlignment Unpack $= 1++   fontDisplayLists@(fontOffset:_) <- genObjectNames 128+   let listsStartingWith ch = genericDrop (charToGLubyte ch) fontDisplayLists+       makeLetter dl letter =+          defineList dl Compile $+             withArray letter $+                bitmap (Size 8 13) (Vertex2 0 2) (Vector2 10 0)++   zipWithM_ makeLetter (listsStartingWith 'A') letters+   makeLetter (head (listsStartingWith ' ')) space+   return fontOffset++myInit :: IO DisplayList+myInit = do+   shadeModel $= Flat+   makeRasterFont++printString :: DisplayList -> String -> IO ()+printString fontOffset s =+   preservingAttrib [ ListAttributes ] $ do+      listBase $= fontOffset+      withArray (map charToGLubyte s) $+         callLists (genericLength s) UnsignedByte++-- Everything above this line could be in a library+-- that defines a font.  To make it work, you've got+-- to call makeRasterFont before you start making+-- calls to printString.+display :: DisplayList -> DisplayCallback+display fontOffset = do+   let white = Color3 1 1 1++   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+       rasterPos2i = rasterPos :: Vertex2 GLint -> IO ()+   color3f white++   rasterPos2i (Vertex2 20 60)+   printString fontOffset "THE QUICK BROWN FOX JUMPS"+   rasterPos2i (Vertex2 20 40)+   printString fontOffset "OVER A LAZY DOG"+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1+   matrixMode $= Modelview 0++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++-- Main Loop+-- Open window with initial window size, title bar,+-- RGBA display mode, and handle input events.+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 300 100+   initialWindowPosition $= Position 100 100+   createWindow progName+   fontOffset <- myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   displayCallback $= display fontOffset+   mainLoop
+ examples/RedBook/Hello.hs view
@@ -0,0 +1,55 @@+{-+   Hello.hs (adapted from hello.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This is a simple, introductory OpenGL program.+-}++import Graphics.UI.GLUT++display :: DisplayCallback+display = do+   -- clear all pixels+   clear [ ColorBuffer ]++   -- draw white polygon (rectangle) with corners at+   -- (0.25, 0.25, 0.0) and (0.75, 0.75, 0.0)+   color (Color3 1.0 1.0 (1.0 :: GLfloat))+   -- resolve overloading, not needed in "real" programs+   let vertex3f = vertex :: Vertex3 GLfloat -> IO ()+   renderPrimitive Polygon $ mapM_ vertex3f [+      Vertex3 0.25 0.25 0.0,+      Vertex3 0.75 0.25 0.0,+      Vertex3 0.75 0.75 0.0,+      Vertex3 0.25 0.75 0.0]++   -- don't wait!+   -- start processing buffered OpenGL routines+   flush++myInit :: IO ()+myInit = do+   -- select clearing color+   clearColor $= Color4 0 0 0 0++   -- initialize viewing values+   matrixMode $= Projection+   loadIdentity+   ortho 0 1 0 1 (-1) 1++-- Declare initial window size, position, and display mode (single buffer and+-- RGBA). Open window with "hello" in its title bar. Call initialization+-- routines. Register callback function to display graphics. Enter main loop and+-- process events.+main :: IO ()+main = do+   getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 250 250+   initialWindowPosition $= Position 100 100+   createWindow "hello"+   myInit+   displayCallback $= display+   mainLoop
+ examples/RedBook/Histogram.hs view
@@ -0,0 +1,85 @@+{-+   Histogram.hs (adapted from histogram.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   Compute the histogram of the image.  This program illustrates the use of+   the histogram function.+-}++import Control.Monad ( zipWithM_ )+import Foreign ( allocaArray, peekArray )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT+import ReadImage++histogramSize :: Int+histogramSize = 256   -- Must be a power of 2++myInit :: IO ()+myInit = do+   rowAlignment Unpack $= 1+   clearColor $= Color4 0 0 0 0++   histogram NoProxy $= Just (fromIntegral histogramSize, RGB', PassThrough)++display :: Size -> PixelData a -> DisplayCallback+display size pixels = do+   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let rasterPos2i = rasterPos :: Vertex2 GLint -> IO ()+   rasterPos2i (Vertex2 1 1)+   drawPixels size pixels++   values <- allocaArray histogramSize $ \buf -> do+      -- Note: The example in the Red Book uses GL_UNSIGNED_SHORT here,+      -- but we are more honest by using Short...+      getHistogram Reset (PixelData RGB Short buf)+      peekArray histogramSize buf++   -- Plot histogram+   zipWithM_ (plotHistogram values)+             [  Color3 1 0 0,         Color3 0 1 0,         Color3 0 0 1       ]+             [\(Color3 r _ _) -> r, \(Color3 _ g _) -> g, \(Color3 _ _ b) -> b ]+   flush++plotHistogram ::+   [Color3 GLshort] -> Color3 GLfloat -> (Color3 GLshort -> GLshort) -> IO ()+plotHistogram values c selectComponent =+   renderPrimitive LineStrip $ do+      color c+      zipWithM_ (\i h -> vertex (Vertex2 i (selectComponent h))) [ 0 .. ] values++reshape :: ReshapeCallback+reshape size = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho 0 (fromIntegral histogramSize) 0 10000 (-1) 1+   matrixMode $= Modelview 0++keyboard :: KeyboardMouseCallback+keyboard (Char 's')   Down _ _ = do+   Just (width, format, sink) <- get (histogram NoProxy)+   let newSink = if sink == Sink then PassThrough else Sink+   histogram NoProxy $= Just (width, format, newSink)+   postRedisplay Nothing+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++-- Main Loop: Open window with initial window size, title bar, RGBA display+-- mode, and handle input events.+main :: IO ()+main = do+   (progName, args) <- getArgsAndInitialize+   (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args)+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= size+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   displayCallback $= display size pixels+   mainLoop
+ examples/RedBook/Image.hs view
@@ -0,0 +1,116 @@+{-+   Image.hs  (adapted from image.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates drawing pixels and shows the effect of+   drawPixels, copyPixels, and pixelZoom.++   Interaction: moving the mouse while pressing the mouse button will copy+   the image in the lower-left corner of the window to the mouse position,+   using the current pixel zoom factors. There is no attempt to prevent you+   from drawing over the original image. If you press the 'r' key, the+   original image and zoom factors are reset. If you press the 'z' or 'Z'+   keys, you change the zoom factors.+-}++import Data.Bits ( (.&.) )+import Data.IORef ( IORef, newIORef )+import Foreign ( newArray )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++data State = State { zoomFactor :: IORef GLfloat }++makeState :: IO State+makeState = do+   z <- newIORef 1+   return $ State { zoomFactor = z }++-- Create checkerboard image+checkImageSize :: Size+checkImageSize = Size 64 64++type Image = PixelData (Color3 GLubyte)++makeCheckImage :: Size -> GLsizei -> (GLubyte -> (Color3 GLubyte)) -> IO Image+makeCheckImage (Size w h) n f =+   fmap (PixelData RGB UnsignedByte) $+      newArray [ f c |+                 i <- [ 0 .. w - 1 ],+                 j <- [ 0 .. h - 1 ],+                 let c | (i .&. n) == (j .&. n) = 0+                       | otherwise              = 255 ]++myInit :: IO Image+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Flat+   rowAlignment Unpack $= 1+   makeCheckImage checkImageSize 0x8 (\c -> Color3 c c c)++display ::  Image -> DisplayCallback+display pixelData = do+   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let rasterPos2i = rasterPos :: Vertex2 GLint -> IO ()+   rasterPos2i (Vertex2 0 0)+   drawPixels checkImageSize pixelData+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho2D 0 (fromIntegral w) 0 (fromIntegral h)+   matrixMode $= Modelview 0+   loadIdentity++motion :: State -> MotionCallback+motion state (Position x y) = do+   Size _ height <- get windowSize+   let screenY = height - y+   -- resolve overloading, not needed in "real" programs+   let rasterPos2i = rasterPos :: Vertex2 GLint -> IO ()+   rasterPos2i (Vertex2 x screenY)+   z <- get (zoomFactor state)+   pixelZoom $= (z, z)+   copyPixels (Position 0 0) checkImageSize CopyColor+   pixelZoom $= (1, 1)+   flush++resetZoomFactor :: State -> IO ()+resetZoomFactor state = do+   zoomFactor state $= 1.0+   postRedisplay Nothing+   putStrLn "zoomFactor reset to 1.0"++incZoomFactor :: State -> GLfloat -> IO ()+incZoomFactor state inc = do+   zoomFactor state $~! (max 0.5 . min 3.0 . (+ inc))+   get (zoomFactor state) >>= putStrLn . ("zoomFactor is now " ++) . show++keyboard :: State -> KeyboardMouseCallback+keyboard state (Char 'r')   Down _   _ = resetZoomFactor state+keyboard state (Char 'R')   Down _   _ = resetZoomFactor state+keyboard state (Char 'z')   Down _   _ = incZoomFactor   state   0.5+keyboard state (Char 'Z')   Down _   _ = incZoomFactor   state (-0.5)+keyboard _     (Char '\27') Down _   _ = exitWith ExitSuccess+keyboard _     _            _    _   _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 250 250+   initialWindowPosition $= Position 100 100+   createWindow progName+   state <- makeState+   checkImage <- myInit+   displayCallback $= display checkImage+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboard state)+   motionCallback $= Just (motion state)+   mainLoop
+ examples/RedBook/Light.hs view
@@ -0,0 +1,62 @@+{-+   Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates the use of the OpenGL lighting model. A sphere+   is drawn using a grey material characteristic. A single light source+   illuminates the object.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Smooth++   materialSpecular Front $= Color4 1 1 1 1+   materialShininess Front $= 50+   position (Light 0) $= Vertex4 1 1 1 0++   lighting $= Enabled+   light (Light 0) $= Enabled+   depthFunc $= Just Less++display :: DisplayCallback+display = do+   clear [ ColorBuffer, DepthBuffer ]+   renderObject Solid (Sphere' 1 20 16)+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho (-1.5) 1.5 (-1.5 * hf/wf) (1.5 * hf/wf) (-10) 10+      else ortho (-1.5 * wf/hf) (1.5 * wf/hf) (-1.5) 1.5 (-10) 10+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   displayCallback $= display+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/Lines.hs view
@@ -0,0 +1,88 @@+{-+   Lines.hs (adapted from lines.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates geometric primitives and their attributes.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++drawOneLine :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO ()+drawOneLine p1 p2 = renderPrimitive Lines $ do vertex p1; vertex p2++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Flat++display :: DisplayCallback+display = do+   clear [ ColorBuffer ]+   -- select white for all lines+   color (Color3 1.0 1.0 1.0 :: Color3 GLfloat)++   -- in 1st row, 3 lines, each with a different stipple+   lineStipple $= Just (1, 0x0101)  --  dotted+   drawOneLine (Vertex2  50 125) (Vertex2 150 125)+   lineStipple $= Just (1, 0x00FF)  --  dashed+   drawOneLine (Vertex2 150 125) (Vertex2  50 125)+   lineStipple $= Just (1, 0x1C47)  --  dash/dot/dash+   drawOneLine (Vertex2 250 125) (Vertex2 350 125)++   -- in 2nd row, 3 wide lines, each with different stipple+   lineWidth $= 5.0+   lineStipple $= Just (1, 0x0101)  --  dotted+   drawOneLine (Vertex2  50 100) (Vertex2 150 100)+   lineStipple $= Just (1, 0x00FF)  --  dashed+   drawOneLine (Vertex2 150 100) (Vertex2 250 100)+   lineStipple $= Just (1, 0x1C47)  --  dash/dot/dash+   drawOneLine (Vertex2 250 100) (Vertex2 350 100)+   lineWidth $= 1.0++   -- in 3rd row, 6 lines, with dash/dot/dash stipple+   -- as part of a single connected line strip+   lineStipple $= Just (1, 0x1C47)  --  dash/dot/dash+   renderPrimitive LineStrip $ mapM_ vertex [ Vertex2 (50+(i*50)) (75 :: GLint) | i <- [0..6] ]++   -- in 4th row, 6 independent lines with same stipple+   sequence_ [ drawOneLine (Vertex2 (50+( i   *50)) 50)+                           (Vertex2 (50+((i+1)*50)) 50) | i <- [0..5] ]++   -- in 5th row, 1 line, with dash/dot/dash stipple+   -- and a stipple repeat factor of 5+   lineStipple $= Just (5, 0x1C47)  --  dash/dot/dash+   drawOneLine (Vertex2 50 25) (Vertex2 350 25)++   lineStipple $= Nothing+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho2D 0 (fromIntegral w) 0 (fromIntegral h)+   -- the following line is not in the original example, but it's good style...+   matrixMode $= Modelview 0++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _ _ _ _ = return ()++--  Request double buffer display mode.+--  Register mouse input callback functions+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 400 150+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   displayCallback $= display+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/MVArray.hs view
@@ -0,0 +1,87 @@+{-+   MVArray.hs (adapted from mvarray.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates multiple vertex arrays, specifically the OpenGL+   routine multiDrawElements.+-}++import Control.Monad ( unless )+import Data.List ( genericLength )+import Foreign ( Storable, Ptr, newArray )+import System.Exit ( exitFailure, exitWith, ExitCode(..) )+import Graphics.UI.GLUT++data MultiDrawInfo a = MultiDrawInfo (Ptr GLsizei) (Ptr (Ptr a)) GLsizei++makeMultiDrawInfo :: Storable a => [[a]] -> IO (MultiDrawInfo a)+makeMultiDrawInfo indicesLists = do+   count <- newArray $ map genericLength indicesLists+   indices <- newArray =<< mapM newArray indicesLists+   return $ MultiDrawInfo count indices (genericLength indicesLists)++setupPointer :: IO ()+setupPointer = do+   clientState VertexArray $= Enabled+   vertices <- newArray ([+      Vertex2  25 25,+      Vertex2  75 75,+      Vertex2 100 125,+      Vertex2 150  75,+      Vertex2 200 175,+      Vertex2 250 150,+      Vertex2 300 125,+      Vertex2 100 200,+      Vertex2 150 250,+      Vertex2 200 225,+      Vertex2 250 300,+      Vertex2 300 250 ] :: [Vertex2 GLint])+   arrayPointer VertexArray $= VertexArrayDescriptor 2 Int 0 vertices++myInit :: IO (MultiDrawInfo GLubyte)+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Smooth+   setupPointer+   makeMultiDrawInfo [ [ 0, 1, 2, 3, 4, 5, 6 ],+                       [ 1, 7, 8, 9, 10, 11 ] ]++display :: MultiDrawInfo GLubyte -> DisplayCallback+display (MultiDrawInfo count indices primCount) = do+   clear [ ColorBuffer ]+   color (Color3 1 1 1 :: Color3 GLfloat)+   multiDrawElements LineStrip count UnsignedByte indices primCount+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho2D 0 (fromIntegral w) 0 (fromIntegral h)+   -- the following line is not in the original example, but it's good style...+   matrixMode $= Modelview 0++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _ _ _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 350 350+   initialWindowPosition $= Position 100 100+   createWindow progName+   -- we have to do this *after* createWindow, otherwise we have no OpenGL context+   exts <- get glExtensions+   unless ("GL_EXT_multi_draw_arrays" `elem` exts) $ do+      putStrLn "Sorry, this demo requires the GL_EXT_multi_draw_arrays extension."+      exitFailure+   multiDrawInfo <- myInit+   displayCallback $= display multiDrawInfo+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/Material.hs view
@@ -0,0 +1,149 @@+{-+   Material.hs (adapted from material.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates the use of the GL lighting model. Several+   objects are drawn using different material characteristics. A single+   light source illuminates the objects.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++-- Initialize z-buffer, projection matrix, light source, and lighting model.+-- Do not specify a material property here.++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0.1 0.1 0+   depthFunc $= Just Less+   shadeModel $= Smooth++   ambient (Light 0) $= Color4 0 0 0 1+   diffuse (Light 0) $= Color4 1 1 1 1+   position (Light 0) $= Vertex4 0 3 2 0+   lightModelAmbient $= Color4 0.4 0.4 0.4 1+   lightModelLocalViewer $= Disabled++   lighting $= Enabled+   light (Light 0) $= Enabled++-- Draw twelve spheres in 3 rows with 4 columns.+-- The spheres in the first row have materials with no ambient reflection.+-- The second row has materials with significant ambient reflection.+-- The third row has materials with colored ambient reflection.+--+-- The first column has materials with blue, diffuse reflection only.+-- The second column has blue diffuse reflection, as well as specular+-- reflection with a low shininess exponent.+-- The third column has blue diffuse reflection, as well as specular+-- reflection with a high shininess exponent (a more concentrated highlight).+-- The fourth column has materials which also include an emissive component.+--+-- translate is used to move spheres to their appropriate locations.++display :: DisplayCallback+display = do+   clear [ ColorBuffer, DepthBuffer ]++   let draw :: GLfloat -> GLfloat -> Color4 GLfloat -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> Color4 GLfloat -> IO ()+       draw row column amb dif spc shi emi =+          preservingMatrix $ do+             translate (Vector3 (2.5 * (column - 2.5)) (3 * (2 - row)) 0)+             materialAmbient   Front $= amb+             materialDiffuse   Front $= dif+             materialSpecular  Front $= spc+             materialShininess Front $= shi+             materialEmission  Front $= emi+             renderObject Solid (Sphere' 1 16 16)++       noMat           = Color4 0 0 0 1+       matAmbient      = Color4 0.7 0.7 0.7 1+       matAmbientColor = Color4 0.8 0.8 0.2 1+       matDiffuse      = Color4 0.1 0.5 0.8 1+       matSpecular     = Color4 1 1 1 1+       noShininess     = 0+       lowShininess    = 5+       highShininess   = 100+       matEmission     = Color4 0.3 0.2 0.2 0++   -- draw sphere in first row, first column+   -- diffuse reflection only; no ambient or specular+   draw 1 1 noMat matDiffuse noMat noShininess noMat++   -- draw sphere in first row, second column+   -- diffuse and specular reflection; low shininess; no ambient+   draw 1 2 noMat matDiffuse matSpecular lowShininess noMat++   -- draw sphere in first row, third column+   -- diffuse and specular reflection; high shininess; no ambient+   draw 1 3 noMat matDiffuse matSpecular highShininess noMat++   -- draw sphere in first row, fourth column+   -- diffuse reflection; emission; no ambient or specular reflection+   draw 1 4 noMat matDiffuse noMat noShininess matEmission++   -- draw sphere in second row, first column+   -- ambient and diffuse reflection; no specular+   draw 2 1 matAmbient matDiffuse noMat noShininess noMat++   -- draw sphere in second row, second column+   -- ambient, diffuse and specular reflection; low shininess+   draw 2 2 matAmbient matDiffuse matSpecular lowShininess noMat++   -- draw sphere in second row, third column+   -- ambient, diffuse and specular reflection; high shininess+   draw 2 3 matAmbient matDiffuse matSpecular highShininess noMat++   -- draw sphere in second row, fourth column+   -- ambient and diffuse reflection; emission; no specular+   draw 2 4 matAmbient matDiffuse noMat noShininess matEmission++   -- draw sphere in third row, first column+   -- colored ambient and diffuse reflection; no specular+   draw 3 1 matAmbientColor matDiffuse noMat noShininess noMat++   -- draw sphere in third row, second column+   -- colored ambient, diffuse and specular reflection; low shininess+   draw 3 2 matAmbientColor matDiffuse matSpecular lowShininess noMat++   -- draw sphere in third row, third column+   -- colored ambient, diffuse and specular reflection; high shininess+   draw 3 3 matAmbientColor matDiffuse matSpecular highShininess noMat++   -- draw sphere in third row, fourth column+   -- colored ambient and diffuse reflection; emission; no specular+   draw 3 4 matAmbientColor matDiffuse noMat noShininess matEmission++   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h * 2+      then ortho (-6) 6 (-3 * (hf * 2) / wf) (3 * (hf * 2) / wf) (-10) 10+      else ortho (-6 * wf / (hf * 2)) (6 * wf / (hf * 2)) (-3) 3 (-10) 10+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 600 450+   createWindow progName+   myInit+   reshapeCallback $= Just reshape+   displayCallback $= display+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/Minmax.hs view
@@ -0,0 +1,64 @@+{-+   Minmax.hs (adapted from minmax.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   Determine the minimum and maximum values of a group of pixels. This+   demonstrates use of the minmax function.+-}++import Foreign ( allocaArray, peekArray )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT+import ReadImage++myInit :: IO ()+myInit = do+   rowAlignment Unpack $= 1+   clearColor $= Color4 0 0 0 0+   minmax $= Just (RGB', PassThrough)++display :: Size -> PixelData a -> DisplayCallback+display size pixels = do+   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let rasterPos2i = rasterPos :: Vertex2 GLint -> IO ()+   rasterPos2i (Vertex2 1 1)+   drawPixels size pixels+   flush++   [Color3 minR minG minB, Color3 maxR maxG maxB] <- allocaArray 2 $ \buf -> do+      getMinmax Reset (PixelData RGB UnsignedByte buf)+      peekArray 2 buf :: IO [Color3 GLubyte]+   putStrLn (" Red   : min = " ++ show minR ++ "   max = " ++ show maxR)+   putStrLn (" Green : min = " ++ show minG ++ "   max = " ++ show maxG)+   putStrLn (" Blue  : min = " ++ show minB ++ "   max = " ++ show maxB)++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1+   matrixMode $= Modelview 0++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++-- Main Loop: Open window with initial window size, title bar, RGBA display+-- mode, and handle input events.+main :: IO ()+main = do+   (progName, args) <- getArgsAndInitialize+   (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args)+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= size+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   displayCallback $= display size pixels+   mainLoop
+ examples/RedBook/Mipmap.hs view
@@ -0,0 +1,97 @@+{-+   Mipmap.hs  (adapted from mipmap.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates using mipmaps for texture maps. To overtly show+   the effect of mipmaps, each mipmap reduction level has a solidly colored,+   contrasting texture image. Thus, the quadrilateral which is drawn is drawn+   with several different colors.+-}++import Control.Monad ( when )+import Data.Maybe ( isJust, listToMaybe )+import Foreign ( withArray )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++makeImage :: Level -> TextureSize2D -> Color4 GLubyte -> IO ()+makeImage level size@(TextureSize2D w h) col =+   withArray (replicate (fromIntegral (w * h)) col) $+      texImage2D Nothing NoProxy level RGBA' size 0 . PixelData RGBA UnsignedByte++makeImages :: [Color4 GLubyte] -> IO ()+makeImages colors = sequence_ $ zipWith3 makeImage levels sizes colors+   where numLevels = length colors+         levels = [ 0 .. fromIntegral numLevels - 1 ]+         sizes = reverse (take numLevels [ TextureSize2D s s | s <- iterate (* 2) 1 ])++myInit :: IO (Maybe TextureObject)+myInit = do+   depthFunc $= Just Less+   shadeModel $= Flat++   translate (Vector3 0 0 (-3.6 :: GLfloat))+   rowAlignment Unpack $= 1++   exts <- get glExtensions+   mbTexName <- if "GL_EXT_texture_object" `elem` exts+                   then fmap listToMaybe $ genObjectNames 1+                   else return Nothing+   when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName++   textureWrapMode Texture2D S $= (Repeated, Repeat)+   textureWrapMode Texture2D T $= (Repeated, Repeat)+   textureFilter Texture2D $= ((Nearest, Just Nearest), Nearest)++   makeImages [ Color4 255 255   0 255,+                Color4 255   0 255 255,+                Color4 255   0   0 255,+                Color4   0 255   0 255,+                Color4   0   0 255 255,+                Color4 255 255 255 255 ]++   textureFunction $= Decal+   texture Texture2D $= Enabled+   return mbTexName++display :: Maybe TextureObject -> DisplayCallback+display mbTexName = do+   clear [ ColorBuffer, DepthBuffer ]+   when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName+   -- resolve overloading, not needed in "real" programs+   let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()+       vertex3f = vertex :: Vertex3 GLfloat -> IO ()+   renderPrimitive Quads $ do+      texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (  -2) (-1)      0 )+      texCoord2f (TexCoord2 0 8); vertex3f (Vertex3 (  -2)   1       0 )+      texCoord2f (TexCoord2 8 8); vertex3f (Vertex3  2000    1  (-6000))+      texCoord2f (TexCoord2 8 0); vertex3f (Vertex3  2000  (-1) (-6000))+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective 60 (fromIntegral w / fromIntegral h) 1 30000+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 50 50+   createWindow progName+   texName <- myInit+   displayCallback $= display texName+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/Model.hs view
@@ -0,0 +1,86 @@+{-+   Model.hs (adapted from model.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates modeling transformations.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Flat++drawTriangle :: IO ()+drawTriangle = do+   -- resolve overloading, not needed in "real" programs+   let vertex2f = vertex :: Vertex2 GLfloat -> IO ()+   renderPrimitive LineLoop $ do+      vertex2f (Vertex2    0    25 )+      vertex2f (Vertex2   25  (-25))+      vertex2f (Vertex2 (-25) (-25))++display :: DisplayCallback+display = do+   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+       translatef = translate :: Vector3 GLfloat -> IO ()+       scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO ()+       rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO ()+   color3f (Color3 1 1 1)++   loadIdentity+   color3f (Color3 1 1 1)+   drawTriangle++   lineStipple $= Just (1, 0xF0F0)+   loadIdentity+   translatef (Vector3 (-20) 0 0)+   drawTriangle++   lineStipple $= Just (1, 0xF00F)+   loadIdentity+   scalef 1.5 0.5 1.0+   drawTriangle++   lineStipple $= Just (1, 0x8888)+   loadIdentity+   rotatef 90 (Vector3 0 0 1)+   drawTriangle+   lineStipple $= Nothing++   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho (-50) 50 (-50 * hf/wf) (50 * hf/wf) (-1) 1+      else ortho (-50 * wf/hf) (50 * wf/hf) (-50) 50 (-1) 1+   matrixMode $= Modelview 0++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   displayCallback $= display+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/MoveLight.hs view
@@ -0,0 +1,85 @@+{-+   MoveLight.hs (adapted from movelight.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates when to issue lighting and transformation+   commands to render a model with a light which is moved by a+   modeling transformation (rotate or translate). The light position+   is reset after the modeling transformation is called. The eye+   position does not change.++   A sphere is drawn using a grey material characteristic. A single+   light source illuminates the object.++   Interaction: pressing the left mouse button alters the modeling+   transformation (x rotation) by 30 degrees. The scene is then+   redrawn with the light in a new position.+-}++import Data.IORef ( IORef, newIORef )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++data State = State { spin :: IORef Int }++makeState :: IO State+makeState = do+   s <- newIORef 0+   return $ State { spin = s }++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Smooth+   lighting $= Enabled+   light (Light 0) $= Enabled+   depthFunc $= Just Less++display :: State -> DisplayCallback+display state = do+   clear [ ColorBuffer, DepthBuffer ]+   preservingMatrix $ do+      lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0)+      preservingMatrix $ do+         s <- get (spin state)+         rotate (fromIntegral s :: GLdouble) (Vector3 1 0 0)+         position (Light 0) $= Vertex4 0 0 1.5 1+         translate (Vector3 0 0 1.5 :: Vector3 GLdouble)+         lighting $= Disabled+         color (Color3 0 1 1 :: Color3 GLfloat)+         renderObject Wireframe (Cube 0.1)+         lighting $= Enabled+      renderObject Solid (Torus 0.275 0.85 8 15)+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective 40 (fromIntegral w / fromIntegral h) 1 20+   matrixMode $= Modelview 0+   loadIdentity++keyboardMouse :: State -> KeyboardMouseCallback+keyboardMouse state (MouseButton LeftButton) Down _ _ = do+   spin state $~ ((`mod` 360) . (+ 30))+   postRedisplay Nothing+keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess+keyboardMouse _ _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   state <- makeState+   myInit+   displayCallback $= display state+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboardMouse state)+   mainLoop
+ examples/RedBook/MultiTex.hs view
@@ -0,0 +1,109 @@+{-+   MultiTex.hs  (adapted from multitex.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE+-}++import Control.Monad ( unless )+import Foreign ( withArray )+import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++specifyTexture :: TextureSize2D -> (GLubyte -> GLubyte -> Color4 GLubyte) -> IO ()+specifyTexture size@(TextureSize2D w h) f =+   withArray [ f i j | i <- [ 0 .. fromIntegral w - 1 ],+                       j <- [ 0 .. fromIntegral h - 1] ] $+      texImage2D Nothing NoProxy 0 RGBA' size 0 . PixelData RGBA UnsignedByte++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Flat+   depthFunc $= Just Less+   rowAlignment Unpack $= 1++   [texName0, texName1] <- genObjectNames 2+   textureBinding Texture2D $= Just texName0+   -- Note: We use much brighter colors than in the original example where+   -- everything was almost black.+   specifyTexture (TextureSize2D 32 32) (\i j -> Color4 (i*8) (j*8) ((i*j) `div` 4) 255)+   textureFilter Texture2D $= ((Nearest, Nothing), Nearest)+   textureWrapMode Texture2D S $= (Repeated, Repeat)+   textureWrapMode Texture2D T $= (Repeated, Repeat)++   textureBinding Texture2D $= Just texName1+   specifyTexture (TextureSize2D 16 16) (\i j -> Color4 255 (i*16) (j*16) 255)+   textureFilter Texture2D $= ((Linear', Nothing), Linear')+   textureWrapMode Texture2D S $= (Repeated, ClampToEdge)+   textureWrapMode Texture2D T $= (Repeated, ClampToEdge)+   -- Use the two texture objects to define two texture units+   -- for use in multitexturing+   activeTexture $= TextureUnit 0+   texture Texture2D $= Enabled+   textureBinding Texture2D $= Just texName0+   textureFunction $= Replace+   matrixMode $= Texture+   loadIdentity+   translate (Vector3 0.5 0.5 (0 :: GLfloat))+   rotate (45 :: GLfloat) (Vector3 0 0 1)+   translate (Vector3 (-0.5) (-0.5) (0 :: GLfloat))+   matrixMode $= Modelview 0+   activeTexture $= TextureUnit 1+   texture Texture2D $= Enabled+   textureBinding Texture2D $= Just texName1+   textureFunction $= Modulate++display ::  DisplayCallback+display = do+   clear [ ColorBuffer, DepthBuffer ]+   -- resolve overloading, not needed in "real" programs+   let multiTexCoord2f = multiTexCoord :: TextureUnit -> TexCoord2 GLfloat -> IO ()+       vertex2f = vertex :: Vertex2 GLfloat -> IO ()+   renderPrimitive Triangles $ do+      multiTexCoord2f (TextureUnit 0) (TexCoord2 0   0)+      multiTexCoord2f (TextureUnit 1) (TexCoord2 1   0)+      vertex2f (Vertex2 0 0)+      multiTexCoord2f (TextureUnit 0) (TexCoord2 0.5 1)+      multiTexCoord2f (TextureUnit 1) (TexCoord2 0.5 0)+      vertex2f (Vertex2 50 100)+      multiTexCoord2f (TextureUnit 0) (TexCoord2 1   0)+      multiTexCoord2f (TextureUnit 1) (TexCoord2 1   1)+      vertex2f (Vertex2 100 0)+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho2D 0 100 0 (100*hf/wf)+      else ortho2D 0 (100*wf/hf) 0 100+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 250 250+   initialWindowPosition $= Position 100 100+   createWindow progName+   -- we have to do this *after* createWindow, otherwise we have no OpenGL context+   exts <- get glExtensions+   unless ("GL_ARB_multitexture"   `elem` exts &&+           "GL_EXT_texture_object" `elem` exts) $ do+      putStrLn "Sorry, this demo requires the GL_ARB_multitexture and GL_EXT_texture_object extensions."+      exitFailure+   myInit+   reshapeCallback $= Just reshape+   displayCallback $= display+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/Multisamp.hs view
@@ -0,0 +1,137 @@+{-+   Multisamp.hs (adapted from multisamp.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program draws shows how to use multisampling to draw anti-aliased+   geometric primitives. The same display list, a pinwheel of triangles and+   lines of varying widths, is rendered twice. Multisampling is enabled when the+   left side is drawn. Multisampling is disabled when the right side is drawn.++   Pressing the 'b' key toggles drawing of the checkerboard background.+   Antialiasing is sometimes easier to see when objects are rendered over a+   contrasting background.+-}++import Control.Monad ( when )+import Data.Char ( toLower )+import Data.IORef ( IORef, newIORef )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++data State = State { bgToggle :: IORef Bool }++makeState :: IO State+makeState = do+   b <- newIORef True+   return $ State { bgToggle = b }++data DisplayLists = DisplayLists { pinwheelList, backgroundList :: DisplayList }++-- Print out state values related to multisampling. Create display list with+-- "pinwheel" of lines and triangles.+myInit :: IO DisplayLists+myInit = do+   clearColor $= Color4 0 0 0 0+   sb <- get sampleBuffers+   putStrLn ("number of sample buffers is " ++ show sb)+   s <- get samples+   putStrLn ("number of samples is " ++ show s)++   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+       vertex2f = vertex :: Vertex2 GLfloat -> IO ()++   p <- defineNewList Compile $ do+      flip mapM_ [ 0 .. 18 ] $ \i ->+         preservingMatrix $ do+            rotate (360 * fromIntegral i / 19 :: GLfloat) (Vector3 0 0 1)+            color3f (Color3 1 1 1)+            lineWidth $= fromIntegral ((i `mod` 3 :: Int) + 1)+            renderPrimitive Lines $ do+              vertex2f (Vertex2 0.25 0.05)+              vertex2f (Vertex2 0.9 0.2)+            color3f (Color3 0 1 1)+            renderPrimitive Triangles $ do+               vertex2f (Vertex2 0.25 0)+               vertex2f (Vertex2 0.9 0)+               vertex2f (Vertex2 0.875 0.1)++   b <- defineNewList Compile $ do+      color3f (Color3 1 0.5 0)+      renderPrimitive Quads $+         flip mapM_ [ 0 .. 15 ] $ \i ->+            flip mapM_ [ 0 .. 15 ] $ \j ->+               when (((i + j) `mod` 2 :: Int) == 0) $ do+                  let ii = fromIntegral i * 0.25+                      jj = fromIntegral j * 0.25+                  vertex2f (Vertex2 (-2.0  + ii) (-2.0  + jj))+                  vertex2f (Vertex2 (-2.0  + ii) (-1.75 + jj))+                  vertex2f (Vertex2 (-1.75 + ii) (-1.75 + jj))+                  vertex2f (Vertex2 (-1.75 + ii) (-2.0  + jj))++   return $ DisplayLists { pinwheelList = p, backgroundList = b }++-- Draw two sets of primitives, so that you can compare the user of+-- multisampling against its absence.+--+-- This code enables antialiasing and draws one display list and disables and+-- draws the other display list+display :: State -> DisplayLists -> DisplayCallback+display state displayLists = do+   clear [ ColorBuffer ]++   t <- get (bgToggle state)+   when t $+      callList (backgroundList displayLists)++   -- resolve overloading, not needed in "real" programs+   let translatef = translate :: Vector3 GLfloat -> IO ()++   multisample $= Enabled+   preservingMatrix $ do+      translatef (Vector3 (-1) 0 0)+      callList (pinwheelList displayLists)++   multisample $= Disabled+   preservingMatrix $ do+      translatef (Vector3 1 0 0)+      callList (pinwheelList displayLists)++   swapBuffers++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= 2 * h+      then ortho2D (-2) 2 (-2*hf/wf) (2*hf/wf)+      else ortho2D (-2*wf/hf) (2*wf/hf) (-2) 2+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: State -> KeyboardMouseCallback+keyboard state (Char c) Down _ _ = case toLower c of+   'b'   -> do bgToggle state $~ not; postRedisplay Nothing+   '\27' -> exitWith ExitSuccess+   _     -> return ()+keyboard _ _ _ _ _ = return ()++-- Main Loop: Open window with initial window size, title bar, RGBA display+-- mode, and handle input events.+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ DoubleBuffered, RGBMode, Multisampling ]+   initialWindowSize $= Size 600 300+   createWindow progName+   state <- makeState+   displayLists <- myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboard state)+   displayCallback $= display state displayLists+   mainLoop
+ examples/RedBook/PickDepth.hs view
@@ -0,0 +1,126 @@+{-+   PickDepth.hs (adapted from pickdepth.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   Picking is demonstrated in this program. In rendering mode, three+   overlapping rectangles are drawn. When the left mouse button is pressed,+   selection mode is entered with the picking matrix. Rectangles which are drawn+   under the cursor position are "picked." Pay special attention to the depth+   value range, which is returned.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   depthFunc $= Just Less+   shadeModel $= Flat+   depthRange $= (0, 1)   -- The default z mapping++-- The nine squares are drawn. Each square is given two names: one for the row+-- and the other for the column on the grid. The color of each square is+-- determined by its position on the grid, and the value in the board array.+-- Note: In contrast to the the original example, we always give names to+-- squares, regardless of the render mode. This simplifies the code a bit and+-- is even suggested by the Red Book.++-- The three rectangles are drawn, each with a different name. Note that each+-- rectangle is drawn with a different z value. Note: In contrast to the the+-- original example, we always give names to squares, regardless of the render+-- mode. This simplifies the code a bit and is even suggested by the Red Book.+drawRects :: IO ()+drawRects = do+   -- resolve overloading, not needed in "real" programs+   let color3  = color :: Color3 GLfloat -> IO ()+       vertex3 = vertex :: Vertex3 GLint -> IO ()+   loadName (Name 1)+   renderPrimitive Quads $ do+      color3 (Color3 1.0 1.0 0.0)+      vertex3 (Vertex3 2 0 0)+      vertex3 (Vertex3 2 6 0)+      vertex3 (Vertex3 6 6 0)+      vertex3 (Vertex3 6 0 0)+   loadName (Name 2)+   renderPrimitive Quads $ do+      color3 (Color3 0.0 1.0 1.0)+      vertex3 (Vertex3 3 2 (-1))+      vertex3 (Vertex3 3 8 (-1))+      vertex3 (Vertex3 8 8 (-1))+      vertex3 (Vertex3 8 2 (-1))+   loadName (Name 3)+   renderPrimitive Quads $ do+      color3 (Color3 1.0 0.0 1.0)+      vertex3 (Vertex3 0 2 (-2))+      vertex3 (Vertex3 0 7 (-2))+      vertex3 (Vertex3 5 7 (-2))+      vertex3 (Vertex3 5 2 (-2))++-- processHits prints the hit records.+processHits :: Maybe[HitRecord] -> IO ()+processHits Nothing = putStrLn "selection buffer overflow"+processHits (Just hitRecords) = do+   putStrLn ("hits = " ++ show (length hitRecords))+   flip mapM_ hitRecords $ \(HitRecord z1 z2 names) -> do+      putStrLn (" number of names for hit = " ++ show (length names))+      putStr   ("  z1 is " ++ show z1)+      putStrLn ("; z2 is " ++ show z2)+      putStr   "   the name is"+      sequence_ [ putStr (" " ++ show n) | Name n <- names ]+      putChar '\n'++-- pickRects() sets up selection mode, name stack, and projection matrix for+-- picking. Then the objects are drawn.++bufSize :: GLsizei+bufSize = 512++pickRects :: KeyboardMouseCallback+pickRects (MouseButton LeftButton) Down _ (Position x y) = do+   vp@(_, (Size _ height)) <- get viewport+   (_, maybeHitRecords) <- getHitRecords bufSize $+      withName (Name 0) $ do+         matrixMode $= Projection+         preservingMatrix $ do+            loadIdentity+            -- create 5x5 pixel picking region near cursor location+            pickMatrix (fromIntegral x, fromIntegral height - fromIntegral y) (5, 5) vp+            ortho 0 8 0 8 (-0.5) 2.5+            drawRects+         flush+   processHits maybeHitRecords+   postRedisplay Nothing+pickRects (Char '\27') Down _ _ = exitWith ExitSuccess+pickRects _            _    _ _ = return ()++display :: DisplayCallback+display = do+   clear [ ColorBuffer, DepthBuffer ]+   drawRects+   flush++reshape :: ReshapeCallback+reshape size = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho 0 8 0 8 (-0.5) 2.5+   matrixMode $= Modelview 0+   loadIdentity++-- Main Loop+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 200 200+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   reshapeCallback $= Just reshape+   displayCallback $= display+   keyboardMouseCallback $= Just pickRects+   mainLoop
+ examples/RedBook/PickSquare.hs view
@@ -0,0 +1,119 @@+{-+   PickSquare.hs (adapted from picksquare.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   Use of multiple names and picking are demonstrated. A 3x3 grid of squares is+   drawn. When the left mouse button is pressed, all squares under the cursor+   position have their color changed.+-}++import Data.Array ( Array, listArray, (!) )+import Data.IORef ( IORef, newIORef )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++type Board = Array (GLint,GLint) (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))+            rect (Vertex2 i j) (Vertex2 (i + 1) (j + 1))++-- processHits prints the hit records and updates the board array.+processHits :: Maybe[HitRecord] -> State -> IO ()+processHits Nothing _ = putStrLn "selection buffer overflow"+processHits (Just hitRecords) state = do+   putStrLn ("hits = " ++ show (length hitRecords))+   mapM_ (\(HitRecord z1 z2 names) -> do+      putStrLn (" number of names for this hit = " ++ show (length names))+      putStr   ("  z1 is " ++ show z1)+      putStrLn ("; z2 is " ++ show z2)+      putStr   "   names are"+      sequence_ [ putStr (" " ++ show n) | Name n <- names ]+      putChar '\n'+      let [i, j] = [ fromIntegral n | Name n <- names ]+      (board state ! (i,j)) $~ (\x -> (x + 1) `mod` 3))+      hitRecords++-- pickSquares sets up selection mode, name stack, and projection matrix for+-- picking. Then the objects are drawn.++bufSize :: GLsizei+bufSize = 512++pickSquares :: State -> KeyboardMouseCallback+pickSquares state (MouseButton LeftButton) Down _ (Position x y) = do+   vp@(_, (Size _ height)) <- get viewport+   (_, maybeHitRecords) <- getHitRecords bufSize $+      withName (Name 0) $ do+         matrixMode $= Projection+         preservingMatrix $ do+            loadIdentity+            -- create 5x5 pixel picking region near cursor location+            pickMatrix (fromIntegral x, fromIntegral height - fromIntegral y) (5, 5) vp+            ortho2D 0 3 0 3+            drawSquares state+         flush+   processHits maybeHitRecords state+   postRedisplay Nothing+pickSquares _ (Char '\27') Down _ _ = exitWith ExitSuccess+pickSquares _ _            _    _ _ = return ()++display :: State -> DisplayCallback+display state = do+   clear [ ColorBuffer ]+   drawSquares state+   flush++reshape :: ReshapeCallback+reshape size = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho2D 0 3 0 3+   matrixMode $= Modelview 0+   loadIdentity++-- Main Loop+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 100 100+   initialWindowPosition $= Position 100 100+   createWindow progName+   state <- makeState+   myInit+   reshapeCallback $= Just reshape+   displayCallback $= display state+   keyboardMouseCallback $= Just (pickSquares state)+   mainLoop
+ examples/RedBook/Planet.hs view
@@ -0,0 +1,83 @@+{-+   Planet.hs (adapted from planet.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program shows how to composite modeling transformations to draw+   translated and rotated models. Interaction: pressing the d and y keys+   (day and year) alters the rotation of the planet around the sun.+-}++import Data.IORef ( IORef, newIORef )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++data State = State { year, day :: IORef GLint }++makeState :: IO State+makeState = do+   y <- newIORef 0+   d <- newIORef 0+   return $ State { year = y, day = d }++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Flat++display :: State -> DisplayCallback+display state = do+   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+       translatef = translate :: Vector3 GLfloat -> IO ()+   color3f (Color3 1 1 1)++   preservingMatrix $ do+      renderObject Wireframe (Sphere' 1 20 16)   -- draw sun+      y <- get (year state)+      rotate (fromIntegral y :: GLfloat) (Vector3 0 1 0)+      translatef (Vector3 2 0 0)+      d <- get (day state)+      rotate (fromIntegral d :: GLfloat) (Vector3 0 1 0)+      renderObject Wireframe (Sphere' 0.2 10 8)  -- draw smaller planet++   swapBuffers++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective 60 (fromIntegral w / fromIntegral h) 1 20+   matrixMode $= Modelview 0+   loadIdentity+   lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0)++keyboard :: State -> KeyboardMouseCallback+keyboard state (Char c) Down _ _ = case c of+   'd'   -> update day    10+   'D'   -> update day  (-10)+   'y'   -> update year   10+   'Y'   -> update year (-10)+   '\27' -> exitWith ExitSuccess+   _     -> return ()+   where update angle inc = do+            angle state $~ ((`mod` 360) . (+ inc))+            postRedisplay Nothing+keyboard _ _ _ _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ DoubleBuffered, RGBMode ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   state <- makeState+   myInit+   displayCallback $= display state+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboard state)+   mainLoop
+ examples/RedBook/PointP.hs view
@@ -0,0 +1,145 @@+{-+   PointP.hs (adapted from pointp.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates point parameters and their effect on point+   primitives. 250 points are randomly generated within a 10 by 10 by 40 region,+   centered at the origin. In some modes (including the default), points that+   are closer to the viewer will appear larger.++   Pressing the 'c', 'l', and 'q' keys switch the point parameters attenuation+   mode to constant, linear, or quadratic, respectively.++   Pressing the 'f' and 'b' keys move the viewer forward and backwards. In+   either linear or quadratic attenuation mode, the distance from the viewer to+   the point will change the size of the point primitive.++   Pressing the '+' and '-' keys will change the current point size. In this+   program, the point size is bounded, so it will not get less than 2, nor+   greater than the maximum returned by pointSizeRange.+-}++import Control.Monad ( when, unless )+import Data.IORef ( IORef, newIORef )+import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure )+import System.Random ( randomRIO )+import Graphics.UI.GLUT++type Attenuation = (GLfloat,GLfloat,GLfloat)++constant, linear, quadratic :: Attenuation+constant  = (1, 0,    0   )+linear    = (0, 0.12, 0   )+quadratic = (0, 0,    0.01)++data State = State { distance :: IORef GLfloat }++makeState :: IO State+makeState = do+   d <- newIORef (-10)+   return $ State { distance = d }++randomColor :: IO (Color3 GLfloat)+randomColor = do+   g <- randomRIO (0.5, 1)+   b <- randomRIO (0, 1)+   return $ Color3 1 g b++randomVertex :: IO (Vertex3 GLfloat)+randomVertex = do+   x <- randomRIO (-5, 5)+   y <- randomRIO (-5, 5)+   z <- randomRIO (-5, -45)+   return $ Vertex3 x y z++myInit :: IO DisplayList+myInit = do+   pointList <- defineNewList Compile $+      renderPrimitive Points $+         sequence_ $ replicate 250 $ do+            color =<< randomColor+            vertex =<< randomVertex++   depthFunc $= Just Less+   pointSmooth $= Enabled+   blend $= Enabled+   blendFunc $= (SrcAlpha, OneMinusSrcAlpha)+   pointSize $= 7++   pointDistanceAttenuation $= linear+   pointFadeThresholdSize $= 2++   return pointList++display :: State -> DisplayList -> DisplayCallback+display state pointList = do+   clear [ ColorBuffer, DepthBuffer ]+   d <- get (distance state)+   loadIdentity+   translate (Vector3 0 0 d)+   callList pointList+   swapBuffers++reshape :: ReshapeCallback+reshape size = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective  35 1 0.25 200+   matrixMode $= Modelview 0++setPointDistanceAttenuation :: Attenuation -> IO ()+setPointDistanceAttenuation att = do+   pointDistanceAttenuation $= att+   postRedisplay Nothing++incDistance :: State -> GLfloat -> IO ()+incDistance state inc = do+   distance state $~ (+ inc)+   postRedisplay Nothing++incPointSize :: GLfloat -> IO ()+incPointSize inc = do+   newPointSize <- fmap (+ inc) $ get pointSize+   (_,maxPointSize) <- get pointSizeRange+   when (2 <= newPointSize && newPointSize <= maxPointSize) $ do+      pointSize $= newPointSize+      postRedisplay Nothing++keyboard :: State -> KeyboardMouseCallback+keyboard state (Char c) Down _ _ = case c of+   'c'   -> setPointDistanceAttenuation constant+   'l'   -> setPointDistanceAttenuation linear+   'q'   -> setPointDistanceAttenuation quadratic+   'b'   -> incDistance state (-0.5)+   'f'   -> incDistance state 0.5+   '+'   -> incPointSize 1+   '-'   -> incPointSize (-1)+   '\27' -> exitWith ExitSuccess+   _     -> return ()+keyboard _ _ _ _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ RGBMode, DoubleBuffered, WithDepthBuffer, Multisampling ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName++   -- We have to do this *after* createWindow, otherwise we have no OpenGL+   -- context. Note that the original C example simply tests for OpenGL 1.4 at+   -- compile time, we do a runtime check for the needed extension.+   extensions <- get glExtensions+   unless ("GL_ARB_point_parameters" `elem` extensions) $ do+      putStrLn "Sorry, this demo requires the GL_ARB_point_parameters extension."+      exitFailure++   state <- makeState+   pointList <- myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboard state)+   displayCallback $= display state pointList+   mainLoop
+ examples/RedBook/PolyOff.hs view
@@ -0,0 +1,151 @@+{-+   PolyOff.hs (adapted from polyoff.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates polygon offset to draw a shaded polygon and its+   wireframe counterpart without ugly visual artifacts ("stitching").+-}++import Control.Monad ( when )+import Data.IORef ( IORef, newIORef )+import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure )+import Graphics.UI.GLUT++data State = State {+   spinX, spinY :: IORef GLfloat,+   tDist :: IORef GLfloat,+   polyFactor :: IORef GLfloat,+   polyUnits :: IORef GLfloat+ }++makeState :: IO State+makeState = do+   x <- newIORef 0+   y <- newIORef 0+   t <- newIORef 0+   f <- newIORef 1+   u <- newIORef 1+   return $ State { spinX = x, spinY = y, tDist = t, polyFactor = f, polyUnits = u }++-- display draws two spheres, one with a gray, diffuse material, the other+-- sphere with a magenta material with a specular highlight.+display :: State -> DisplayList -> DisplayCallback+display state sphereList = do+   clear [ ColorBuffer, DepthBuffer ]+   preservingMatrix $ do+      t <- get (tDist state)+      translate (Vector3 0 0 t)+      x <- get (spinX state)+      rotate x (Vector3 1 0 0)+      y <- get (spinY state)+      rotate y (Vector3 0 1 0)++      materialAmbientAndDiffuse Front $= Color4 0.8 0.8 0.8 1+      materialSpecular Front $= Color4 0 0 0 1+      materialShininess Front $= 0+      lighting $= Enabled+      light (Light 0) $= Enabled+      polygonOffsetFill $= Enabled+      f <- get (polyFactor state)+      u <- get (polyUnits state)+      polygonOffset $= (f, u)+      callList sphereList+      polygonOffsetFill $= Disabled++      lighting $= Disabled+      light (Light 0) $= Disabled+      color (Color3 1 1 (1 :: GLfloat))+      polygonMode $= (Line, Line)+      callList sphereList+      polygonMode $= (Fill, Fill)++   flush++-- specify initial properties+-- create display list with sphere+-- initialize lighting and depth buffer+gfxinit :: IO DisplayList+gfxinit = do+   clearColor $= Color4 0 0 0 1++   sphereList <- defineNewList Compile $+      renderObject Solid (Sphere' 1 20 12)++   depthFunc $= Just Less++   ambient (Light 0) $= Color4 0 0 0 1+   diffuse (Light 0) $= Color4 1 1 1 1+   specular (Light 0) $= Color4 1 1 1 1+   position (Light 0) $= Vertex4 1 1 1 0+   lightModelAmbient $= Color4 0.2 0.2 0.2 1++   return sphereList++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective 45 (fromIntegral w / fromIntegral h) 1 10+   matrixMode $= Modelview 0+   loadIdentity+   lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0)++incSpin :: IORef GLfloat -> IO ()+incSpin spinRef = do+   let wrap n s = if s > n then s - n else s+   spinRef $~ (wrap 360 . (+ 5))+   postRedisplay Nothing++incDist :: State -> GLfloat -> IO ()+incDist state inc = do+   newDist <- fmap (+ inc) $ get (tDist state)+   when (-5 <= newDist && newDist <= 4) $ do+      tDist state $= newDist+      postRedisplay Nothing++incPoly :: String -> IORef GLfloat -> GLfloat -> IO ()+incPoly name polyRef inc = do+   polyRef $~ (+ inc)+   p <- get polyRef+   putStrLn (name ++ " is " ++ show p)+   postRedisplay Nothing++keyboardMouse :: State -> KeyboardMouseCallback+keyboardMouse state k Down _ _ = case k of+   (MouseButton LeftButton)   -> incSpin (spinX state)+   (MouseButton MiddleButton) -> incSpin (spinY state)+   (MouseButton RightButton)  -> exitWith ExitSuccess+   (Char 't')                 -> incDist state 0.5+   (Char 'T')                 -> incDist state (-0.5)+   (Char 'F')                 -> incPoly "polyFactor" (polyFactor state) 0.1+   (Char 'f')                 -> incPoly "polyFactor" (polyFactor state) (-0.1)+   (Char 'U')                 -> incPoly "polyUnits"  (polyUnits  state) 1+   (Char 'u')                 -> incPoly "polyUnits"  (polyUnits  state) (-1)+   _                          -> return ()+keyboardMouse _ _ _ _ _ = return ()++-- Main Loop: Open window with initial window size, title bar, RGBA display+-- mode, and handle input events.+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   createWindow progName++   -- we have to do this *after* createWindow, otherwise we have no OpenGL context+   version <- get (majorMinor glVersion)+   when (version == (1,0)) $ do+      putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0."+      putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions,"+      putStrLn "you may be able to modify this program to make it run."+      exitFailure++   state <- makeState+   sphereList <- gfxinit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboardMouse state)+   displayCallback $= display state sphereList+   mainLoop
+ examples/RedBook/Polys.hs view
@@ -0,0 +1,84 @@+{-+   Polys.hs (adapted from polys.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates polygon stippling.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++fly :: IO GLpolygonstipple+fly = newPolygonStipple [+   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,+   0x03, 0x80, 0x01, 0xC0, 0x06, 0xC0, 0x03, 0x60,+   0x04, 0x60, 0x06, 0x20, 0x04, 0x30, 0x0C, 0x20,+   0x04, 0x18, 0x18, 0x20, 0x04, 0x0C, 0x30, 0x20,+   0x04, 0x06, 0x60, 0x20, 0x44, 0x03, 0xC0, 0x22,+   0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22,+   0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22,+   0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22,+   0x66, 0x01, 0x80, 0x66, 0x33, 0x01, 0x80, 0xCC,+   0x19, 0x81, 0x81, 0x98, 0x0C, 0xC1, 0x83, 0x30,+   0x07, 0xe1, 0x87, 0xe0, 0x03, 0x3f, 0xfc, 0xc0,+   0x03, 0x31, 0x8c, 0xc0, 0x03, 0x33, 0xcc, 0xc0,+   0x06, 0x64, 0x26, 0x60, 0x0c, 0xcc, 0x33, 0x30,+   0x18, 0xcc, 0x33, 0x18, 0x10, 0xc4, 0x23, 0x08,+   0x10, 0x63, 0xC6, 0x08, 0x10, 0x30, 0x0c, 0x08,+   0x10, 0x18, 0x18, 0x08, 0x10, 0x00, 0x00, 0x08]++halftone :: IO GLpolygonstipple+halftone = newPolygonStipple . take 128 . cycle $ [+   0xAA, 0xAA, 0xAA, 0xAA, 0x55, 0x55, 0x55, 0x55]++display :: (GLpolygonstipple, GLpolygonstipple) -> DisplayCallback+display (flyStipple, halftoneStipple) = do+   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+       rectf = rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO ()+   color3f (Color3 1 1 1)++   -- draw one solid, unstippled rectangle,+   -- then two stippled rectangles+   rectf (Vertex2  25 25) (Vertex2 125 125)+   polygonStipple $= Just flyStipple+   rectf (Vertex2 125 25) (Vertex2 225 125)+   polygonStipple $= Just halftoneStipple+   rectf (Vertex2 225 25) (Vertex2 325 125)+   polygonStipple $= (Nothing :: Maybe GLpolygonstipple)++   flush++myInit :: IO (GLpolygonstipple, GLpolygonstipple)+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Flat+   flyStipple <- fly+   halftoneStipple <- halftone+   return (flyStipple, halftoneStipple)++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho2D 0.0 (fromIntegral w) 0.0 (fromIntegral h)++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 350 150+   createWindow progName+   stipples <- myInit+   displayCallback $= display stipples+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/Quadric.hs view
@@ -0,0 +1,106 @@+{-+   Quadric.hs (adapted from quadric.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates the use of the renderQuadric routine. Quadric+   objects are created with some quadric properties and errors are reported.+   Note that the cylinder has no top or bottom and the circle has a hole in it.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++myInit :: IO (DisplayList, DisplayList, DisplayList, DisplayList)+myInit = do+   clearColor $= Color4 0 0 0 0++   materialAmbient Front $= Color4 0.5 0.5 0.5 1+   materialSpecular Front $= Color4 1 1 1 1+   materialShininess Front $= 50+   position (Light 0) $= Vertex4 1 1 1 0+   lightModelAmbient $= Color4 0.5 0.5 0.5 1++   lighting $= Enabled+   light (Light 0) $= Enabled+   depthFunc $= Just Less++   -- Create 4 display lists, each with a different quadric object.+   -- Different drawing styles and surface normal specifications+   -- are demonstrated.+   -- smooth shaded+   dl1 <- newQuadricDL (Just Smooth) FillStyle (Sphere 0.75 15 10)+   -- flat shaded+   dl2 <- newQuadricDL (Just Flat) FillStyle (Cylinder 0.5 0.3 1 15 5)+   -- all polygons wireframe+   dl3 <- newQuadricDL Nothing LineStyle (Disk 0.25 1 20 4)+   -- boundary only+   dl4 <- newQuadricDL Nothing SilhouetteStyle (PartialDisk 0 1 20 4 0 225)+   return (dl1, dl2, dl3, dl4)++newQuadricDL :: QuadricNormal -> QuadricDrawStyle -> QuadricPrimitive -> IO DisplayList+newQuadricDL n s p =+   defineNewList Compile $ do+      renderQuadric (QuadricStyle n NoTextureCoordinates Outside s) p+      reportErrors++display :: (DisplayList, DisplayList, DisplayList, DisplayList) -> DisplayCallback+display (dl1, dl2, dl3, dl4) = do+   clear [ ColorBuffer, DepthBuffer ]+   preservingMatrix $ do+      -- resolve overloading, not needed in "real" programs+      let translatef = translate :: Vector3 GLfloat -> IO ()+          rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO ()+          color3f = color :: Color3 GLfloat -> IO ()++      lighting $= Enabled+      shadeModel $= Smooth+      translatef (Vector3 (-1) (-1) 0)+      callList dl1++      shadeModel $= Flat+      translatef (Vector3 0 2 0)+      preservingMatrix $ do+         rotatef 300 (Vector3 1 0 0)+         callList dl2++      lighting $= Disabled+      color3f (Color3 0 1 1)+      translatef (Vector3 2 (-2) 0)+      callList dl3++      color3f (Color3 1 1 0)+      translatef (Vector3 0 2 0)+      callList dl4++   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10) 10+      else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10) 10+   matrixMode $= Modelview 0++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   displayLists <- myInit+   displayCallback $= display displayLists+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/ReadImage.hs view
@@ -0,0 +1,65 @@+{-+   ReadImage.hs (adapted from readImage.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   Support for reading a file of raw RGB data:+      4 bytes big-endian width+      4 bytes big-endian height+      width * height RGB byte triples+-}++module ReadImage ( readImage ) where++import Data.Word ( Word8, Word32 )+import Control.Exception ( bracket )+import Control.Monad ( when )+import System.IO ( Handle, IOMode(ReadMode), openBinaryFile, hGetBuf, hClose )+import System.IO.Error ( mkIOError, eofErrorType )+import Foreign ( Ptr, alloca, mallocBytes, Storable(..) )+import Graphics.UI.GLUT++-- This is probably overkill, but anyway...+newtype Word32BigEndian = Word32BigEndian Word32++word32BigEndianToGLsizei :: Word32BigEndian -> GLsizei+word32BigEndianToGLsizei (Word32BigEndian x) = fromIntegral x++instance Storable Word32BigEndian where+   sizeOf ~(Word32BigEndian x) = sizeOf x+   alignment ~(Word32BigEndian x) = alignment x+   peek ptr = do+      let numBytes = sizeOf (undefined :: Word32BigEndian)+      bytes <- mapM (peekByteOff ptr) [ 0 ..  numBytes - 1 ] :: IO [Word8]+      let value = foldl (\val byte -> val * 256 + fromIntegral byte) 0 bytes+      return $ Word32BigEndian value+   poke = error ""++-- This is the reason for all this stuff above...+readGLsizei :: Handle -> IO GLsizei+readGLsizei handle =+   alloca $ \buf -> do+      hGetBufFully handle buf (sizeOf (undefined :: Word32BigEndian))+      fmap word32BigEndianToGLsizei $ peek buf++-- A handy variant of hGetBuf with additional error checking+hGetBufFully :: Handle -> Ptr a -> Int -> IO ()+hGetBufFully handle ptr numBytes = do+   bytesRead <- hGetBuf handle ptr numBytes+   when (bytesRead /= numBytes) $+      ioError $ mkIOError eofErrorType "hGetBufFully" (Just handle) Nothing++-- Closing a file is nice, even when an error occurs during reading.+withBinaryFile :: FilePath -> (Handle -> IO a) -> IO a+withBinaryFile filePath = bracket (openBinaryFile filePath ReadMode) hClose++readImage :: FilePath -> IO (Size, PixelData a)+readImage filePath =+   withBinaryFile filePath $ \handle -> do+      width <- readGLsizei handle+      height <- readGLsizei handle+      let numBytes = fromIntegral (3 * width * height)+      buf <- mallocBytes numBytes+      hGetBufFully handle buf numBytes+      return (Size width height, PixelData RGB UnsignedByte buf)
+ examples/RedBook/Robot.hs view
@@ -0,0 +1,89 @@+{-+   Robot.hs (adapted from robot.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++  This program shows how to composite modeling transformations to draw+  translated and rotated hierarchical models. Interaction: pressing the s+  and e keys (shoulder and elbow) alters the rotation of the robot arm.+-}++import Data.IORef ( IORef, newIORef )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++data State = State { shoulder, elbow :: IORef GLint }++makeState :: IO State+makeState = do+   s <- newIORef 0+   e <- newIORef 0+   return $ State { shoulder = s, elbow = e }++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Flat++display :: State -> DisplayCallback+display state = do+   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let translatef = translate :: Vector3 GLfloat -> IO ()+       scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO ()+   preservingMatrix $ do+      translatef (Vector3 (-1) 0 0)+      s <- get (shoulder state)+      rotate (fromIntegral s :: GLfloat) (Vector3 0 0 1)+      translatef (Vector3 1 0 0)+      preservingMatrix $ do+         scalef 2 0.4 1+         renderObject Wireframe (Cube 1)+      translatef (Vector3 1 0 0)+      e <- get (elbow state)+      rotate (fromIntegral e :: GLfloat) (Vector3 0 0 1)+      translatef (Vector3 1 0 0)+      preservingMatrix $ do+         scalef 2 0.4 1+         renderObject Wireframe (Cube 1)+   swapBuffers++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective 65 (fromIntegral w / fromIntegral h) 1 20+   matrixMode $= Modelview 0+   loadIdentity+   -- resolve overloading, not needed in "real" programs+   let translatef = translate :: Vector3 GLfloat -> IO ()+   translatef (Vector3 0 0 (-5))++keyboard :: State -> KeyboardMouseCallback+keyboard state (Char c) Down _ _ = case c of+   's'   -> update shoulder   5+   'S'   -> update shoulder (-5)+   'e'   -> update elbow      5+   'E'   -> update elbow    (-5)+   '\27' -> exitWith ExitSuccess+   _     -> return ()+   where update joint inc = do+            joint state $~ ((`mod` 360) . (+ inc))+            postRedisplay Nothing+keyboard _ _ _ _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ DoubleBuffered, RGBMode ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   state <- makeState+   myInit+   displayCallback $= display state+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboard state)+   mainLoop
+ examples/RedBook/Scene.hs view
@@ -0,0 +1,73 @@+{-+   Scene.hs (adapted from scene.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates the use of the GL lighting model. Objects are+   drawn using a grey material characteristic. A single light source+   illuminates the objects.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++-- Initialize material property and light source.+myInit :: IO ()+myInit = do+   ambient (Light 0) $= Color4 0 0 0 1+   diffuse (Light 0) $= Color4 1 1 1 1+   specular (Light 0) $= Color4 1 1 1 1+   -- light position is NOT default value+   position (Light 0) $= Vertex4  1 1 1 0++   lighting $= Enabled+   light (Light 0) $= Enabled+   depthFunc $= Just Less++display :: DisplayCallback+display = do+   clear [ ColorBuffer, DepthBuffer ]+   preservingMatrix $ do+      rotate (20 :: GLfloat) (Vector3 1 0 0)+      preservingMatrix $ do+         translate (Vector3 (-0.75) 0.5 (0 :: GLfloat))+         rotate (90 :: GLfloat) (Vector3 1 0 0)+         renderObject Solid (Torus 0.275 0.85 15 15)+      preservingMatrix $ do+         translate (Vector3 (-0.75) (-0.5) (0 :: GLfloat))+         rotate (270 :: GLfloat) (Vector3 1 0 0)+         renderObject Solid (Cone 1 2 15 15)+      preservingMatrix $ do+         translate (Vector3 0.75 0 (-1 :: GLfloat))+         renderObject Solid (Sphere' 1 15 15)+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho (-2.5) 2.5 (-2.5 * hf/wf) (2.5 * hf/wf) (-10) 10+      else ortho (-2.5 * wf/hf) (2.5 * wf/hf) (-2.5) 2.5 (-10) 10+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 500 500+   createWindow progName+   myInit+   reshapeCallback $= Just reshape+   displayCallback $= display+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/Select.hs view
@@ -0,0 +1,150 @@+{-+   Select.hs (adapted from select.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This is an illustration of the selection mode and name stack, which detects+   whether objects which collide with a viewing volume. First, four triangles+   and a rectangular box representing a viewing volume are drawn (drawScene+   routine). The green triangle and yellow triangles appear to lie within the+   viewing volume, but the red triangle appears to lie outside it. Then the+   selection mode is entered (selectObjects routine). Drawing to the screen+   ceases. To see if any collisions occur, the four triangles are called. In+   this example, the green triangle causes one hit with the name 1, and the+   yellow triangles cause one hit with the name 3.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++-- draw a triangle with vertices at (x1, y1), (x2, y2) and (x3, y3) at z units+-- away from the origin.+drawTriangle ::+   Vertex2 GLfloat -> Vertex2 GLfloat -> Vertex2 GLfloat -> GLfloat -> IO ()+drawTriangle (Vertex2 x1 y1) (Vertex2 x2 y2) (Vertex2 x3 y3) z = do+   renderPrimitive Triangles $ mapM_ vertex [+      Vertex3 x1 y1 z,+      Vertex3 x2 y2 z,+      Vertex3 x3 y3 z]++-- draw a rectangular box with these outer x, y, and z values+drawViewVolume :: Vertex3 GLfloat -> Vertex3 GLfloat -> IO ()+drawViewVolume (Vertex3 x1 y1 z1) (Vertex3 x2 y2 z2) = do+   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+   color3f (Color3 1 1 1)+   renderPrimitive LineLoop $ mapM_ vertex [+      Vertex3 x1 y1 (-z1),+      Vertex3 x2 y1 (-z1),+      Vertex3 x2 y2 (-z1),+      Vertex3 x1 y2 (-z1)]++   renderPrimitive LineLoop $ mapM_ vertex [+      Vertex3 x1 y1 (-z2),+      Vertex3 x2 y1 (-z2),+      Vertex3 x2 y2 (-z2),+      Vertex3 x1 y2 (-z2)]++   renderPrimitive Lines $ mapM_ vertex [   -- 4 lines+      Vertex3 x1 y1 (-z1),+      Vertex3 x1 y1 (-z2),+      Vertex3 x1 y2 (-z1),+      Vertex3 x1 y2 (-z2),+      Vertex3 x2 y1 (-z1),+      Vertex3 x2 y1 (-z2),+      Vertex3 x2 y2 (-z1),+      Vertex3 x2 y2 (-z2)]++-- drawScene draws 4 triangles and a wire frame which represents the viewing+-- volume.+drawScene :: IO ()+drawScene = do+   matrixMode $= Projection+   loadIdentity+   perspective 40 (4/3) 1 100++   matrixMode $= Modelview 0+   loadIdentity+   lookAt (Vertex3 7.5 7.5 12.5) (Vertex3 2.5 2.5 (-5)) (Vector3 0 1 0)+   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+   color3f (Color3 0 1 0)   -- green triangle+   drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-5)+   color3f (Color3 1 0 0)   -- red triangle+   drawTriangle (Vertex2 2 7) (Vertex2 3 7) (Vertex2 2.5 8) (-5)+   color3f (Color3 1 1 0)   -- yellow triangles+   drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-1)+   drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-9)+   drawViewVolume (Vertex3 0 0 0) (Vertex3 5 5 10)++processHits :: Maybe [HitRecord] -> IO ()+processHits Nothing = putStrLn "selection buffer overflow"+processHits (Just hitRecords) = do+   putStrLn ("hits = " ++ show (length hitRecords))+   mapM_ (\(HitRecord z1 z2 names) -> do+      putStrLn (" number of names for hit = " ++ show (length names))+      putStr   ("  z1 is " ++ show z1)+      putStrLn ("; z2 is " ++ show z2)+      putStr   "   the name is"+      sequence_ [ putStr (" " ++ show n) | Name n <- names ]+      putChar '\n')+      hitRecords++-- selectObjects "draws" the triangles in selection mode, assigning names for+-- the triangles. Note that the third and fourth triangles share one name, so+-- that if either or both triangles intersects the viewing/clipping volume,+-- only one hit will be registered.++bufSize :: GLsizei+bufSize = 512++selectObjects :: IO ()+selectObjects = do+   (_, maybeHitRecords) <- getHitRecords bufSize $ do+      withName (Name 0) $ do+         preservingMatrix $ do+            matrixMode $= Projection+            loadIdentity+            ortho 0 5 0 5 0 10+            matrixMode $= Modelview 0+            loadIdentity+            loadName (Name 1)+            drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-5)+            loadName (Name 2)+            drawTriangle (Vertex2 2 7) (Vertex2 3 7) (Vertex2 2.5 8) (-5)+            loadName (Name 3)+            drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-1)+            drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-9)+      flush+   processHits maybeHitRecords++myInit :: IO ()+myInit = do+   depthFunc $= Just Less+   shadeModel $= Flat++display :: DisplayCallback+display = do+   clearColor $= Color4 0 0 0 0+   clear [ ColorBuffer, DepthBuffer ]+   drawScene+   selectObjects+   flush++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++-- Main Loop+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 200 200+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   displayCallback $= display+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/ShadowMap.hs view
@@ -0,0 +1,255 @@+{-+   ShadowMap.hs (adapted from shadowmap.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE+-}++import Control.Monad ( when, unless )+import Data.IORef ( IORef, newIORef )+import Foreign.Marshal.Array ( allocaArray )+import Foreign.Ptr ( nullPtr )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++shadowMapSize :: TextureSize2D+shadowMapSize = TextureSize2D 256 256++fovy, nearPlane, farPlane :: GLdouble+fovy      =  60+nearPlane =  10+farPlane  = 100++lightPos :: Vertex4 GLfloat+lightPos = Vertex4 25 25 25 1++lookat :: Vertex3 GLdouble+lookat   = Vertex3 0 0 0++up :: Vector3 GLdouble+up = Vector3 0 0 1++data State = State {+   angle      :: IORef GLdouble,+   torusAngle :: IORef GLfloat,+   showShadow :: IORef Bool,+   animate    :: IORef Bool,+   funcMode   :: IORef ComparisonFunction }++makeState :: IO State+makeState = do+   a <- newIORef 0+   t <- newIORef 0+   s <- newIORef False+   n <- newIORef True+   f <- newIORef Lequal+   return $ State { angle = a, torusAngle = t, showShadow = s,+                    animate = n, funcMode = f }++myInit :: IO ()+myInit = do+   texImage2D Nothing NoProxy 0 DepthComponent' shadowMapSize 0+              (PixelData DepthComponent UnsignedByte nullPtr)++   position (Light 0) $= lightPos+   let white = Color4 1 1 1 1+   specular (Light 0) $= white+   diffuse  (Light 0) $= white++   textureWrapMode Texture2D S $= (Repeated, ClampToEdge)+   textureWrapMode Texture2D T $= (Repeated, ClampToEdge)+   textureFilter Texture2D $= ((Linear', Nothing), Linear')+   textureCompareMode Texture2D $= Just Lequal+   depthTextureMode Texture2D $= Luminance'++   colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse)++   cullFace $= Just Back++   depthFunc $= Just Less+   light (Light 0) $= Enabled+   lighting $= Enabled+   texture Texture2D $= Enabled++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective fovy (fromIntegral w / fromIntegral h) nearPlane farPlane+   matrixMode $= Modelview 0++idle :: State -> IdleCallback+idle state = do+   angle state $~! (+ (pi / 10000))+   torusAngle state $~! (+ 0.1)+   postRedisplay Nothing++keyboard :: State -> KeyboardMouseCallback+keyboard state (Char c) Down _ _ = do+   case c of+      '\27' -> exitWith ExitSuccess+      't' ->+         texture Texture2D $~ \cap -> if cap == Enabled then Disabled else Enabled+      'm' -> do+         fm <- get (funcMode state)+         textureCompareMode Texture2D $~ maybe (Just fm) (const Nothing)+         compareMode <- get (textureCompareMode Texture2D)+         putStrLn ("Compare mode " ++ maybe "Off" (const "On") compareMode)+      'f' -> do+         funcMode state $~ \fm -> if fm == Lequal then Gequal else Lequal+         fm <- get (funcMode state)+         putStrLn ("Operator " ++ show fm)+         textureCompareMode Texture2D $~ maybe Nothing (const (Just fm))+      's' -> showShadow state $~ not+      'p' -> do+         animate state $~ not+         animate' <- get (animate state)+         idleCallback $= if animate' then Just (idle state) else Nothing+      _ -> return ()+   postRedisplay Nothing+keyboard _ _ _ _ _ = return ()++drawObjects :: GLfloat -> Bool -> IO ()+drawObjects torusAngle' shadowRender = do+   textureOn <- get (texture Texture2D)++   when shadowRender $+      texture Texture2D $= Disabled++   -- resolve overloading, not needed in "real" programs+   let normal3f = normal :: Normal3 GLfloat -> IO ()+       color3f = color :: Color3 GLfloat -> IO ()+       rectf = rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO ()+       translatef = translate :: Vector3 GLfloat -> IO ()+       rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO ()++   unless shadowRender $ do+      normal3f (Normal3 0 0 1)+      color3f (Color3 1 1 1)+      rectf (Vertex2 (-20) (-20)) (Vertex2 20 20)++   preservingMatrix $ do+      translatef (Vector3 11 11 11)+      rotatef 54.73 (Vector3 (-5) 5 0)+      rotate torusAngle' (Vector3 1 0 0)+      color3f (Color3 1 0 0)+      renderObject Solid (Torus 1 4 8 36)++   preservingMatrix $ do+      translatef (Vector3 2 2 2)+      color3f (Color3 0 0 1)+      renderObject Solid (Cube 4)++   preservingMatrix $ do+      getLightPos Vector3 >>= translate+      color3f (Color3 1 1 1)+      renderObject Wireframe (Sphere' 0.5 6 6)++   when (shadowRender && textureOn == Enabled) $+      texture Texture2D $= Enabled++getLightPos :: (GLdouble -> GLdouble -> GLdouble -> a) -> IO a+getLightPos f = do+    Vertex4 x y z _ <- get (position (Light 0))+    return $ f (realToFrac x) (realToFrac y) (realToFrac z)++generateShadowMap :: GLfloat -> Bool -> IO ()+generateShadowMap torusAngle' showShadow' = do+   lightPos' <- getLightPos Vertex3+   let (TextureSize2D shadowMapWidth shadowMapHeight) = shadowMapSize+       shadowMapSize' = Size shadowMapWidth shadowMapHeight++   preservingViewport $ do+      viewport $= (Position 0 0, shadowMapSize')++      clear [ ColorBuffer, DepthBuffer ]++      matrixMode $= Projection+      preservingMatrix $ do+         loadIdentity+         perspective 80 1 10 1000+         matrixMode $= Modelview 0+         preservingMatrix $ do+            loadIdentity+            lookAt lightPos' lookat up+            drawObjects torusAngle' True+         matrixMode $= Projection+      matrixMode $= Modelview 0++      copyTexImage2D Nothing 0 DepthComponent' (Position 0 0) shadowMapSize 0++   when showShadow' $ do+      let numShadowMapPixels = fromIntegral (shadowMapWidth * shadowMapHeight)+      allocaArray numShadowMapPixels $ \depthImage -> do+        let pixelData fmt = PixelData fmt Float depthImage :: PixelData GLfloat+        readPixels (Position 0 0) shadowMapSize' (pixelData DepthComponent)+        (_, Size viewPortWidth _) <- get viewport+        windowPos (Vertex2 (fromIntegral viewPortWidth / 2 :: GLfloat) 0)+        drawPixels shadowMapSize' (pixelData Luminance)+        swapBuffers++-- Note: preservingViewport is not exception safe, but it doesn't matter here+preservingViewport :: IO a -> IO a+preservingViewport act = do+   v <- get viewport+   x <- act+   viewport $= v+   return x++generateTextureMatrix :: IO ()+generateTextureMatrix = do+   -- Set up projective texture matrix. We use the Modelview matrix stack and+   -- OpenGL matrix commands to make the matrix.+   m <- preservingMatrix $ do+      loadIdentity+      -- resolve overloading, not needed in "real" programs+      let translatef = translate :: Vector3 GLfloat -> IO ()+          scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO ()+      translatef (Vector3 0.5 0.5 0.0)+      scalef 0.5 0.5 1.0+      perspective 60 1 1 1000+      lightPos' <- getLightPos Vertex3+      lookAt lightPos' lookat up+      get (matrix (Just (Modelview 0)))++   [ sx, sy, sz, sw,+     tx, ty, tz, tw,+     rx, ry, rz, rw,+     qx, qy, qz, qw ] <- getMatrixComponents RowMajor (m :: GLmatrix GLdouble)++   textureGenMode S $= Just (ObjectLinear (Plane sx sy sz sw))+   textureGenMode T $= Just (ObjectLinear (Plane tx ty tz tw))+   textureGenMode R $= Just (ObjectLinear (Plane rx ry rz rw))+   textureGenMode Q $= Just (ObjectLinear (Plane qx qy qz qw))++display :: State -> DisplayCallback+display state = do+   let radius = 30+   torusAngle' <- get (torusAngle state)+   showShadow' <- get (showShadow state)+   generateShadowMap torusAngle' showShadow'+   generateTextureMatrix+   unless showShadow' $ do+      clear [ ColorBuffer, DepthBuffer ]+      preservingMatrix $ do+         angle' <- get (angle state)+         lookAt (Vertex3 (radius * cos angle') (radius * sin angle') 30) lookat up+         drawObjects torusAngle' False+      swapBuffers++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ RGBAMode, WithDepthBuffer, DoubleBuffered ]+   initialWindowSize $= Size 521 512+   initialWindowPosition $= Position 100 100+   createWindow progName+   state <- makeState+   myInit+   displayCallback $= display state+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboard state)+   idleCallback $= Just (idle state)++   mainLoop
+ examples/RedBook/Smooth.hs view
@@ -0,0 +1,65 @@+{-+   Smooth.hs (adapted from smooth.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates smooth shading. A smooth shaded polygon is drawn in+   a 2-D projection.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Smooth++triangle :: IO ()+triangle =+   -- resolve overloading, not needed in "real" programs+   let vertex2f = vertex :: Vertex2 GLfloat -> IO ()+       color3f = color :: Color3 GLfloat -> IO ()+   in renderPrimitive Triangles $ do+      color3f (Color3 1 0 0)+      vertex2f (Vertex2 5 5)+      color3f (Color3 0 1 0)+      vertex2f (Vertex2 25 5)+      color3f (Color3 0 0 1)+      vertex2f (Vertex2 5 25)++display :: DisplayCallback+display = do+   clear [ ColorBuffer ]+   triangle+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho2D 0 30 0 (30 * hf/wf)+      else ortho2D 0 (30 * wf/hf) 0 30+   matrixMode $= Modelview 0++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   displayCallback $= display+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/Stencil.hs view
@@ -0,0 +1,123 @@+{-+   Stencil.hs (adapted from stencil.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates use of the stencil buffer for masking+   nonrectangular regions. Whenever the window is redrawn, a value of 1 is drawn+   into a diamond-shaped region in the stencil buffer. Elsewhere in the stencil+   buffer, the value is 0. Then a blue sphere is drawn where the stencil value+   is 1, and yellow torii are drawn where the stencil value is not 1.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++data DisplayLists = DisplayLists { yellowMat, blueMat :: DisplayList }++myInit :: IO DisplayLists+myInit = do+   y <- defineNewList Compile $ do+      materialDiffuse Front $= Color4 0.7 0.7 0 1+      materialSpecular Front $= Color4 1 1 1 1+      materialShininess Front $= 64++   b <- defineNewList Compile $ do+      materialDiffuse Front $= Color4 0.1 0.1 0.7 1+      materialSpecular Front $= Color4  0.1 1 1 1+      materialShininess Front $= 45++   position (Light 0) $= Vertex4 1 1 1 0++   light (Light 0) $= Enabled+   lighting $= Enabled+   depthFunc $= Just Less++   clearStencil $= 0+   stencilTest $= Enabled++   return $ DisplayLists { yellowMat = y, blueMat = b }++-- Draw a sphere in a diamond-shaped section in the middle of a window with 2+-- torii.+display :: DisplayLists -> DisplayCallback+display displayLists = do+   clear [ ColorBuffer, DepthBuffer ]++   -- draw blue sphere where the stencil is 1+   stencilFunc $= (Equal, 1, 1)+   stencilOp $= (OpKeep, OpKeep, OpKeep)+   callList (blueMat displayLists)+   renderObject Solid (Sphere' 0.5 15 15)++   -- resolve overloading, not needed in "real" programs+   let rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO ()++   -- draw the tori where the stencil is not 1+   stencilFunc $= (Notequal, 1, 1)+   preservingMatrix $ do+      rotatef 45 (Vector3 0 0 1)+      rotatef 45 (Vector3 0 1 0)+      callList (yellowMat displayLists)+      renderObject Solid (Torus 0.275 0.85 15 15)+      preservingMatrix $ do+         rotatef 90 (Vector3 1 0 0)+         renderObject Solid (Torus 0.275 0.85 15 15)++   flush++-- Whenever the window is reshaped, redefine the coordinate system and redraw+-- the stencil area.+reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)++   -- create a diamond shaped stencil area+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho2D (-3) 3 (-3*hf/wf) (3*hf/wf)+      else ortho2D (-3*wf/hf) (3*wf/hf) (-3) 3+   matrixMode $= Modelview 0+   loadIdentity++   -- resolve overloading, not needed in "real" programs+   let vertex2f = vertex :: Vertex2 GLfloat -> IO ()+       translatef = translate :: Vector3 GLfloat -> IO ()++   clear [ StencilBuffer ]+   stencilFunc $= (Always, 1, 1)+   stencilOp $= (OpReplace, OpReplace, OpReplace)+   renderPrimitive Quads $ do+      vertex2f (Vertex2 (-1) 0)+      vertex2f (Vertex2 0 1)+      vertex2f (Vertex2 1 0)+      vertex2f (Vertex2 0 (-1))++   matrixMode $= Projection+   loadIdentity+   perspective 45 (wf/hf) 3 7+   matrixMode $= Modelview 0+   loadIdentity+   translatef (Vector3 0 0 (-5))++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++-- Main Loop: Be certain to request stencil bits.+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer, WithStencilBuffer ]+   initialWindowSize $= Size 400 400+   initialWindowPosition $= Position 100 100+   createWindow progName+   displayLists <- myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   displayCallback $= display displayLists+   mainLoop
+ examples/RedBook/Stroke.hs view
@@ -0,0 +1,127 @@+{-+   Stroke.hs (adapted from stroke.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates some characters of a stroke (vector) font. The+   characters are represented by display lists, which are given numbers which+   correspond to the ASCII values of the characters. Use of callLists is+   demonstrated.+-}++import Data.List ( genericLength )+import Foreign.C.String ( castCharToCChar )+import Foreign.Marshal.Array ( withArray )+import Graphics.UI.GLUT+import System.Exit ( exitWith, ExitCode(ExitSuccess) )++aData, eData, pData, rData, sData :: [[Vertex2 GLfloat]]+aData = [+   [ Vertex2 0 0, Vertex2 0 9, Vertex2 1 10, Vertex2 4 10, Vertex2 5 9,+     Vertex2 5 0 ],+   [ Vertex2 0 5, Vertex2 5 5 ] ]++eData = [+   [ Vertex2 5 0, Vertex2 0 0, Vertex2 0 10, Vertex2 5 10 ],+   [ Vertex2 0 5, Vertex2 4 5 ] ]++pData = [+   [ Vertex2 0 0, Vertex2 0 10,  Vertex2 4 10, Vertex2 5 9, Vertex2 5 6,+     Vertex2 4 5, Vertex2 0 5 ] ]++rData = [+   [ Vertex2 0 0, Vertex2 0 10,  Vertex2 4 10, Vertex2 5 9, Vertex2 5 6,+     Vertex2 4 5, Vertex2 0 5 ],+   [ Vertex2 3 5, Vertex2 5 0 ] ]++sData = [+   [ Vertex2 0 1, Vertex2 1 0, Vertex2 4 0, Vertex2 5 1, Vertex2 5 4,+     Vertex2 4 5, Vertex2 1 5, Vertex2 0 6, Vertex2 0 9, Vertex2 1 10,+     Vertex2 4 10, Vertex2 5 9 ] ]++advance :: IO ()+advance = translate (Vector3 8 0 (0 :: GLfloat))++-- drawLetter renders a letter with line segments given by the list of line+-- strips.+drawLetter :: [[Vertex2 GLfloat]] -> IO ()+drawLetter lineStrips = do+   mapM_ (renderPrimitive LineStrip . mapM_ vertex) lineStrips+   advance++charToGLubyte :: Char -> GLubyte+charToGLubyte = fromIntegral . castCharToCChar++myInit :: IO ()+myInit = do+   shadeModel $= Flat++   (base@(DisplayList b):_) <- genObjectNames 128+   listBase $= base+   let charToDisplayList c = DisplayList (b + fromIntegral (charToGLubyte c))+   mapM_ (\(c, d) -> defineList (charToDisplayList c) Compile d)+         [ ('A', drawLetter aData),+           ('E', drawLetter eData),+           ('P', drawLetter pData),+           ('R', drawLetter rData),+           ('S', drawLetter sData),+           (' ', advance) ]++test1, test2 :: String+test1 = "A SPARE SERAPE APPEARS AS"+test2 = "APES PREPARE RARE PEPPERS"++printStrokedString :: String -> IO ()+printStrokedString s =+   withArray (map charToGLubyte s) $+      callLists (genericLength s) UnsignedByte++display :: DisplayCallback+display = do+   clear [ ColorBuffer ]++   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+       scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO ()+       translatef = translate :: Vector3 GLfloat -> IO ()++   color3f (Color3 1 1 1)+   preservingMatrix $ do+      scalef 2 2 2+      translatef (Vector3 10 30 0)+      printStrokedString test1+   preservingMatrix $ do+      scalef 2 2 2+      translatef (Vector3 10 13 0)+      printStrokedString test2+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho2D 0 (fromIntegral w) 0 (fromIntegral h)+   matrixMode $= Modelview 0++keyboard :: KeyboardMouseCallback+keyboard (Char c) Down _ _ = case c of+   ' '   -> postRedisplay Nothing+   '\27' -> exitWith ExitSuccess+   _     -> return ()+keyboard _ _ _ _ = return ()++-- Main Loop: Open window with initial window size, title bar, RGBA display+-- mode, and handle input events.+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 440 120+   createWindow progName+   myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   displayCallback $= display+   mainLoop
+ examples/RedBook/SurfPoints.hs view
@@ -0,0 +1,129 @@+{-+   SurfPoints.hs (adapted from surfpoints.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program is a modification of the earlier Surface.hs program. The+   vertex data are not directly rendered, but are instead passed to the+   callback function. The values of the tessellated vertices are printed+   out there.++   This program draws a NURBS surface in the shape of a symmetrical hill.+   The 'c' keyboard key allows you to toggle the visibility of the control+   points themselves. Note that some of the control points are hidden by+   the surface itself.++   NOTE: This example does NOT demonstrate the final NURBS API, it's currently+   just a test for the internals...+-}++import Control.Monad ( when )+import Data.Char ( toLower )+import Data.IORef ( IORef, newIORef )+import Foreign.Marshal ( withArray )+import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure )+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."+      exitFailure+   state <- makeState+   myInit+   reshapeCallback $= Just reshape+   displayCallback $= display state+   keyboardMouseCallback $= Just (keyboard state)+   mainLoop
+ examples/RedBook/Surface.hs view
@@ -0,0 +1,112 @@+{-+   Surface.hs (adapted from surface.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program draws a NURBS surface in the shape of a symmetrical hill.+   The 'c' keyboard key allows you to toggle the visibility of the control+   points themselves. Note that some of the control points are hidden by+   the surface itself.++   NOTE: This example does NOT demonstrate the final NURBS API, it's currently+   just a test for the internals...+-}++import Control.Monad ( when )+import Data.Char ( toLower )+import Data.IORef ( IORef, newIORef )+import Foreign.Marshal ( withArray )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++data State = State { showPoints :: IORef Bool }++makeState :: IO State+makeState = do+   s <- newIORef False+   return $ State { showPoints = s }++-- The control points of the surface form a small hill and+-- range from -3 to +3 in x, y, and z.+ctlPoints :: [[Vertex3 GLfloat]]+ctlPoints =+   [ [ Vertex3 (2 * u - 3)+               (2 * v - 3)+               (if (u == 1 || u ==2) && (v == 1 || v == 2) then 3 else -3)+     | v <- [ 0 .. 3 ] ]+   | u <- [ 0 .. 3 ]]++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   materialDiffuse Front $= Color4 0.7 0.7 0.7 1+   materialSpecular Front $= Color4 1 1 1 1+   materialShininess Front $= 100++   lighting $= Enabled+   light (Light 0) $= Enabled+   depthFunc $= Just Less+   autoNormal $= Enabled+   normalize $= Enabled++--------------------------------------------------------------------------------++display :: State -> DisplayCallback+display state = do+   let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat]+   clear [ ColorBuffer, DepthBuffer ]+   preservingMatrix $ do+      rotate (330 :: GLfloat) (Vector3 1 0 0)+      scale 0.5 0.5 (0.5 :: GLfloat)++      withNURBSObj () $ \nurbsObj -> do+         setSamplingMethod nurbsObj (PathLength 25)+         setDisplayMode' nurbsObj Fill'+         checkForNURBSError nurbsObj $+            nurbsBeginEndSurface nurbsObj $+               withArray (concat ctlPoints) $ \cBuf ->+                  withArray knots $ \kBuf ->+                     nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4++      s <- get (showPoints state)+      when s $ do+         pointSize $= 5+         lighting $= Disabled+         color (Color3 1 1 (0 :: GLfloat))+         renderPrimitive Points $+            mapM_ (mapM_ vertex) ctlPoints+         lighting $= Enabled++   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective 45 (fromIntegral w / fromIntegral h) 3 8+   matrixMode $= Modelview 0+   loadIdentity+   translate (Vector3 0 0 (-5 :: GLfloat))++keyboard :: State -> KeyboardMouseCallback+keyboard state (Char c) Down _ _ = case toLower c of+   'c'   -> do showPoints state $~ not; postRedisplay Nothing+   '\27' -> exitWith ExitSuccess+   _     -> return ()+keyboard _ _ _ _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   state <- makeState+   myInit+   reshapeCallback $= Just reshape+   displayCallback $= display state+   keyboardMouseCallback $= Just (keyboard state)+   mainLoop
+ examples/RedBook/Teapots.hs view
@@ -0,0 +1,226 @@+{-+   Teapots.hs (adapted from teapots.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates lots of material properties. A single light+   source illuminates the objects.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++-- Initialize depth buffer, projection matrix, light source, and lighting+-- model. Do not specify a material property here.+myInit :: IO DisplayList+myInit = do+   ambient (Light 0) $= Color4 0 0 0 1+   diffuse (Light 0) $= Color4 1 1 1 1+   position (Light 0) $= Vertex4  0 3 3 0+   lightModelAmbient $= Color4 0.2 0.2 0.2 1+   lightModelLocalViewer $= Disabled++   frontFace $= CW+   lighting $= Enabled+   light (Light 0) $= Enabled+   autoNormal $= Enabled+   normalize $= Enabled+   depthFunc $= Just Less+   -- be efficient--make teapot display list+   defineNewList Compile $+      renderObject Solid (Teapot 1)++-- Move object into position, specify the material properties, draw a teapot.+renderTeapot :: DisplayList -> Vector3 GLfloat -> Color4 GLfloat+             -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> IO ()+renderTeapot teapotList pos amb dif spec shine = do+   preservingMatrix $ do+      translate pos+      materialAmbient Front $= amb+      materialDiffuse Front $= dif+      materialSpecular Front $= spec+      materialShininess Front $= shine * 128+      callList teapotList++-- 1st column: emerald, jade, obsidian, pearl, ruby, turquoise+-- 2nd column: brass, bronze, chrome, copper, gold, silver+-- 3rd column: black, cyan, green, red, white, yellow plastic+-- 4th column: black, cyan, green, red, white, yellow rubber+display :: DisplayList -> DisplayCallback+display teapotList = do+   clear [ ColorBuffer, DepthBuffer ]+   renderTeapot teapotList+                (Vector3  2 17 0)+                (Color4 0.0215    0.1745      0.0215     1)+                (Color4 0.07568   0.61424     0.07568    1)+                (Color4 0.633     0.727811    0.633      1)+                0.6+   renderTeapot teapotList+                (Vector3  2 14 0)+                (Color4 0.135     0.2225      0.1575     1)+                (Color4 0.54      0.89        0.63       1)+                (Color4 0.316228  0.316228    0.316228   1)+                0.1+   renderTeapot teapotList+                (Vector3  2 11 0)+                (Color4 0.05375   0.05        0.06625    1)+                (Color4 0.18275   0.17        0.22525    1)+                (Color4 0.332741  0.328634    0.346435   1)+                0.3+   renderTeapot teapotList+                (Vector3  2  8 0)+                (Color4 0.25      0.20725     0.20725    1)+                (Color4 1         0.829       0.829      1)+                (Color4 0.296648  0.296648    0.296648   1)+                0.088+   renderTeapot teapotList+                (Vector3  2  5 0)+                (Color4 0.1745    0.01175     0.01175    1)+                (Color4 0.61424   0.04136     0.04136    1)+                (Color4 0.727811  0.626959    0.626959   1)+                0.6+   renderTeapot teapotList+                (Vector3  2  2 0)+                (Color4 0.1       0.18725     0.1745     1)+                (Color4 0.396     0.74151     0.69102    1)+                (Color4 0.297254  0.30829     0.306678   1)+                0.1+   renderTeapot teapotList+                (Vector3  6 17 0)+                (Color4 0.329412  0.223529    0.027451   1)+                (Color4 0.780392  0.568627    0.113725   1)+                (Color4 0.992157  0.941176    0.807843   1)+                0.21794872+   renderTeapot teapotList+                (Vector3  6 14 0)+                (Color4 0.2125    0.1275      0.054      1)+                (Color4 0.714     0.4284      0.18144    1)+                (Color4 0.393548  0.271906    0.166721   1)+                0.2+   renderTeapot teapotList+                (Vector3  6 11 0)+                (Color4 0.25      0.25        0.25       1)+                (Color4 0.4       0.4         0.4        1)+                (Color4 0.774597  0.774597    0.774597   1)+                0.6+   renderTeapot teapotList+                (Vector3  6  8 0)+                (Color4 0.19125   0.0735      0.0225     1)+                (Color4 0.7038    0.27048     0.0828     1)+                (Color4 0.256777  0.137622    0.086014   1)+                0.1+   renderTeapot teapotList+                (Vector3  6  5 0)+                (Color4 0.24725   0.1995      0.0745     1)+                (Color4 0.75164   0.60648     0.22648    1)+                (Color4 0.628281  0.555802    0.366065   1)+                0.4+   renderTeapot teapotList+                (Vector3  6  2 0)+                (Color4 0.19225   0.19225     0.19225    1)+                (Color4 0.50754   0.50754     0.50754    1)+                (Color4 0.508273  0.508273    0.508273   1)+                0.4+   renderTeapot teapotList+                (Vector3 10 17 0)+                (Color4 0         0           0          1)+                (Color4 0.01      0.01        0.01       1)+                (Color4 0.50      0.50        0.50       1)+                0.25+   renderTeapot teapotList+                (Vector3 10 14 0)+                (Color4 0          0.1        0.06       1)+                (Color4 0          0.50980392 0.50980392 1)+                (Color4 0.50196078 0.50196078 0.50196078 1)+                0.25+   renderTeapot teapotList+                (Vector3 10 11 0)+                (Color4 0         0           0          1)+                (Color4 0.1       0.35        0.1        1)+                (Color4 0.45      0.55        0.45       1)+                0.25+   renderTeapot teapotList+                (Vector3 10  8 0)+                (Color4 0         0           0          1)+                (Color4 0.5       0           0          1)+                (Color4 0.7       0.6         0.6        1)+                0.25+   renderTeapot teapotList+                (Vector3 10  5 0)+                (Color4 0         0           0          1)+                (Color4 0.55      0.55        0.55       1)+                (Color4 0.70      0.70        0.70       1)+                0.25+   renderTeapot teapotList+                (Vector3 10  2 0)+                (Color4 0         0           0          1)+                (Color4 0.5       0.5         0          1)+                (Color4 0.60      0.60        0.50       1)+                0.25+   renderTeapot teapotList+                (Vector3 14 17 0)+                (Color4 0.02      0.02        0.02       1)+                (Color4 0.01      0.01        0.01       1)+                (Color4 0.4       0.4         0.4        1)+                0.078125+   renderTeapot teapotList+                (Vector3 14 14 0)+                (Color4 0         0.05        0.05       1)+                (Color4 0.4       0.5         0.5        1)+                (Color4 0.04      0.7         0.7        1)+                0.078125+   renderTeapot teapotList+                (Vector3 14 11 0)+                (Color4 0         0.05        0          1)+                (Color4 0.4       0.5         0.4        1)+                (Color4 0.04      0.7         0.04       1)+                0.078125+   renderTeapot teapotList+                (Vector3 14  8 0)+                (Color4 0.05      0           0          1)+                (Color4 0.5       0.4         0.4        1)+                (Color4 0.7       0.04        0.04       1)+                0.078125+   renderTeapot teapotList+                (Vector3 14  5 0)+                (Color4 0.05      0.05        0.05       1)+                (Color4 0.5       0.5         0.5        1)+                (Color4 0.7       0.7         0.7        1)+                0.078125+   renderTeapot teapotList+                (Vector3 14  2 0)+                (Color4 0.05      0.05        0          1)+                (Color4 0.5       0.5         0.4        1)+                (Color4 0.7       0.7         0.04       1)+                0.078125+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho 0 16 0 (16 * hf/wf) (-10) 10+      else ortho 0 (16 * wf/hf) 0 16 (-10) 10+   matrixMode $= Modelview 0++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 500 600+   initialWindowPosition $= Position 50 50+   createWindow progName+   teapotList <- myInit+   reshapeCallback $= Just reshape+   displayCallback $= display teapotList+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/Tess.hs view
@@ -0,0 +1,117 @@+{-+   Tess.hs (adapted from tess.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates polygon tessellation. Two tesselated objects are+   drawn. The first is a rectangle with a triangular hole. The second is a+   smooth shaded, self-intersecting star.++   Note the exterior rectangle is drawn with its vertices in counter-clockwise+   order, but its interior clockwise. Note the combineCallback is needed for the+   self-intersecting star. Also note that removing the TessProperty for the+   star will make the interior unshaded (TessWindingOdd).+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++display :: [DisplayList] -> DisplayCallback+display displayLists = do+   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+   color3f (Color3 1 1 1)+   mapM callList displayLists+   flush++-- 'Float' is a dummy, any marshalable type would do+type DontCare = Float++rectangle :: ComplexContour DontCare+rectangle = ComplexContour [+   AnnotatedVertex (Vertex3  50  50 0) 0,+   AnnotatedVertex (Vertex3 200  50 0) 0,+   AnnotatedVertex (Vertex3 200 200 0) 0,+   AnnotatedVertex (Vertex3  50 200 0) 0 ]++tri :: ComplexContour DontCare+tri = ComplexContour [+   AnnotatedVertex (Vertex3  75  75 0) 0,+   AnnotatedVertex (Vertex3 125 175 0) 0,+   AnnotatedVertex (Vertex3 175  75 0) 0 ]++rectAndTri :: ComplexPolygon DontCare+rectAndTri = ComplexPolygon [ rectangle, tri ]++noOpCombiner :: Combiner DontCare+noOpCombiner _newVertex _weightedProperties = 0++star :: ComplexPolygon (Color3 GLclampf)+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 GLclampf)+combineColors+   _newVertex+   (WeightedProperties+      (w0, Color3 r0 g0 b0)+      (w1, Color3 r1 g1 b1)+      (w2, Color3 r2 g2 b2)+      (w3, Color3 r3 g3 b3)) =+         Color3 (w0*r0 + w1*r1 + w2*r2 + w3*r3)+                (w0*g0 + w1*g1 + w2*g2 + w3*g3)+                (w0*b0 + w1*b1 + w2*b2 + w3*b3)++myInit :: IO [DisplayList]+myInit = do+   clearColor $= Color4 0 0 0 0++   rectAndTriList <- defineNewList Compile $+      drawSimplePolygon (\_ -> return ()) =<<+         tessellate TessWindingOdd 0 (Normal3 0 0 0) noOpCombiner rectAndTri++   starList <- defineNewList Compile $+      drawSimplePolygon color =<<+         tessellate TessWindingPositive 0 (Normal3 0 0 0) combineColors star++   return [ rectAndTriList, starList ]++drawSimplePolygon :: (v -> IO ()) -> SimplePolygon v -> IO ()+drawSimplePolygon colorHandler (SimplePolygon primitives) =+   flip mapM_ primitives $ \(Primitive primitiveMode vertices) ->+      renderPrimitive primitiveMode $+         flip mapM_ vertices $ \(AnnotatedVertex plainVertex col) -> do+            colorHandler col+            vertex plainVertex++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho2D 0 (fromIntegral w) 0 (fromIntegral h)+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 500 500+   createWindow progName+   displayLists <- myInit+   displayCallback $= display displayLists+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/TessWind.hs view
@@ -0,0 +1,195 @@+{-+   TessWind.hs (adapted from tesswind.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates the winding rule polygon tessellation property.+   Four tessellated objects are drawn, each with very different contours. When+   the w key is pressed, the objects are drawn with a different winding rule.+-}++import Data.Char ( toLower )+import Data.IORef ( IORef, newIORef )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++data State = State { currentWindingRule :: IORef TessWinding }++makeState :: IO State+makeState = do+   c <- newIORef TessWindingOdd+   return $ State { currentWindingRule = c }++type DisplayLists = (DisplayList, DisplayList, DisplayList, DisplayList)++-- 'Float' is a dummy, any marshalable type would do+type DontCare = Float++rect1 :: ComplexContour DontCare+rect1 = ComplexContour [+   AnnotatedVertex (Vertex3  50  50 0) 0,+   AnnotatedVertex (Vertex3 300  50 0) 0,+   AnnotatedVertex (Vertex3 300 300 0) 0,+   AnnotatedVertex (Vertex3  50 300 0) 0 ]++rect2 :: ComplexContour DontCare+rect2 = ComplexContour [+   AnnotatedVertex (Vertex3 100 100 0) 0,+   AnnotatedVertex (Vertex3 250 100 0) 0,+   AnnotatedVertex (Vertex3 250 250 0) 0,+   AnnotatedVertex (Vertex3 100 250 0) 0 ]++rect3 :: ComplexContour DontCare+rect3 = ComplexContour [+   AnnotatedVertex (Vertex3 150 150 0) 0,+   AnnotatedVertex (Vertex3 200 150 0) 0,+   AnnotatedVertex (Vertex3 200 200 0) 0,+   AnnotatedVertex (Vertex3 150 200 0) 0 ]++rects1 :: ComplexPolygon DontCare+rects1 = ComplexPolygon [ rect1, rect2, rect3 ]++rects2 :: ComplexPolygon DontCare+rects2 = ComplexPolygon [+   rect1, reverseComplexContour rect2, reverseComplexContour rect3 ]++spiral :: ComplexPolygon DontCare+spiral = ComplexPolygon [+   ComplexContour [+      AnnotatedVertex (Vertex3 400 250 0) 0,+      AnnotatedVertex (Vertex3 400  50 0) 0,+      AnnotatedVertex (Vertex3  50  50 0) 0,+      AnnotatedVertex (Vertex3  50 400 0) 0,+      AnnotatedVertex (Vertex3 350 400 0) 0,+      AnnotatedVertex (Vertex3 350 100 0) 0,+      AnnotatedVertex (Vertex3 100 100 0) 0,+      AnnotatedVertex (Vertex3 100 350 0) 0,+      AnnotatedVertex (Vertex3 300 350 0) 0,+      AnnotatedVertex (Vertex3 300 150 0) 0,+      AnnotatedVertex (Vertex3 150 150 0) 0,+      AnnotatedVertex (Vertex3 150 300 0) 0,+      AnnotatedVertex (Vertex3 250 300 0) 0,+      AnnotatedVertex (Vertex3 250 200 0) 0,+      AnnotatedVertex (Vertex3 200 200 0) 0,+      AnnotatedVertex (Vertex3 200 250 0) 0 ] ]++quad1 :: ComplexContour DontCare+quad1 = ComplexContour [+   AnnotatedVertex (Vertex3  50 150 0) 0,+   AnnotatedVertex (Vertex3 350 150 0) 0,+   AnnotatedVertex (Vertex3 350 200 0) 0,+   AnnotatedVertex (Vertex3  50 200 0) 0 ]++quad2 :: ComplexContour DontCare+quad2 = ComplexContour [+   AnnotatedVertex (Vertex3 100 100 0) 0,+   AnnotatedVertex (Vertex3 300 100 0) 0,+   AnnotatedVertex (Vertex3 300 350 0) 0,+   AnnotatedVertex (Vertex3 100 350 0) 0 ]++tri :: ComplexContour DontCare+tri = ComplexContour [+   AnnotatedVertex (Vertex3 200  50 0) 0,+   AnnotatedVertex (Vertex3 250 300 0) 0,+   AnnotatedVertex (Vertex3 150 300 0) 0 ]++quadsAndTri :: ComplexPolygon DontCare+quadsAndTri = ComplexPolygon [ quad1, quad2, tri ]++reverseComplexContour :: ComplexContour DontCare -> ComplexContour DontCare+reverseComplexContour (ComplexContour avs) = ComplexContour (reverse avs)++makeNewLists :: State -> DisplayLists -> IO ()+makeNewLists state (dl1, dl2, dl3, dl4) = do+   windingRule <- get (currentWindingRule state)+   print windingRule   -- not in original program, but useful+   compileList windingRule dl1 rects1+   compileList windingRule dl2 rects2+   compileList windingRule dl3 spiral+   compileList windingRule dl4 quadsAndTri++compileList :: TessWinding -> DisplayList -> ComplexPolygon DontCare -> IO ()+compileList windingRule displayList complexPolygon =+   defineList displayList Compile $+      drawSimplePolygon =<<+         tessellate windingRule 0 (Normal3 0 0 0) noOpCombiner complexPolygon++noOpCombiner :: Combiner DontCare+noOpCombiner _newVertex _weightedProperties = 0++drawSimplePolygon :: SimplePolygon DontCare -> IO ()+drawSimplePolygon (SimplePolygon primitives) =+   flip mapM_ primitives $ \(Primitive primitiveMode vertices) ->+      renderPrimitive primitiveMode $+         flip mapM_ vertices $ \(AnnotatedVertex plainVertex _) ->+            vertex plainVertex++display :: DisplayLists -> DisplayCallback+display (dl1, dl2, dl3, dl4) = do+   clear [ ColorBuffer ]+   -- resolve overloading, not needed in "real" programs+   let color3f = color :: Color3 GLfloat -> IO ()+       translatef = translate :: Vector3 GLfloat -> IO ()+   color3f (Color3 1 1 1)+   preservingMatrix $ do+      callList dl1+      translatef (Vector3   0   500  0)+      callList dl2+      translatef (Vector3 500 (-500) 0)+      callList dl3+      translatef (Vector3   0   500  0)+      callList dl4+   flush++myInit :: State -> IO DisplayLists+myInit state = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Flat+   [dl1, dl2, dl3, dl4] <- genObjectNames 4+   let displayLists = (dl1, dl2, dl3, dl4)+   makeNewLists state displayLists+   return displayLists++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho2D 0 1000 0 (1000 * hf/wf)+      else ortho2D 0 (1000 * wf/hf) 0 1000+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: State -> DisplayLists -> KeyboardMouseCallback+keyboard state displayLists (Char c) Down _ _ = case toLower c of+   'w'   -> do currentWindingRule state $~ nextWindingRule+               makeNewLists state displayLists+               postRedisplay Nothing+   '\27' -> exitWith ExitSuccess+   _     -> return ()+keyboard _ _ _ _ _ _ = return ()++nextWindingRule :: TessWinding -> TessWinding+nextWindingRule r = case r of+   TessWindingOdd       -> TessWindingNonzero+   TessWindingNonzero   -> TessWindingPositive+   TessWindingPositive  -> TessWindingNegative+   TessWindingNegative  -> TessWindingAbsGeqTwo+   TessWindingAbsGeqTwo -> TessWindingOdd++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 500 500+   createWindow progName+   state <- makeState+   displayLists <- myInit state+   displayCallback $= display displayLists+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboard state displayLists)+   mainLoop
+ examples/RedBook/TexBind.hs view
@@ -0,0 +1,108 @@+{-+   TexBind.hs  (adapted from texbind.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates using textureBinding by creating and managing+   two textures.+-}++import Control.Monad ( when )+import Data.Bits ( (.&.) )+import Foreign ( withArray )+import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++-- Create checkerboard image+checkImageSize :: TextureSize2D+checkImageSize = TextureSize2D 64 64++withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte))+               -> (PixelData (Color4 GLubyte) -> IO ()) -> IO ()+withCheckImage (TextureSize2D w h) n f act =+   withArray [ f c |+               i <- [ 0 .. w - 1 ],+               j <- [ 0 .. h - 1 ],+               let c | (i .&. n) == (j .&. n) = 0+                     | otherwise              = 255 ] $+   act . PixelData RGBA UnsignedByte++myInit :: IO (TextureObject, TextureObject)+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Flat+   depthFunc $= Just Less+   rowAlignment Unpack $= 1++   [texName0, texName1] <- genObjectNames 2+   textureBinding Texture2D $= Just texName0+   textureWrapMode Texture2D S $= (Repeated, Clamp)+   textureWrapMode Texture2D T $= (Repeated, Clamp)+   textureFilter Texture2D $= ((Nearest, Nothing), Nearest)+   withCheckImage checkImageSize 0x08 (\c -> Color4 c c c 255) $+      texImage2D Nothing NoProxy 0  RGBA' checkImageSize 0++   textureBinding Texture2D $= Just texName1+   textureWrapMode Texture2D S $= (Repeated, Clamp)+   textureWrapMode Texture2D T $= (Repeated, Clamp)+   textureFilter Texture2D $= ((Nearest, Nothing), Nearest)+   textureFunction $= Decal+   withCheckImage checkImageSize 0x10 (\c -> Color4 c 0 0 255) $+      texImage2D Nothing NoProxy 0  RGBA' checkImageSize 0+   texture Texture2D $= Enabled+   return (texName0, texName1)++display ::  (TextureObject, TextureObject) -> DisplayCallback+display (texName0, texName1) = do+   clear [ ColorBuffer, DepthBuffer ]+   -- resolve overloading, not needed in "real" programs+   let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()+       vertex3f = vertex :: Vertex3 GLfloat -> IO ()+   textureBinding Texture2D $= Just texName0+   renderPrimitive Quads $ do+      texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0)    (-1.0)   0.0     )+      texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0)      1.0    0.0     )+      texCoord2f (TexCoord2 1 1); vertex3f (Vertex3   0.0       1.0    0.0     )+      texCoord2f (TexCoord2 1 0); vertex3f (Vertex3   0.0     (-1.0)   0.0     )+   textureBinding Texture2D $= Just texName1+   renderPrimitive Quads $ do+      texCoord2f (TexCoord2 0 0); vertex3f (Vertex3   1.0     (-1.0)   0.0     )+      texCoord2f (TexCoord2 0 1); vertex3f (Vertex3   1.0       1.0    0.0     )+      texCoord2f (TexCoord2 1 1); vertex3f (Vertex3   2.41421   1.0  (-1.41421))+      texCoord2f (TexCoord2 1 0); vertex3f (Vertex3   2.41421 (-1.0) (-1.41421))+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective 60 (fromIntegral w / fromIntegral h) 1 30+   matrixMode $= Modelview 0+   loadIdentity+   translate (Vector3 0 0 (-3.6 :: GLfloat))++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 250 250+   initialWindowPosition $= Position 100 100+   createWindow progName+   -- we have to do this *after* createWindow, otherwise we have no OpenGL context+   version <- get (majorMinor glVersion)+   when (version == (1,0)) $ do+      putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0."+      putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions,"+      putStrLn "you may be able to modify this program to make it run."+      exitFailure+   texNames <- myInit+   reshapeCallback $= Just reshape+   displayCallback $= display texNames+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/TexGen.hs view
@@ -0,0 +1,132 @@+{-+   TexGen.hs  (adapted from texgen.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program draws a texture mapped teapot with automatically generated+   texture coordinates. The texture is rendered as stripes on the teapot.+   Initially, the object is drawn with texture coordinates based upon the+   object coordinates of the vertex and distance from the plane x = 0.+   Pressing the 'e' key changes the coordinate generation to eye coordinates+   of the vertex. Pressing the 'o' key switches it back to the object+   coordinates. Pressing the 's' key changes the plane to a slanted one+   (x + y + z = 0). Pressing the 'x' key switches it back to x = 0.+-}++import Control.Monad ( when )+import Data.Char ( toLower )+import Data.Maybe ( isJust, listToMaybe )+import Foreign ( withArray )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++stripeImageWidth :: TextureSize1D+stripeImageWidth = TextureSize1D 32++xEqualZero, slanted :: Plane GLdouble+xEqualZero = Plane 1 0 0 0+slanted    = Plane 1 1 1 0++withStripeImage :: (PixelData (Color4 GLubyte) -> IO a) -> IO a+withStripeImage act =+   withArray [ Color4 (if j <= 4 then 255 else 0)+                      (if j >  4 then 255 else 0)+                      0+                      255+             | j <- [ 0 .. w - 1 ] ] $+      act . PixelData RGBA UnsignedByte+   where TextureSize1D w = stripeImageWidth++myInit :: IO (Maybe TextureObject)+myInit = do+   clearColor $= Color4 0 0 0 0+   depthFunc $= Just Less+   shadeModel $= Smooth+   rowAlignment Unpack $= 1++   exts <- get glExtensions+   mbTexName <- if "GL_EXT_texture_object" `elem` exts+                   then fmap listToMaybe $ genObjectNames 1+                   else return Nothing+   when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName++   textureWrapMode Texture1D S $= (Repeated, Repeat)+   textureFilter Texture1D $= ((Linear', Nothing), Linear')+   withStripeImage $ texImage1D NoProxy 0  RGBA' stripeImageWidth 0++   textureFunction $= Modulate+   textureGenMode S $= Just (ObjectLinear xEqualZero)++   texture Texture1D $= Enabled+   lighting $= Enabled+   light (Light 0) $= Enabled+   autoNormal $= Enabled+   normalize $= Enabled+   frontFace $= CW+   cullFace $= Just Back+   materialShininess Front $= 64+   return mbTexName++display ::  Maybe TextureObject -> DisplayCallback+display mbTexName = do+   clear [ ColorBuffer, DepthBuffer ]+   preservingMatrix $ do+      rotate (45 :: GLfloat) (Vector3 0 0 1)+      when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName+      renderObject Solid (Teapot 2)+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho (-3.5) 3.5 (-3.5*hf/wf) (3.5*hf/wf) (-3.5) 3.5+      else ortho (-3.5*wf/hf) (3.5*wf/hf) (-3.5) 3.5 (-3.5) 3.5+   matrixMode $= Modelview 0+   loadIdentity++keyboard :: KeyboardMouseCallback+keyboard (Char c) Down _ _ = case toLower c of+   'e'   -> setGenMode EyeLinear+   'o'   -> setGenMode ObjectLinear+   's'   -> setPlane slanted+   'x'   -> setPlane xEqualZero+   '\27' -> exitWith ExitSuccess+   _     -> return ()+keyboard _ _ _ _ = return ()++setGenMode :: (Plane GLdouble -> TextureGenMode) -> IO ()+setGenMode mode = do+   currentGenMode <- get (textureGenMode S)+   case currentGenMode of+      Just (EyeLinear    plane) -> textureGenMode S $= Just (mode plane)+      Just (ObjectLinear plane) -> textureGenMode S $= Just (mode plane)+      _ -> error "setGenMode: should never happen..."+   postRedisplay Nothing++setPlane :: Plane GLdouble -> IO ()+setPlane plane = do+   currentGenMode <- get (textureGenMode S)+   case currentGenMode of+      Just (EyeLinear    _) -> textureGenMode S $= Just (EyeLinear    plane)+      Just (ObjectLinear _) -> textureGenMode S $= Just (ObjectLinear plane)+      _ -> error "setPlane: should never happen..."+   postRedisplay Nothing++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 256 256+   initialWindowPosition $= Position 100 100+   createWindow progName+   mbTexName <- myInit+   displayCallback $= display mbTexName+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/TexProx.hs view
@@ -0,0 +1,58 @@+{-+   TexProx.hs (adapted from texprox.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   The brief program illustrates use of texture proxies. This program only+   prints out some messages about whether certain size textures are supported+   and then exits.+-}++import Control.Monad ( when )+import Foreign.Ptr ( nullPtr )+import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++myInit :: IO ()+myInit = do+   let check = do+          ok <- get (textureProxyOK (Left Texture2D) 0)+          putStrLn ("proxy allocation " ++ if ok then "succeeded" else "failed")++   texImage2D Nothing Proxy 0 RGBA8 (TextureSize2D 64 64) 0 (PixelData RGBA UnsignedByte nullPtr)+   check++   -- Note: We use a larger texture size here to demonstrate failure,+   -- modern graphic cards can handle the original size.+   texImage2D Nothing Proxy 0 RGBA16 (TextureSize2D 8192 8192) 0 (PixelData RGBA UnsignedShort nullPtr)+   check+++display :: DisplayCallback+display = exitWith ExitSuccess++reshape :: ReshapeCallback+reshape size = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   -- we have to do this *after* createWindow, otherwise we have no OpenGL context+   version <- get (majorMinor glVersion)+   when (version == (1,0)) $ do+      putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0."+      putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions,"+      putStrLn "you may be able to modify this program to make it run."+      exitFailure+   myInit+   displayCallback $= display+   reshapeCallback $= Just reshape+   mainLoop
+ examples/RedBook/TexSub.hs view
@@ -0,0 +1,120 @@+{-+   TexSub.hs  (adapted from texsub.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program texture maps a checkerboard image onto two rectangles. This+   program clamps the texture, if the texture coordinates fall outside 0.0+   and 1.0. If the s key is pressed, a texture subimage is used to alter the+   original texture. If the r key is pressed, the original texture is restored.+-}++import Control.Monad ( when )+import Data.Char ( toLower )+import Data.Bits ( (.&.) )+import Foreign ( newArray )+import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++checkImageSize, subImageSize :: TextureSize2D+checkImageSize = TextureSize2D 64 64+subImageSize   = TextureSize2D 16 16++type Image = PixelData (Color4 GLubyte)++makeCheckImage ::+   TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) -> IO Image+makeCheckImage (TextureSize2D w h) n f =+   fmap (PixelData RGBA UnsignedByte) $+      newArray [ f c |+                 i <- [ 0 .. w - 1 ],+                 j <- [ 0 .. h - 1 ],+                 let c | (i .&. n) == (j .&. n) = 0+                       | otherwise              = 255 ]++myInit :: IO (TextureObject, Image, Image)+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Flat+   depthFunc $= Just Less++   checkImage <- makeCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255)+   subImage   <- makeCheckImage subImageSize   0x4 (\c -> Color4 c 0 0 255)+   rowAlignment Unpack $= 1++   [texName] <- genObjectNames 1+   textureBinding Texture2D $= Just texName++   textureWrapMode Texture2D S $= (Repeated, Repeat)+   textureWrapMode Texture2D T $= (Repeated, Repeat)+   textureFilter Texture2D $= ((Nearest, Nothing), Nearest)+   texImage2D Nothing NoProxy 0  RGBA' checkImageSize 0 checkImage+   return (texName, checkImage, subImage)++display :: TextureObject -> DisplayCallback+display texName = do+   clear [ ColorBuffer, DepthBuffer ]+   texture Texture2D $= Enabled+   textureFunction $= Decal+   textureBinding Texture2D $= Just texName++   -- resolve overloading, not needed in "real" programs+   let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()+       vertex3f = vertex :: Vertex3 GLfloat -> IO ()+   renderPrimitive Quads $ do+      texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0)    (-1.0)   0.0     )+      texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0)      1.0    0.0     )+      texCoord2f (TexCoord2 1 1); vertex3f (Vertex3   0.0       1.0    0.0     )+      texCoord2f (TexCoord2 1 0); vertex3f (Vertex3   0.0     (-1.0)   0.0     )++      texCoord2f (TexCoord2 0 0); vertex3f (Vertex3   1.0     (-1.0)   0.0     )+      texCoord2f (TexCoord2 0 1); vertex3f (Vertex3   1.0       1.0    0.0     )+      texCoord2f (TexCoord2 1 1); vertex3f (Vertex3   2.41421   1.0  (-1.41421))+      texCoord2f (TexCoord2 1 0); vertex3f (Vertex3   2.41421 (-1.0) (-1.41421))+   flush+   texture Texture2D $= Disabled++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective 60 (fromIntegral w / fromIntegral h) 1 30+   matrixMode $= Modelview 0+   loadIdentity+   translate (Vector3 0 0 (-3.6 :: GLfloat))++keyboard :: TextureObject -> Image -> Image -> KeyboardMouseCallback+keyboard texName checkImage subImage (Char c) Down _ _ = case toLower c of+   's' -> do+      textureBinding Texture2D $= Just texName+      texSubImage2D Nothing 0 (TexturePosition2D 12 44) subImageSize subImage+      postRedisplay Nothing+   'r' -> do+      textureBinding Texture2D $= Just texName+      texImage2D Nothing NoProxy 0 RGBA' checkImageSize 0 checkImage+      postRedisplay Nothing+   '\27' -> exitWith ExitSuccess+   _ -> return ()+keyboard _ _ _ _ _ _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 250 250+   initialWindowPosition $= Position 100 100+   createWindow progName+   -- we have to do this *after* createWindow, otherwise we have no OpenGL context+   version <- get (majorMinor glVersion)+   when (version == (1,0)) $ do+      putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0."+      putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions,"+      putStrLn "you may be able to modify this program to make it run."+      exitFailure+   (texName, checkImage, subImage) <- myInit+   displayCallback $= display texName+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboard texName checkImage subImage)+   mainLoop
+ examples/RedBook/Texture3D.hs view
@@ -0,0 +1,94 @@+{-+   Texture3D.hs  (adapted from texture3d.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates using a three-dimensional texture. It creates+   a 3D texture and then renders two rectangles with different texture+   coordinates to obtain different "slices" of the 3D texture.+-}++import Control.Monad ( unless )+import Foreign ( withArray )+import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++-- Create checkerboard image+imageSize :: TextureSize3D+imageSize = TextureSize3D 16 16 16++withImage :: (PixelData (Color3 GLubyte) -> IO ()) -> IO ()+withImage act =+   withArray [ Color3 (s * 17) (t * 17) (r * 17) |+               r <- [ 0 .. fromIntegral d - 1 ],+               t <- [ 0 .. fromIntegral h - 1 ],+               s <- [ 0 .. fromIntegral w - 1 ] ] $+   act . PixelData RGB UnsignedByte+   where (TextureSize3D w h d) = imageSize++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Flat+   depthFunc $= Just Less+   rowAlignment Unpack $= 1++   [texName] <- genObjectNames 1+   textureBinding Texture3D $= Just texName+   textureWrapMode Texture3D S $= (Repeated, Clamp)+   textureWrapMode Texture3D T $= (Repeated, Clamp)+   textureWrapMode Texture3D R $= (Repeated, Clamp)+   textureFilter Texture3D $= ((Nearest, Nothing), Nearest)+   withImage $ texImage3D NoProxy 0  RGB' imageSize 0+   texture Texture3D $= Enabled++display :: DisplayCallback+display = do+   clear [ ColorBuffer, DepthBuffer ]+   -- resolve overloading, not needed in "real" programs+   let texCoord3f = texCoord :: TexCoord3 GLfloat -> IO ()+       vertex3f = vertex :: Vertex3 GLfloat -> IO ()+   renderPrimitive Quads $ do+      texCoord3f (TexCoord3 0 0 0); vertex3f (Vertex3 (-2.25) (-1) 0)+      texCoord3f (TexCoord3 0 1 0); vertex3f (Vertex3 (-2.25)   1  0)+      texCoord3f (TexCoord3 1 1 1); vertex3f (Vertex3 (-0.25)   1  0)+      texCoord3f (TexCoord3 1 0 1); vertex3f (Vertex3 (-0.25) (-1) 0)++      texCoord3f (TexCoord3 0 0 1); vertex3f (Vertex3   0.25  (-1) 0)+      texCoord3f (TexCoord3 0 1 1); vertex3f (Vertex3   0.25    1  0)+      texCoord3f (TexCoord3 1 1 0); vertex3f (Vertex3   2.25    1  0)+      texCoord3f (TexCoord3 1 0 0); vertex3f (Vertex3   2.25  (-1) 0)+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective 60 (fromIntegral w / fromIntegral h) 1 30+   matrixMode $= Modelview 0+   loadIdentity+   translate (Vector3 0 0 (-4 :: GLfloat))++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 250 250+   initialWindowPosition $= Position 100 100+   createWindow progName+   -- we have to do this *after* createWindow, otherwise we have no OpenGL context+   exts <- get glExtensions+   unless ("GL_EXT_texture3D" `elem` exts) $ do+      putStrLn "Sorry, this demo requires the GL_EXT_texture3D extension."+      exitFailure+   myInit+   reshapeCallback $= Just reshape+   displayCallback $= display+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/TextureSurf.hs view
@@ -0,0 +1,99 @@+{-+   TextureSurf.hs (adapted from texturesurf.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program uses evaluators to generate a curved surface and automatically+   generated texture coordinates.+-}++import Data.List ( transpose )+import Foreign ( withArray )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++ctrlPoints :: [[Vertex3 GLfloat]]+ctrlPoints = [+   [ Vertex3 (-1.5) (-1.5)   4.0,  Vertex3 (-0.5) (-1.5)   2.0,+     Vertex3   0.5  (-1.5) (-1.0), Vertex3   1.5  (-1.5)   2.0 ],+   [ Vertex3 (-1.5) (-0.5)   1.0,  Vertex3 (-0.5) (-0.5)   3.0,+     Vertex3   0.5  (-0.5)   0.0,  Vertex3   1.5  (-0.5) (-1.0) ],+   [ Vertex3 (-1.5)   0.5    4.0,  Vertex3 (-0.5)   0.5    0.0,+     Vertex3   0.5    0.5    3.0,  Vertex3   1.5    0.5    4.0 ],+   [ Vertex3 (-1.5)   1.5  (-2.0), Vertex3 (-0.5)   1.5  (-2.0),+     Vertex3   0.5    1.5    0.0,  Vertex3   1.5    1.5  (-1.0) ]]++texPts :: [[TexCoord2 GLfloat]]+texPts = [+   [ TexCoord2 0 0, TexCoord2 0 1 ],+   [ TexCoord2 1 0, TexCoord2 1 1 ]]++display :: DisplayCallback+display = do+   clear [ ColorBuffer, DepthBuffer ]+   color (Color3 1 1 1 :: Color3 GLfloat)+   evalMesh2 Fill (0, 20) (0, 20)+   flush++imageSize :: TextureSize2D+imageSize = TextureSize2D 64 64++withImage :: (PixelData (Color3 GLubyte) -> IO ()) -> IO ()+withImage act =+   withArray [ Color3 (s (sin ti)) (s (cos (2 * tj))) (s (cos (ti + tj))) |+               i <- [ 0 .. fromIntegral w - 1 ],+               let ti = 2 * pi * i / fromIntegral w,+               j <- [ 0 .. fromIntegral h - 1 ],+               let tj = 2 * pi * j / fromIntegral h ] $+   act . PixelData RGB UnsignedByte+   where (TextureSize2D w h) = imageSize+         s :: Double -> GLubyte+         s x = truncate (127 * (1 + x))++myInit :: IO ()+myInit = do+   m <- newMap2 (0, 1) (0, 1) (transpose ctrlPoints)+   map2 $= Just (m :: GLmap2 Vertex3 GLfloat)+   t <- newMap2 (0, 1) (0, 1) (transpose texPts)+   map2 $= Just (t :: GLmap2 TexCoord2 GLfloat)+   mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat)))+   textureFunction $= Decal+   textureWrapMode Texture2D S $= (Repeated, Repeat)+   textureWrapMode Texture2D T $= (Repeated, Repeat)+   textureFilter Texture2D $= ((Nearest, Nothing), Nearest)+   withImage $ texImage2D Nothing NoProxy 0 RGB' imageSize 0+   texture Texture2D $= Enabled+   depthFunc $= Just Less+   shadeModel $= Flat++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   let wf = fromIntegral w+       hf = fromIntegral h+   if w <= h+      then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0+      else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0+   matrixMode $= Modelview 0+   loadIdentity+   rotate (85 :: GLfloat) (Vector3 1 1 1)++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   displayCallback $= display+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/Torus.hs view
@@ -0,0 +1,93 @@+{-+   Torus.hs (adapted from torus.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates the creation of a display list.+-}++import Data.Char ( toLower )+import Data.IORef ( IORef, newIORef )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++data State = State { spinX, spinY :: IORef GLfloat }++makeState :: IO State+makeState = do+   x <- newIORef 0+   y <- newIORef 0+   return $ State { spinX = x, spinY = y }++torus :: Int -> Int -> IO ()+torus numC numT = do+   let stepC = 2 * pi / fromIntegral numC :: GLfloat+       stepT = 2 * pi / fromIntegral numT+   flip mapM_ [ 0 .. numC - 1 ] $ \i ->+      renderPrimitive QuadStrip $+         flip mapM_ [ 0 .. numT ] $ \j ->+            flip mapM_ [ 1, 0 ] $ \k -> do+               let s = (fromIntegral ((i + k) `mod` numC) + 0.5) * stepC+                   t = (fromIntegral (      j `mod` numT)      ) * stepT+                   x = (1 + 0.1 * cos s) * cos t+                   y = (1 + 0.1 * cos s) * sin t+                   z =      0.1 * sin s+               vertex (Vertex3 x y z)++myInit :: IO DisplayList+myInit = do+   theTorus <- defineNewList Compile $+      torus 8 25+   shadeModel $= Flat+   clearColor $= Color4 0 0 0 0+   return theTorus++display :: State -> DisplayList -> DisplayCallback+display state theTorus = do+   clear [ ColorBuffer ]+   loadIdentity+   lookAt (Vertex3 0 0 10) (Vertex3 0 0 0) (Vector3 0 1 0)+   x <- get (spinX state)+   rotate x (Vector3 1 0 0)+   y <- get (spinY state)+   rotate y (Vector3 0 1 0)+   color (Color3 1 1 (1 :: GLfloat))+   callList theTorus+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective  30 (fromIntegral w / fromIntegral h) 1 100+   matrixMode $= Modelview 0++incSpin :: IORef GLfloat -> IO ()+incSpin spinRef = do+   let wrap n s = if s > n then s - n else s+   spinRef $~ (wrap 360 . (+ 30))+   postRedisplay Nothing++keyboard :: State -> KeyboardMouseCallback+keyboard state (Char c) Down _ _ = case toLower c of+   'x'   -> incSpin (spinX state)+   'y'   -> incSpin (spinY state)+   'i'   -> do spinX state $= 0; spinY state $= 0; postRedisplay Nothing+   '\27' -> exitWith ExitSuccess+   _     -> return ()+keyboard _ _ _ _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 200 200+   createWindow progName+   state <- makeState+   theTorus <- myInit+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboard state)+   displayCallback $= display state theTorus+   mainLoop
+ examples/RedBook/Trim.hs view
@@ -0,0 +1,107 @@+{-+   Trim.hs (adapted from trim.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program draws a NURBS surface in the shape of a symmetrical hill,+   using both a NURBS curve and pwl (piecewise linear) curve to trim part+   of the surface.++   NOTE: This example does NOT demonstrate the final NURBS API, it's currently+   just a test for the internals...+-}++import Foreign.Marshal ( withArray )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++-- The control points of the surface form a small hill and+-- range from -3 to +3 in x, y, and z.+ctlPoints :: [[Vertex3 GLfloat]]+ctlPoints =+   [ [ Vertex3 (2 * u - 3)+               (2 * v - 3)+               (if (u == 1 || u ==2) && (v == 1 || v == 2) then 3 else -3)+     | v <- [ 0 .. 3 ] ]+   | u <- [ 0 .. 3 ]]++myInit :: IO ()+myInit = do+   clearColor $= Color4 0 0 0 0+   materialDiffuse Front $= Color4 0.7 0.7 0.7 1+   materialSpecular Front $= Color4 1 1 1 1+   materialShininess Front $= 100++   lighting $= Enabled+   light (Light 0) $= Enabled+   depthFunc $= Just Less+   autoNormal $= Enabled+   normalize $= Enabled++--------------------------------------------------------------------------------++display :: DisplayCallback+display = do+   let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat]+       edgePt = -- counter clockwise+          [ Vertex2 0 0, Vertex2 1 0, Vertex2 1 1, Vertex2 0 1, Vertex2 0 0 ] :: [Vertex2 GLfloat]+       curvePt = -- clockwise+          [ Vertex2 0.25 0.5, Vertex2 0.25 0.75, Vertex2 0.75 0.75, Vertex2 0.75 0.5 ]  :: [Vertex2 GLfloat]+       curveKnots =+          [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat]+       pwlPt = -- clockwise+          [Vertex2 0.75 0.5, Vertex2 0.5 0.25, Vertex2 0.25 0.5 ] :: [Vertex2 GLfloat]++   clear [ ColorBuffer, DepthBuffer ]+   preservingMatrix $ do+      rotate (330 :: GLfloat) (Vector3 1 0 0)+      scale 0.5 0.5 (0.5 :: GLfloat)++      withNURBSObj () $ \nurbsObj -> do+         setSamplingMethod nurbsObj (PathLength 25)+         setDisplayMode' nurbsObj Fill'+         checkForNURBSError nurbsObj $+            nurbsBeginEndSurface nurbsObj $+               withArray (concat ctlPoints) $ \cBuf ->+                  withArray knots $ \kBuf -> do+                     nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4+                     nurbsBeginEndTrim nurbsObj $+                        withArray edgePt $ \edgePtBuf ->+                           pwlCurve nurbsObj 5 edgePtBuf 2+                     nurbsBeginEndTrim nurbsObj $ do+                        withArray curveKnots $ \curveKnotsBuf ->+                           withArray curvePt $ \curvePtBuf ->+                              trimmingCurve nurbsObj 8 curveKnotsBuf 2 curvePtBuf 4+                        withArray pwlPt $ \pwlPtBuf ->+                           pwlCurve nurbsObj 3 pwlPtBuf 2++   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective 45 (fromIntegral w / fromIntegral h) 3 8+   matrixMode $= Modelview 0+   loadIdentity+   translate (Vector3 0 0 (-5 :: GLfloat))++keyboard :: KeyboardMouseCallback+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++-- Main Loop+main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   myInit+   reshapeCallback $= Just reshape+   displayCallback $= display+   keyboardMouseCallback $= Just keyboard+   mainLoop
+ examples/RedBook/UnProject.hs view
@@ -0,0 +1,54 @@+{-+   UnProject.hs (adapted from unproject.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   When the left mouse button is pressed, this program reads the mouse+   position and determines two 3D points from which it was transformed.+   Very little is displayed.+-}++import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++display :: DisplayCallback+display = do+   clear [ ColorBuffer ]+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective 45 (fromIntegral w / fromIntegral h) 1 100+   matrixMode $= Modelview 0+   loadIdentity++keyboardMouse :: KeyboardMouseCallback+keyboardMouse (MouseButton LeftButton)  Down _ (Position x y) = do+   v@(_, Size _ h) <- get viewport+   mvMatrix <- get (matrix (Just (Modelview 0))) :: IO (GLmatrix GLdouble)+   projMatrix <- get (matrix (Just Projection)) :: IO (GLmatrix GLdouble)+   let realY = h - y -1+   putStrLn ("Coordinates at cursor are (" ++ show x ++", " ++ show realY ++ ")")+   w0 <- unProject (Vertex3 (fromIntegral x) (fromIntegral realY) 0) mvMatrix projMatrix v+   putStrLn ("World coords at z=0.0 are " ++ show w0)+   w1 <- unProject (Vertex3 (fromIntegral x) (fromIntegral realY) 1) mvMatrix projMatrix v+   putStrLn ("World coords at z=1.0 are " ++ show w1)+keyboardMouse (MouseButton RightButton) Down _ _ = exitWith ExitSuccess+keyboardMouse (Char '\27')              Down _ _ = exitWith ExitSuccess+keyboardMouse _                         _    _ _ = return ()++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 500 500+   initialWindowPosition $= Position 100 100+   createWindow progName+   displayCallback $= display+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboardMouse+   mainLoop
+ examples/RedBook/VArray.hs view
@@ -0,0 +1,141 @@+{-+   VArray.hs (adapted from varray.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program demonstrates vertex arrays.+-}++import Control.Monad ( when )+import Data.IORef ( IORef, newIORef )+import Foreign ( Ptr, newArray )+import System.Exit ( exitFailure, exitWith, ExitCode(..) )+import Graphics.UI.GLUT++data SetupMethod = Pointer | Interleaved+   deriving ( Eq, Bounded, Enum )++data DerefMethod = DrawArray | ArrayElement | DrawElements+   deriving ( Eq, Bounded, Enum )++makeVertices :: IO (Ptr (Vertex2 GLint))+makeVertices = newArray [+   Vertex2  25  25,+   Vertex2 100 325,+   Vertex2 175  25,+   Vertex2 175 325,+   Vertex2 250  25,+   Vertex2 325 325 ]++makeColors :: IO (Ptr (Color3 GLfloat))+makeColors = newArray [+   Color3 1.0  0.2  0.2,+   Color3 0.2  0.2  1.0,+   Color3 0.8  1.0  0.2,+   Color3 0.75 0.75 0.75,+   Color3 0.35 0.35 0.35,+   Color3 0.5  0.5  0.5 ]++makeIntertwined :: IO (Ptr GLfloat)+makeIntertwined = newArray [+   1.0, 0.2, 1.0, 100.0, 100.0, 0.0,+   1.0, 0.2, 0.2,   0.0, 200.0, 0.0,+   1.0, 1.0, 0.2, 100.0, 300.0, 0.0,+   0.2, 1.0, 0.2, 200.0, 300.0, 0.0,+   0.2, 1.0, 1.0, 300.0, 200.0, 0.0,+   0.2, 0.2, 1.0, 200.0, 100.0, 0.0 ]++makeIndices :: IO (Ptr GLuint)+makeIndices = newArray [ 0, 1, 3, 4 ]++data State = State {+   vertices    :: Ptr (Vertex2 GLint),+   colors      :: Ptr (Color3 GLfloat),+   intertwined :: Ptr GLfloat,+   indices     :: Ptr GLuint,+   setupMethod :: IORef SetupMethod,+   derefMethod :: IORef DerefMethod }++makeState :: IO State+makeState = do+   v <- makeVertices+   c <- makeColors+   i <- makeIntertwined+   n <- makeIndices+   s <- newIORef Pointer+   d <- newIORef DrawArray+   return $ State { vertices = v, colors = c, intertwined = i,+                    indices = n, setupMethod = s, derefMethod = d }++setup :: State -> IO ()+setup state = do+   s <- get (setupMethod state)+   case s of+      Pointer -> do+         clientState VertexArray $= Enabled+         clientState ColorArray $= Enabled+         arrayPointer VertexArray $= VertexArrayDescriptor 2 Int 0 (vertices state)+         arrayPointer ColorArray $= VertexArrayDescriptor 3 Float 0 (colors state)+      Interleaved ->+         interleavedArrays C3fV3f 0 (intertwined state)++myInit :: State -> IO ()+myInit state = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Smooth+   setup state++display :: State -> DisplayCallback+display state = do+   clear [ ColorBuffer ]+   d <- get (derefMethod state)+   case d of+      DrawArray    -> drawArrays Triangles 0 6+      ArrayElement -> renderPrimitive Triangles $ mapM_ arrayElement [ 2, 3, 5 ]+      DrawElements -> drawElements Polygon 4 UnsignedInt (indices state)+   flush++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   ortho2D 0 (fromIntegral w) 0 (fromIntegral h)+   -- the following line is not in the original example, but it's good style...+   matrixMode $= Modelview 0++keyboardMouse :: State -> KeyboardMouseCallback+keyboardMouse state (MouseButton LeftButton) Down _ _ = do+   setupMethod state $~ nextValue+   setup state+   postRedisplay Nothing+keyboardMouse state (MouseButton _) Down _ _ = do+   derefMethod state $~ nextValue+   postRedisplay Nothing+keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess+keyboardMouse _ _ _ _ _ = return ()++nextValue :: (Eq a, Bounded a, Enum a) => a -> a+nextValue x = if x == maxBound then minBound else succ x++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode ]+   initialWindowSize $= Size 350 350+   initialWindowPosition $= Position 100 100+   createWindow progName+   -- we have to do this *after* createWindow, otherwise we have no OpenGL context+   version <- get (majorMinor glVersion)+   when (version == (1,0)) $ do+      putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0."+      putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions,"+      putStrLn "you may be able to modify this program to make it run."+      exitFailure+   state <- makeState+   myInit state+   displayCallback $= display state+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just (keyboardMouse state)+   mainLoop
+ examples/RedBook/Wrap.hs view
@@ -0,0 +1,114 @@+{-+   Wrap.hs  (adapted from wrap.c which is (c) Silicon Graphics, Inc)+   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This program texture maps a checkerboard image onto two rectangles. This+   program demonstrates the wrapping modes, if the texture coordinates fall+   outside 0.0 and 1.0. Interaction: Pressing the 's' and 'S' keys switch the+   wrapping between clamping and repeating for the s parameter. The 't' and 'T'+   keys control the wrapping for the t parameter.++   Texture objects are only used when GL_EXT_texture_object is supported.+-}++import Control.Monad ( when )+import Data.Maybe ( isJust, listToMaybe )+import Data.Bits ( (.&.) )+import Foreign ( withArray )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import Graphics.UI.GLUT++-- Create checkerboard image+checkImageSize :: TextureSize2D+checkImageSize = TextureSize2D 64 64++withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte))+               -> (PixelData (Color4 GLubyte) -> IO ()) -> IO ()+withCheckImage (TextureSize2D w h) n f act =+   withArray [ f c |+               i <- [ 0 .. w - 1 ],+               j <- [ 0 .. h - 1 ],+               let c | (i .&. n) == (j .&. n) = 0+                     | otherwise              = 255 ] $+   act. PixelData RGBA UnsignedByte++myInit :: IO (Maybe TextureObject)+myInit = do+   clearColor $= Color4 0 0 0 0+   shadeModel $= Flat+   depthFunc $= Just Less+   rowAlignment Unpack $= 1++   exts <- get glExtensions+   mbTexName <- if "GL_EXT_texture_object" `elem` exts+                   then fmap listToMaybe $ genObjectNames 1+                   else return Nothing+   when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName++   textureWrapMode Texture2D S $= (Repeated, Repeat)+   textureWrapMode Texture2D T $= (Repeated, Repeat)+   textureFilter Texture2D $= ((Nearest, Nothing), Nearest)+   withCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) $+      texImage2D Nothing NoProxy 0  RGBA' checkImageSize 0+   return mbTexName++display ::  Maybe TextureObject -> DisplayCallback+display mbTexName = do+   clear [ ColorBuffer, DepthBuffer ]+   texture Texture2D $= Enabled+   textureFunction $= Decal+   when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName++   -- resolve overloading, not needed in "real" programs+   let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()+       vertex3f = vertex :: Vertex3 GLfloat -> IO ()+   renderPrimitive Quads $ do+      texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0)    (-1.0)   0.0     )+      texCoord2f (TexCoord2 0 3); vertex3f (Vertex3 (-2.0)      1.0    0.0     )+      texCoord2f (TexCoord2 3 3); vertex3f (Vertex3   0.0       1.0    0.0     )+      texCoord2f (TexCoord2 3 0); vertex3f (Vertex3   0.0     (-1.0)   0.0     )++      texCoord2f (TexCoord2 0 0); vertex3f (Vertex3   1.0     (-1.0)   0.0     )+      texCoord2f (TexCoord2 0 3); vertex3f (Vertex3   1.0       1.0    0.0     )+      texCoord2f (TexCoord2 3 3); vertex3f (Vertex3   2.41421   1.0  (-1.41421))+      texCoord2f (TexCoord2 3 0); vertex3f (Vertex3   2.41421 (-1.0) (-1.41421))+   flush+   texture Texture2D $= Disabled++reshape :: ReshapeCallback+reshape size@(Size w h) = do+   viewport $= (Position 0 0, size)+   matrixMode $= Projection+   loadIdentity+   perspective 60 (fromIntegral w / fromIntegral h) 1 30+   matrixMode $= Modelview 0+   loadIdentity+   translate (Vector3 0 0 (-3.6 :: GLfloat))++keyboard :: KeyboardMouseCallback+keyboard (Char 's'  ) Down _ _ = setClamping S Clamp+keyboard (Char 'S'  ) Down _ _ = setClamping S Repeat+keyboard (Char 't'  ) Down _ _ = setClamping T Clamp+keyboard (Char 'T'  ) Down _ _ = setClamping T Repeat+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess+keyboard _            _    _ _ = return ()++setClamping :: TextureCoordName -> Clamping -> IO ()+setClamping coord clamp = do+   textureWrapMode Texture2D coord $= (Repeated, clamp);+   postRedisplay Nothing++main :: IO ()+main = do+   (progName, _args) <- getArgsAndInitialize+   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]+   initialWindowSize $= Size 250 250+   initialWindowPosition $= Position 100 100+   createWindow progName+   mbTexName <- myInit+   displayCallback $= display mbTexName+   reshapeCallback $= Just reshape+   keyboardMouseCallback $= Just keyboard+   mainLoop