diff --git a/GLUT.cabal b/GLUT.cabal --- a/GLUT.cabal +++ b/GLUT.cabal @@ -1,5 +1,5 @@ name: GLUT -version: 2.1.2.0 +version: 2.1.2.1 license: BSD3 license-file: LICENSE maintainer: Sven Panne @@ -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 diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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. diff --git a/aclocal.m4 b/aclocal.m4 new file mode 100644 --- /dev/null +++ b/aclocal.m4 @@ -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(<>, translit(htype_$1, [a-z *], [A-Z_P]))dnl +dnl The cache variable name. +define(<>, translit(fptools_cv_htype_$1, [ *], [_p]))dnl +define(<>, 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 +#include + +#if HAVE_SYS_TYPES_H +# include +#endif + +#if HAVE_UNISTD_H +# include +#endif + +#if HAVE_SYS_STAT_H +# include +#endif + +#if HAVE_FCNTL_H +# include +#endif + +#if HAVE_SIGNAL_H +# include +#endif + +#if HAVE_TIME_H +# include +#endif + +#if HAVE_TERMIOS_H +# include +#endif + +#if HAVE_STRING_H +# include +#endif + +#if HAVE_CTYPE_H +# include +#endif + +#if defined(HAVE_GL_GL_H) +# include +#elif defined(HAVE_OPENGL_GL_H) +# include +#endif + +#if defined(HAVE_AL_AL_H) +# include +#elif defined(HAVE_OPENAL_AL_H) +# include +#endif + +#if defined(HAVE_AL_ALC_H) +# include +#elif defined(HAVE_OPENAL_ALC_H) +# include +#endif + +#if HAVE_SYS_RESOURCE_H +# include +#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 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 ], [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 ]], [[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 ], [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 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 +#endif +#if HAVE_GL_GLUT_H +#include +#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 diff --git a/configure b/configure --- a/configure +++ b/configure @@ -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 . # @@ -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'`\\" diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -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]) diff --git a/examples/BOGLGP/Chapter01/OnYourOwn1.hs b/examples/BOGLGP/Chapter01/OnYourOwn1.hs new file mode 100644 --- /dev/null +++ b/examples/BOGLGP/Chapter01/OnYourOwn1.hs @@ -0,0 +1,111 @@ +{- + OnYourOwn1.hs (adapted from Simple.cpp which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2004-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( unless ) +import 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 diff --git a/examples/BOGLGP/Chapter01/Simple.hs b/examples/BOGLGP/Chapter01/Simple.hs new file mode 100644 --- /dev/null +++ b/examples/BOGLGP/Chapter01/Simple.hs @@ -0,0 +1,111 @@ +{- + Simple.hs (adapted from Simple.cpp which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2004-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( unless ) +import 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 diff --git a/examples/BOGLGP/Chapter02/OnYourOwn1.hs b/examples/BOGLGP/Chapter02/OnYourOwn1.hs new file mode 100644 --- /dev/null +++ b/examples/BOGLGP/Chapter02/OnYourOwn1.hs @@ -0,0 +1,230 @@ +{- + OnYourOwn1.hs (adapted from OpenGLApplication which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2004-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( when, unless ) +import Data.IORef ( IORef, newIORef ) +import 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) diff --git a/examples/BOGLGP/Chapter02/OpenGLApplication.hs b/examples/BOGLGP/Chapter02/OpenGLApplication.hs new file mode 100644 --- /dev/null +++ b/examples/BOGLGP/Chapter02/OpenGLApplication.hs @@ -0,0 +1,230 @@ +{- + OpenGLApplication.hs (adapted from OpenGLApplication which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2004-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( when, unless ) +import Data.IORef ( IORef, newIORef ) +import 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) diff --git a/examples/BOGLGP/Chapter03/Lines.hs b/examples/BOGLGP/Chapter03/Lines.hs new file mode 100644 --- /dev/null +++ b/examples/BOGLGP/Chapter03/Lines.hs @@ -0,0 +1,210 @@ +{- + Lines.hs (adapted from Lines which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2004-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( when, unless, 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 diff --git a/examples/BOGLGP/Chapter03/OnYourOwn1.hs b/examples/BOGLGP/Chapter03/OnYourOwn1.hs new file mode 100644 --- /dev/null +++ b/examples/BOGLGP/Chapter03/OnYourOwn1.hs @@ -0,0 +1,217 @@ +{- + OnYourOwn1.hs (adapted from OnYourOwn1 which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( when, unless ) +import Data.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) diff --git a/examples/BOGLGP/Chapter03/Points.hs b/examples/BOGLGP/Chapter03/Points.hs new file mode 100644 --- /dev/null +++ b/examples/BOGLGP/Chapter03/Points.hs @@ -0,0 +1,196 @@ +{- + Points.hs (adapted from Points which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2004-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( when, unless, 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 ] diff --git a/examples/BOGLGP/Chapter03/Polygons.hs b/examples/BOGLGP/Chapter03/Polygons.hs new file mode 100644 --- /dev/null +++ b/examples/BOGLGP/Chapter03/Polygons.hs @@ -0,0 +1,230 @@ +{- + Polygons.hs (adapted from Polygons which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2004-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( when, unless ) +import Data.IORef ( IORef, newIORef ) +import 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)) diff --git a/examples/BOGLGP/Chapter03/TrianglesQuads.hs b/examples/BOGLGP/Chapter03/TrianglesQuads.hs new file mode 100644 --- /dev/null +++ b/examples/BOGLGP/Chapter03/TrianglesQuads.hs @@ -0,0 +1,294 @@ +{- + TrianglesQuads.hs (adapted from TrianglesQuads which is (c) 2004 Astle/Hawkins) + Copyright (c) Sven Panne 2004-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( when, unless ) +import Data.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) diff --git a/examples/Misc/ARBOcclude.hs b/examples/Misc/ARBOcclude.hs new file mode 100644 --- /dev/null +++ b/examples/Misc/ARBOcclude.hs @@ -0,0 +1,193 @@ +{- + ARBOcclude.hs (adapted from arbocclude.c which is (c) Brian Paul) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( unless, 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 diff --git a/examples/Misc/ExtractContours.hs b/examples/Misc/ExtractContours.hs new file mode 100644 --- /dev/null +++ b/examples/Misc/ExtractContours.hs @@ -0,0 +1,117 @@ +{- + ExtractContours.hs (adapted from tess.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates 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 diff --git a/examples/Misc/Gears.hs b/examples/Misc/Gears.hs new file mode 100644 --- /dev/null +++ b/examples/Misc/Gears.hs @@ -0,0 +1,301 @@ +{- + Gears.hs (adapted from gears.c which is (c) Brian Paul) + Copyright (c) Shawn P. Garbett 2004 + Further hacked by Sven Panne + 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 diff --git a/examples/Misc/Pitfall14.hs b/examples/Misc/Pitfall14.hs new file mode 100644 --- /dev/null +++ b/examples/Misc/Pitfall14.hs @@ -0,0 +1,33 @@ +{- + Pitfall14 + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates 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 diff --git a/examples/Misc/Triangulate.hs b/examples/Misc/Triangulate.hs new file mode 100644 --- /dev/null +++ b/examples/Misc/Triangulate.hs @@ -0,0 +1,120 @@ +{- + Triangulate.hs (adapted from tess.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates polygon 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 diff --git a/examples/OrangeBook/3Dlabs-License.txt b/examples/OrangeBook/3Dlabs-License.txt new file mode 100644 --- /dev/null +++ b/examples/OrangeBook/3Dlabs-License.txt @@ -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. + + diff --git a/examples/OrangeBook/ogl2brick/Brick.frag b/examples/OrangeBook/ogl2brick/Brick.frag new file mode 100644 --- /dev/null +++ b/examples/OrangeBook/ogl2brick/Brick.frag @@ -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); +} diff --git a/examples/OrangeBook/ogl2brick/Brick.hs b/examples/OrangeBook/ogl2brick/Brick.hs new file mode 100644 --- /dev/null +++ b/examples/OrangeBook/ogl2brick/Brick.hs @@ -0,0 +1,377 @@ +{- + Brick.hs (adapted from ogl2brick.c which is (c) 3Dlabs Inc. Ltd.) + Copyright (c) Sven Panne 2006 + 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, - Quit", + "t - Toggle among models to render", + "? - Help", + " - reset zoom and rotation", + " or - stop rotation", + "<+>, <-> or - zoom model", + " or - 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 diff --git a/examples/OrangeBook/ogl2brick/Brick.vert b/examples/OrangeBook/ogl2brick/Brick.vert new file mode 100644 --- /dev/null +++ b/examples/OrangeBook/ogl2brick/Brick.vert @@ -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(); +} diff --git a/examples/RedBook/00-README b/examples/RedBook/00-README new file mode 100644 --- /dev/null +++ b/examples/RedBook/00-README @@ -0,0 +1,189 @@ +This file lists the programs that are referenced in the OpenGL Programming +Guide, Fourth Edition, by chapter. For each program, the version of OpenGL +that is required is listed with the program. + +Chapter 1: Introduction to OpenGL + + Hello.hs (1.0) + Double.hs (1.0) + +Chapter 2: State Management and Drawing Geometric Objects + + Lines.hs (1.0) + Polys.hs (1.0) + VArray.hs (1.1) + MVArray.hs (1.4) + +Chapter 3: Viewing + + Cube.hs (1.0) + Model.hs (1.0) + Clip.hs (1.0) + Planet.hs (1.0) + Robot.hs (1.0) + UnProject.hs (1.1) + +Chapter 4: Color + + Smooth.hs (1.0) + +Chapter 5: Lighting + + Light.hs (1.0) + MoveLight.hs (1.0) + Material.hs (1.0) + ColorMat.hs (1.1) + Scene.hs (1.0) + +Chapter 6: Blending, Antialiasing, Fog, and Polygon Offset + + BlendEqn.hs (1.3 or ARB_imaging_subset) + Alpha.hs (1.0) + Alpha3D.hs (1.1) + AARGB.hs (1.1) + AAIndex.hs (1.1) + Multisamp.hs (1.3) + Fog.hs (1.0) + FogIndex.hs (1.0) + FogCoord.hs (1.4) + PointP.hs (1.4) + PolyOff.hs (1.1) + +Chapter 7: Display Lists + + Torus.hs (1.0) + DList.hs (1.0) + Stroke.hs (1.0) + +Chapter 8: Drawing Pixels, Bitmaps, Fonts, and Images + + DrawF.hs (1.0) + Font.hs (1.0) + Image.hs (1.1) + ColorTable.hs (ARB_imaging_subset) + Convolution.hs (ARB_imaging_subset) + ColorMatrix.hs (ARB_imaging_subset) + Histogram.hs (ARB_imaging_subset) + Minmax.hs (ARB_imaging_subset) + +Chapter 9: Texture Mapping + + Checker.hs (1.0) + TexSub.hs (1.1) + Texture3D.hs (1.2) + Mipmap.hs (1.0) + TexBind.hs (1.1) + TexGen.hs (1.1) + CubeMap.hs (1.3) + MultiTex.hs (1.3 or ARB_multitexture) + Combiner.hs (1.3) + ShadowMap.hs (1.4) + Wrap.hs (1.0) + TexProx.hs (1.1) + +Chapter 10: The Framebuffer + + Stencil.hs (1.0) + AccPersp.hs (1.0) + AccAnti.hs (1.0) + DOF.hs (1.0) + +Chapter 11: Tessellators and Quadrics + + Tess.hs (1.1) + TessWind.hs (1.1) + Quadric.hs (1.1) + +Chapter 12: Evaluators and NURBS + + BezCurve.hs (1.1) + BezSurf.hs (1.1) + BezMesh.hs (1.1) + TextureSurf.hs (1.1) + Surface.hs (1.1) + SurfPoints.hs (1.2) + Trim.hs (1.1) + +Chapter 13: Selection and Feedback + + Select.hs (1.1) + PickSquare.hs (1.0) + PickDepth.hs (1.0) + Feedback.hs (1.0) + +Chapter 14: Now That You Know + + + +Color Plates: + + Teapots.hs (1.1) + +Some remarks regarding the style of the programs: + +To ease comparisons, the Haskell programs in this directory try to stay as +close to the original examples in C as possible. Consequently, they should +not be considered as examples for the best way to implement things in +Haskell. + +The Haskell OpenGL binding uses overloading quite extensively, which makes +its use quite flexible, e.g.: + + class Vertex a where + vertex :: a -> IO () + vertexv :: Ptr a -> IO () + +This single class subsumes all 24 vertex specification calls in OpenGL's C +binding, i.e. glVertex{234}{sifd}[v](), with the help of the following +class and instances: + + class VertexComponent a -- an opaque class + + VertexComponent GLshort + VertexComponent GLint + VertexComponent GLfloat + VertexComponent GLdouble + + VertexComponent a => Vertex (Vertex2 a) + VertexComponent a => Vertex (Vertex3 a) + VertexComponent a => Vertex (Vertex4 a) + +There is a small inconvenience with this when used in "toy" programs: +Haskell's numeric literals are overloaded, too, so the programmer's help is +needed to disambiguate the type of expressions like: + + vertex (Vertex3 0 0 1) + +Let's assume we mean the equivalent of glVertex3f() here. One can either +use an explicitly typed helper function: + + let vertex3f = vertex :: Vertex3 GLfloat -> IO () + in vertex3f (Vertex3 0 0 1) + +This comes in handy when there are a lot of uses of vertex3f. An +alternative is to use a type annotation for the literal: + + vertex (Vertex3 0 0 (1 :: GLfloat)) + +or a type annotation for the vertex: + + vertex (Vertex3 0 0 1 :: Vertex3 GLfloat) + +This is largely a matter of taste and normally not a problem in "real" +programs with type signatures for functions. + +Sometimes different callbacks need to share some state, which is done via +global variables in the C examples. To achieve a unified presentation, all +Haskell examples use a `State' type for this purpose, which collects the +different parts of the global state, i.e. one or more IORefs. There are +alternatives for modeling this, which should be considered in own programs, +depending on the use cases: + + * Separate IORefs: This makes it explicit which parts of the program need + which parts of the state. + + * A single IORef/MVar containing all the state: This enables one to change + the whole state atomically, which is often quite handy in multithreaded + programs. + + * A custom monad: This can hide all the state threading behind the scenes. diff --git a/examples/RedBook/AAIndex.hs b/examples/RedBook/AAIndex.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/AAIndex.hs @@ -0,0 +1,104 @@ +{- + AAIndex.hs (adapted from aaindex.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws shows how to draw anti-aliased lines in color index + mode. It draws two diagonal lines to form an X; when 'r' is typed in the + window, the lines are rotated in opposite directions. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { rotAngle :: IORef Int } + +makeState :: IO State +makeState = do + r <- newIORef 0 + return $ State { rotAngle = r } + +rampSize, ramp1Start, ramp2Start :: GLint +rampSize = 16 +ramp1Start = 32 +ramp2Start = 48 + +-- Initialize antialiasing for color index mode, including loading a green color +-- ramp starting at ramp1Start, and a blue color ramp starting at ramp2Start. +-- The ramps must be a multiple of 16. +myInit :: IO () +myInit = do + flip mapM_ [ 0 .. rampSize - 1 ] $ \i -> do + let shade = fromIntegral i / fromIntegral rampSize + colorMapEntry (Index1 (ramp1Start + i)) $= Color3 0 shade 0 + colorMapEntry (Index1 (ramp2Start + i)) $= Color3 0 0 shade + + lineSmooth $= Enabled + hint LineSmooth $= DontCare + lineWidth $= 1.5 + + clearIndex $= Index1 (fromIntegral ramp1Start) + +-- Draw 2 diagonal lines to form an X +display :: State -> DisplayCallback +display state = do + r <- get (rotAngle state) + clear [ ColorBuffer ] + + -- resolve overloading, not needed in "real" programs + let vertex2f = vertex :: Vertex2 GLfloat -> IO () + + index (Index1 ramp1Start) + preservingMatrix $ do + rotate (-(fromIntegral r :: GLfloat)) (Vector3 0 0 0.1) + renderPrimitive Lines $ do + vertex2f (Vertex2 (-0.5) 0.5) + vertex2f (Vertex2 0.5 (-0.5)) + + index (Index1 ramp2Start) + preservingMatrix $ do + rotate (fromIntegral r :: GLfloat) (Vector3 0 0 0.1) + renderPrimitive Lines $ do + vertex2f (Vertex2 0.5 0.5) + vertex2f (Vertex2 (-0.5) (-0.5)) + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D (-1) 1 (-1*hf/wf) (1*hf/wf) + else ortho2D (-1*wf/hf) (1*wf/hf) (-1) 1 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'r' -> do rotAngle state $~ ((`mod` 360) . (+ 30)); postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +-- Main Loop +-- Open window with initial window size, title bar, +-- color index display mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, IndexMode ] + initialWindowSize $= Size 200 200 + createWindow progName + state <- makeState + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state + mainLoop diff --git a/examples/RedBook/AARGB.hs b/examples/RedBook/AARGB.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/AARGB.hs @@ -0,0 +1,104 @@ +{- + AARGB.hs (adapted from aargb.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws shows how to draw anti-aliased lines. It draws two + diagonal lines to form an X; when 'r' is typed in the window, the lines are + rotated in opposite directions. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { rotAngle :: IORef Int } + +makeState :: IO State +makeState = do + r <- newIORef 0 + return $ State { rotAngle = r } + +-- Initialize antialiasing for RGBA mode, including alpha blending, hint, and +-- line width. Print out implementation specific info on line width granularity +-- and width. +myInit :: IO () +myInit = do + g <- get smoothLineWidthGranularity + putStrLn ("smoothLineWidthGranularity is " ++ show g) + + r <- get smoothLineWidthRange + putStrLn ("smoothLineWidthRange is " ++ show r) + + lineSmooth $= Enabled + + blend $= Enabled + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + hint LineSmooth $= DontCare + lineWidth $= 1.5 + + clearColor $= Color4 0 0 0 0 + +-- Draw 2 diagonal lines to form an X +display :: State -> DisplayCallback +display state = do + r <- get (rotAngle state) + clear [ ColorBuffer ] + + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + vertex2f = vertex :: Vertex2 GLfloat -> IO () + + color3f (Color3 0 1 0) + preservingMatrix $ do + rotate (-(fromIntegral r :: GLfloat)) (Vector3 0 0 0.1) + renderPrimitive Lines $ do + vertex2f (Vertex2 (-0.5) 0.5) + vertex2f (Vertex2 0.5 (-0.5)) + + color3f (Color3 0 0 1) + preservingMatrix $ do + rotate (fromIntegral r :: GLfloat) (Vector3 0 0 0.1) + renderPrimitive Lines $ do + vertex2f (Vertex2 0.5 0.5) + vertex2f (Vertex2 (-0.5) (-0.5)) + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D (-1) 1 (-1*hf/wf) (1*hf/wf) + else ortho2D (-1*wf/hf) (1*wf/hf) (-1) 1 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'r' -> do rotAngle state $~ ((`mod` 360) . (+ 30)); postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +-- Main Loop +-- Open window with initial window size, title bar, +-- RGBA display mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 200 200 + createWindow progName + state <- makeState + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state + mainLoop diff --git a/examples/RedBook/AccAnti.hs b/examples/RedBook/AccAnti.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/AccAnti.hs @@ -0,0 +1,132 @@ +{- + AccAnti.hs (adapted from accanti.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Use the accumulation buffer to do full-scene antialiasing on a scene with + orthographic parallel projection. +-} + +import Data.List ( genericLength ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a +-- gaussian distribution around the origin. Use these to do model jittering for +-- scene anti-aliasing and view volume jittering for depth of field effects. Use +-- in conjunction with the accwindow routine. +j8 :: [Vector2 GLdouble] +j8 = [ + Vector2 (-0.334818) 0.435331 , + Vector2 0.286438 (-0.393495), + Vector2 0.459462 0.141540 , + Vector2 (-0.414498) (-0.192829), + Vector2 (-0.183790) 0.082102 , + Vector2 (-0.079263) (-0.317383), + Vector2 0.102254 0.299133 , + Vector2 0.164216 (-0.054399) ] + +-- Initialize lighting and other values. +myInit :: IO () +myInit = do + materialAmbient Front $= Color4 1 1 1 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 50 + position (Light 0) $= Vertex4 0 0 10 1 + lightModelAmbient $= Color4 0.2 0.2 0.2 1 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + shadeModel $= Flat + + clearColor $= Color4 0 0 0 0 + clearAccum $= Color4 0 0 0 0 + +displayObjects :: IO () +displayObjects = do + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + + preservingMatrix $ do + rotatef 30 (Vector3 1 0 0) + + preservingMatrix $ do + translatef (Vector3 (-0.80) 0.35 0) + rotatef 100 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0.7 0.7 0 1 + renderObject Solid (Torus 0.275 0.85 16 16) + + preservingMatrix $ do + translatef (Vector3 (-0.75) (-0.50) 0) + rotatef 45 (Vector3 0 0 1) + rotatef 45 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0 0.7 0.7 1 + renderObject Solid (Cube 1.5) + + preservingMatrix $ do + translatef (Vector3 0.75 0.60 0) + rotatef 30 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0.7 0 0.7 1 + renderObject Solid (Sphere' 1 16 16) + + preservingMatrix $ do + translatef (Vector3 0.70 (-0.90) 0.25) + materialDiffuse Front $= Color4 0.7 0.4 0.4 1 + renderObject Solid Octahedron + +-- display draws 5 teapots into the accumulation buffer several times; each time +-- with a jittered perspective. The focal point is at z = 5.0, so the gold +-- teapot will stay in focus. The amount of jitter is adjusted by the magnitude +-- of the accPerspective jitter; in this example, 0.33. In this example, the +-- teapots are drawn 8 times. +display :: DisplayCallback +display = do + (_, Size w h) <- get viewport + clear [ AccumBuffer ] + + flip mapM_ j8 $ \(Vector2 x y) -> do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + -- Note that 4.5 is the distance in world space between left and right + -- and bottom and top. This formula converts fractional pixel movement + -- to world coordinates. + translate (Vector3 (x*4.5/fromIntegral w) (y*4.5/fromIntegral h) 0) + displayObjects + accum Accum (recip (genericLength j8)) + + accum Return 1 + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-2.25) 2.25 (-2.25*hf/wf) (2.25*hf/wf) (-10) 10 + else ortho (-2.25*wf/hf) (2.25*wf/hf) (-2.25) 2.25 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Be certain to request an accumulation buffer. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/AccPersp.hs b/examples/RedBook/AccPersp.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/AccPersp.hs @@ -0,0 +1,166 @@ +{- + AccPersp.hs (adapted from accpersp.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Use the accumulation buffer to do full-scene antialiasing on a scene with + perspective projection, using the special routines accFrustum and + accPerspective. +-} + +import Data.List ( genericLength ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a +-- gaussian distribution around the origin. Use these to do model jittering for +-- scene anti-aliasing and view volume jittering for depth of field effects. Use +-- in conjunction with the accwindow routine. +j8 :: [Vector2 GLdouble] +j8 = [ + Vector2 (-0.334818) 0.435331 , + Vector2 0.286438 (-0.393495), + Vector2 0.459462 0.141540 , + Vector2 (-0.414498) (-0.192829), + Vector2 (-0.183790) 0.082102 , + Vector2 (-0.079263) (-0.317383), + Vector2 0.102254 0.299133 , + Vector2 0.164216 (-0.054399) ] + +-- The first 6 arguments are identical to the frustum call. pixD is anti-alias +-- jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD is +-- depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field +-- effects. focus is distance from eye to plane in focus. focus must be greater +-- than, but not equal to 0. Note that accFrustum calls translate. You will +-- probably want to insure that your ModelView matrix has been initialized to +-- identity before calling accFrustum. +accFrustum :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble + -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () +accFrustum left right bottom top zNear zFar + (Vector2 pixDx pixDy) (Vector2 eyeDx eyeDy) focus = do + (_, Size w h) <- get viewport + + let xWSize = right - left; + yWSize = top - bottom; + + dx = -(pixDx * xWSize / fromIntegral w + eyeDx * zNear / focus) + dy = -(pixDy * yWSize / fromIntegral h + eyeDy * zNear / focus) + + matrixMode $= Projection + loadIdentity + frustum (left + dx) (right + dx) (bottom + dy) (top + dy) zNear zFar + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 (-eyeDx) (-eyeDy) 0) + +-- The first 4 arguments are identical to the perspective call. pixD is +-- anti-alias jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD +-- is depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field +-- effects. focus is distance from eye to plane in focus. focus must be greater +-- than, but not equal to 0. Note that accPerspective calls accFrustum. +accPerspective :: GLdouble -> GLdouble -> GLdouble -> GLdouble + -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () +accPerspective fovY aspect zNear zFar pixD eyeD focus = do + let fov2 = ((fovY * pi) / 180) / 2 + + top = zNear / (cos fov2 / sin fov2) + bottom = -top + + right = top * aspect + left = -right + + accFrustum left right bottom top zNear zFar pixD eyeD focus + +-- Initialize lighting and other values. +myInit :: IO () +myInit = do + materialAmbient Front $= Color4 1 1 1 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 50 + position (Light 0) $= Vertex4 0 0 10 1 + lightModelAmbient $= Color4 0.2 0.2 0.2 1 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + shadeModel $= Flat + + clearColor $= Color4 0 0 0 0 + clearAccum $= Color4 0 0 0 0 + +displayObjects :: IO () +displayObjects = do + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + + preservingMatrix $ do + translatef (Vector3 0 0 (-5)) + rotatef 30 (Vector3 1 0 0) + + preservingMatrix $ do + translatef (Vector3 (-0.80) 0.35 0) + rotatef 100 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0.7 0.7 0 1 + renderObject Solid (Torus 0.275 0.85 16 16) + + preservingMatrix $ do + translatef (Vector3 (-0.75) (-0.50) 0) + rotatef 45 (Vector3 0 0 1) + rotatef 45 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0 0.7 0.7 1 + renderObject Solid (Cube 1.5) + + preservingMatrix $ do + translatef (Vector3 0.75 0.60 0) + rotatef 30 (Vector3 1 0 0) + materialDiffuse Front $= Color4 0.7 0 0.7 1 + renderObject Solid (Sphere' 1 16 16) + + preservingMatrix $ do + translatef (Vector3 0.70 (-0.90) 0.25) + materialDiffuse Front $= Color4 0.7 0.4 0.4 1 + renderObject Solid Octahedron + +-- display draws 5 teapots into the accumulation buffer several times; each time +-- with a jittered perspective. The focal point is at z = 5.0, so the gold +-- teapot will stay in focus. The amount of jitter is adjusted by the magnitude +-- of the accPerspective jitter; in this example, 0.33. In this example, the +-- teapots are drawn 8 times. +display :: DisplayCallback +display = do + (_, Size w h) <- get viewport + clear [ AccumBuffer ] + + flip mapM_ j8 $ \(Vector2 x y) -> do + clear [ ColorBuffer, DepthBuffer ] + accPerspective 50 (fromIntegral w / fromIntegral h) 1 15 + (Vector2 x y) (Vector2 0 0) 1 + displayObjects + accum Accum (recip (genericLength j8)) + + accum Return 1 + flush + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Be certain you request an accumulation buffer. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/Alpha.hs b/examples/RedBook/Alpha.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Alpha.hs @@ -0,0 +1,91 @@ +{- + Alpha.hs (adapted from alpha.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws several overlapping filled polygons to demonstrate the + effect order has on alpha blending results. Use the 't' key to toggle the + order of drawing polygons. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { leftFirst :: IORef Bool } + +makeState :: IO State +makeState = do + l <- newIORef True + return $ State { leftFirst = l } + +-- Initialize alpha blending function. +myInit :: IO () +myInit = do + blend $= Enabled + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + shadeModel $= Flat + clearColor $= Color4 0 0 0 0 + +drawLeftTriangle :: IO () +drawLeftTriangle = + -- draw yellow triangle on LHS of screen + renderPrimitive Triangles $ do + color (Color4 1 1 0 (0.75 :: GLfloat)) + vertex (Vertex3 0.1 0.9 (0 :: GLfloat)) + vertex (Vertex3 0.1 0.1 (0 :: GLfloat)) + vertex (Vertex3 0.7 0.5 (0 :: GLfloat)) + +drawRightTriangle :: IO () +drawRightTriangle = + -- draw cyan triangle on RHS of screen + renderPrimitive Triangles $ do + color (Color4 0 1 1 (0.75 :: GLfloat)) + vertex (Vertex3 0.9 0.9 (0 :: GLfloat)) + vertex (Vertex3 0.3 0.5 (0 :: GLfloat)) + vertex (Vertex3 0.9 0.1 (0 :: GLfloat)) + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + l <- get (leftFirst state) + if l + then do drawLeftTriangle; drawRightTriangle + else do drawRightTriangle; drawLeftTriangle + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D 0 1 0 (hf/wf) + else ortho2D 0 (wf/hf) 0 1 + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 't' -> do leftFirst state $~ not; postRedisplay Nothing + '\27' -> exitWith ExitSuccess -- Escape key + _ -> return () +keyboard _ _ _ _ _ = return () + +-- Main Loop +-- Open window with initial window size, title bar, RGBA display mode, and +-- handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 200 200 + createWindow progName + state <- makeState + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state + mainLoop diff --git a/examples/RedBook/Alpha3D.hs b/examples/RedBook/Alpha3D.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Alpha3D.hs @@ -0,0 +1,124 @@ +{- + Alpha3D.hs (adapted from alpha3D.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates how to intermix opaque and alpha blended polygons + in the same scene, by using depthMask. Press the 'a' key to animate moving + the transparent object through the opaque object. Press the 'r' key to reset + the scene. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +maxZ, minZ, zInc :: GLfloat +maxZ = 8 +minZ = -8 +zInc = 0.4 + +-- We don't animate via the idle callback, because this is way too fast on +-- modern computers. A timer with the delay below is used instead for redraw. +delay :: Timeout +delay = 100 + +data State = State { solidZ, transparentZ :: IORef GLfloat } + +makeState :: IO State +makeState = do + s <- newIORef maxZ + t <- newIORef minZ + return $ State { solidZ = s, transparentZ = t } + +data DisplayLists = DisplayLists { sphereList, cubeList :: DisplayList } + +myInit :: IO DisplayLists +myInit = do + materialSpecular Front $= Color4 1 1 1 0.15 + materialShininess Front $= 100 + position (Light 0) $= Vertex4 0.5 0.5 1 0 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + + s <- defineNewList Compile $ renderObject Solid (Sphere' 0.4 16 16) + c <- defineNewList Compile $ renderObject Solid (Cube 0.6) + return $ DisplayLists { sphereList = s, cubeList = c } + +display :: State -> DisplayLists -> DisplayCallback +display state displayLists = do + clear [ ColorBuffer, DepthBuffer ] + + preservingMatrix $ do + s <- get (solidZ state) + translate (Vector3 (-0.15) (-0.15) s) + materialEmission Front $= Color4 0 0 0 1 + materialDiffuse Front $= Color4 0.75 0.75 0 1 + callList (sphereList displayLists) + + preservingMatrix $ do + t <- get (transparentZ state) + translate (Vector3 (0.15) (0.15) t) + rotate (15 :: GLfloat) (Vector3 1 1 0) + rotate (30 :: GLfloat) (Vector3 0 1 0) + materialEmission Front $= Color4 0 0.3 0.3 0.6 + materialDiffuse Front $= Color4 0 0.8 0.8 0.6 + blend $= Enabled + depthMask $= Disabled + blendFunc $= (SrcAlpha, One) + callList (cubeList displayLists) + depthMask $= Enabled + blend $= Disabled + + swapBuffers + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-1.5) 1.5 (-1.5*hf/wf) (1.5*hf/wf) (-10) 10 + else ortho (-1.5*wf/hf) (1.5*wf/hf) (-1.5) 1.5 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +animate :: State -> TimerCallback +animate state = do + s <- get (solidZ state) + t <- get (transparentZ state) + if (s <= minZ || t >= maxZ) + then idleCallback $= Nothing + else do + solidZ state $~ (+ (- zInc)) + transparentZ state $~ (+ zInc) + addTimerCallback delay (animate state) + postRedisplay Nothing + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'a' -> do solidZ state $= maxZ; transparentZ state $= minZ; addTimerCallback delay (animate state) + 'r' -> do solidZ state $= maxZ; transparentZ state $= minZ; postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + -- The original C example uses single buffering, which flickers a lot. + initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + createWindow progName + state <- makeState + displayLists <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state displayLists + mainLoop diff --git a/examples/RedBook/BezCurve.hs b/examples/RedBook/BezCurve.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/BezCurve.hs @@ -0,0 +1,67 @@ +{- + BezCurve.hs (adapted from bezcurve.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program uses evaluators to draw a Bezier curve. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +ctrlPoints :: [Vertex3 GLfloat] +ctrlPoints = [ Vertex3 (-4)(-4) 0, Vertex3 (-2) 4 0, + Vertex3 2 (-4) 0, Vertex3 4 4 0 ] + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + m <- newMap1 (0, 1) ctrlPoints + map1 $= Just (m :: GLmap1 Vertex3 GLfloat) + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 1 1 1) + renderPrimitive LineStrip $ + mapM_ evalCoord1 [ i/30.0 :: GLfloat | i <- [0..30] ] + -- The following code displays the control points as dots. + pointSize $= 5 + color3f (Color3 1 1 0) + renderPrimitive Points $ + mapM_ vertex ctrlPoints + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-5.0) 5.0 (-5.0*hf/wf) (5.0*hf/wf) (-5.0) 5.0 + else ortho (-5.0*wf/hf) (5.0*wf/hf) (-5.0) 5.0 (-5.0) 5.0 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/BezMesh.hs b/examples/RedBook/BezMesh.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/BezMesh.hs @@ -0,0 +1,84 @@ +{- + BezMesh.hs (adapted from bezmesh.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program renders a lighted, filled Bezier surface, using two-dimensional + evaluators. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Data.List ( transpose ) +import Graphics.UI.GLUT + +ctrlPoints :: [[Vertex3 GLfloat]] +ctrlPoints = [ + [ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0, + Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ], + [ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0, + Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ], + [ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0, + Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ], + [ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0), + Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]] + +initlights :: IO () +initlights = do + lighting $= Enabled + light (Light 0) $= Enabled + + ambient (Light 0) $= Color4 0.2 0.2 0.2 1.0 + position (Light 0) $= Vertex4 0 0 2 1 + + materialDiffuse Front $= Color4 0.6 0.6 0.6 1.0 + materialSpecular Front $= Color4 1.0 1.0 1.0 1.0 + materialShininess Front $= 50 + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + rotate (85 :: GLfloat) (Vector3 1 1 1) + evalMesh2 Fill (0, 20) (0, 20) + flush + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + depthFunc $= Just Less + m <- newMap2 (0, 1) (0, 1) (transpose ctrlPoints) + map2 $= Just (m :: GLmap2 Vertex3 GLfloat) + autoNormal $= Enabled + mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat))) + initlights -- for lighted version only + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0 + else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/BezSurf.hs b/examples/RedBook/BezSurf.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/BezSurf.hs @@ -0,0 +1,79 @@ +{- + BezSurf.hs (adapted from bezsurf.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program renders a wireframe Bezier surface, using two-dimensional + evaluators. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +ctrlPoints :: [[Vertex3 GLfloat]] +ctrlPoints = [ + [ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0, + Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ], + [ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0, + Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ], + [ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0, + Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ], + [ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0), + Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]] + +-- Hey mom, look, it's C! ;-) +for :: GLfloat -> GLfloat -> (GLfloat -> IO ()) -> IO () +for s e f = mapM_ f [ i | i <- [ s, if s <= e then s + 1 else s - 1 .. e ] ] + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + color (Color3 1 1 1 :: Color3 GLfloat) + preservingMatrix $ do + rotate (85 :: GLfloat) (Vector3 1 1 1) + for 0 8 $ \j -> do + renderPrimitive LineStrip $ do + for 0 30 $ \i -> evalCoord2 (i/30, j/ 8) + renderPrimitive LineStrip $ do + for 0 30 $ \i -> evalCoord2 (j/ 8, i/30) + flush + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + m <- newMap2 (0, 1) (0, 1) ctrlPoints + map2 $= Just (m :: GLmap2 Vertex3 GLfloat) + mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat))) + depthFunc $= Just Less + shadeModel $= Flat + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0 + else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/BlendEqn.hs b/examples/RedBook/BlendEqn.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/BlendEqn.hs @@ -0,0 +1,95 @@ +{- + BlendEqn.hs (adapted from blendeqn.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Demonstrate the different blending functions available with the OpenGL + imaging subset. This program demonstrates use of blendEquation. + + The following keys change the selected blend equation function: + + 'a' -> FuncAdd + 's' -> FuncSubtract + 'r' -> FuncReverseSubtract + 'm' -> Min + 'x' -> Max +-} + +import Data.Char ( toLower ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 1 1 0 0 + blendFunc $= (One, One) + blend $= Enabled + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + + color (Color3 0 0 (1 :: GLfloat)) + rect (Vertex2 (-0.5) (-0.5)) (Vertex2 0.5 (0.5 :: GLfloat)) + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + let aspect = fromIntegral w / fromIntegral h + + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + if aspect < 1 + then let aspect' = recip aspect + in ortho (-aspect') aspect' (-1) 1 (-1) 1 + else ortho (-1) 1 (-aspect) aspect (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char c) Down _ _ = case toLower c of + -- Colors are added as: (0, 0, 1) + (1, 1, 0) = (1, 1, 1) + -- which will produce a white square on a yellow background. + 'a' -> setBlendEquation FuncAdd + + -- Colors are subtracted as: (0, 0, 1) - (1, 1, 0) = (-1, -1, 1) + -- which is clamped to (0, 0, 1), producing a blue square on a + -- yellow background + 's' -> setBlendEquation FuncSubtract + + -- Colors are subtracted as: (1, 1, 0) - (0, 0, 1) = (1, 1, -1) + -- which is clamed to (1, 1, 0). This produces yellow for both + -- the square and the background. + 'r' -> setBlendEquation FuncReverseSubtract + + -- The minimum of each component is computed, as + -- [min(0, 1), min(0, 1), min(1, 0)] which equates to (0, 0, 0). + -- This will produce a black square on the yellow background. + 'm' -> setBlendEquation Min + + -- The minimum of each component is computed, as + -- [max(0, 1), max(0, 1), max(1, 0)] which equates to (1, 1, 1) + -- This will produce a white square on the yellow background. + 'x' -> setBlendEquation Max + + '\27' -> exitWith ExitSuccess + _ -> return () + where setBlendEquation e = do + blendEquation $= e + postRedisplay Nothing +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 512 512 + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display + mainLoop diff --git a/examples/RedBook/Checker.hs b/examples/RedBook/Checker.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Checker.hs @@ -0,0 +1,101 @@ +{- + Checker.hs (adapted from checker.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program texture maps a checkerboard image onto two rectangles. + + Texture objects are only used when GL_EXT_texture_object is supported. +-} + +import Control.Monad ( when ) +import Data.Maybe ( isJust, listToMaybe ) +import Data.Bits ( (.&.) ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Create checkerboard image +checkImageSize :: TextureSize2D +checkImageSize = TextureSize2D 64 64 + +withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) + -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () +withCheckImage (TextureSize2D w h) n f act = + withArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] $ + act. PixelData RGBA UnsignedByte + +myInit :: IO (Maybe TextureObject) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + rowAlignment Unpack $= 1 + + exts <- get glExtensions + mbTexName <- if "GL_EXT_texture_object" `elem` exts + then fmap listToMaybe $ genObjectNames 1 + else return Nothing + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + withCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) $ + texImage2D Nothing NoProxy 0 RGBA' checkImageSize 0 + return mbTexName + +display :: Maybe TextureObject -> DisplayCallback +display mbTexName = do + clear [ ColorBuffer, DepthBuffer ] + texture Texture2D $= Enabled + textureFunction $= Decal + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + + -- resolve overloading, not needed in "real" programs + let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) + + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) + flush + texture Texture2D $= Disabled + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-3.6 :: GLfloat)) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + createWindow progName + mbTexName <- myInit + displayCallback $= display mbTexName + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/Clip.hs b/examples/RedBook/Clip.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Clip.hs @@ -0,0 +1,63 @@ +{- + Clip.hs (adapted from clip.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates arbitrary clipping planes. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + color3f (Color3 1 1 1) + + preservingMatrix $ do + translatef (Vector3 0 0 (-5)) + + -- clip lower half -- y < 0 + clipPlane (ClipPlaneName 0) $= Just (Plane 0 1 0 0) + -- clip left half -- x < 0 + clipPlane (ClipPlaneName 1) $= Just (Plane 1 0 0 0) + + rotatef 90 (Vector3 1 0 0) + renderObject Wireframe (Sphere' 1 20 16) + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 20 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/ColorMat.hs b/examples/RedBook/ColorMat.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/ColorMat.hs @@ -0,0 +1,94 @@ +{- + Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + After initialization, the program will be in ColorMaterial mode. + Interaction: pressing the mouse buttons will change the diffuse + reflection values. +-} + +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { r, g, b :: IORef GLfloat } + +diffuseMaterial :: State -> IO (Color4 GLfloat) +diffuseMaterial state = do + r' <- get (r state) + g' <- get (g state) + b' <- get (b state) + return $ Color4 r' g' b' 1 + +makeState :: IO State +makeState = do + r' <- newIORef 0.5 + g' <- newIORef 0.5 + b' <- newIORef 0.5 + return $ State { r = r', g = g', b = b' } + +-- Initialize material property, light source, lighting model, +-- and depth buffer. +myInit :: State -> IO () +myInit state = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + depthFunc $= Just Less + dm <- diffuseMaterial state + materialDiffuse Front $= dm + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 25 + position (Light 0) $= Vertex4 1 1 1 0 + lighting $= Enabled + light (Light 0) $= Enabled + colorMaterial $= Just (Front, Diffuse) + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + renderObject Solid (Sphere' 1 20 16) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-1.5) 1.5 (-1.5 * hf/wf) (1.5 * hf/wf) (-10) 10 + else ortho (-1.5 * wf/hf) (1.5 * wf/hf) (-1.5) 1.5 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +keyboardMouse :: State -> KeyboardMouseCallback +keyboardMouse state (MouseButton button) Down _ _ = case button of + LeftButton -> update r + MiddleButton -> update g + RightButton -> update b + _ -> return () + where update component = do + component state $~ inc + dm <- diffuseMaterial state + color dm + postRedisplay Nothing + inc x = let s = x + 0.1 in if s > 1 then 0 else s +keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboardMouse _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + state <- makeState + myInit state + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboardMouse state) + mainLoop diff --git a/examples/RedBook/ColorMatrix.hs b/examples/RedBook/ColorMatrix.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/ColorMatrix.hs @@ -0,0 +1,65 @@ +{- + ColorMatrix.hs (adapted from colormatrix.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program uses the color matrix to exchange the color channels of an image. + + Red -> Green + Green -> Blue + Blue -> Red +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT +import ReadImage + +myInit :: IO () +myInit = do + m <- newMatrix ColumnMajor [ 0, 1, 0, 0, + 0, 0, 1, 0, + 1, 0, 0, 0, + 0, 0, 0, 1 ] + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + matrixMode $= Color + matrix Nothing $= (m :: GLmatrix GLfloat) + matrixMode $= Modelview 0 + +display :: Size -> PixelData a -> DisplayCallback +display size pixels = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 1 1) + drawPixels size pixels + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, args) <- getArgsAndInitialize + (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= size + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display size pixels + mainLoop diff --git a/examples/RedBook/ColorTable.hs b/examples/RedBook/ColorTable.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/ColorTable.hs @@ -0,0 +1,62 @@ +{- + ColorTable.hs (adapted from colortable.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Invert a passed block of pixels. This program illustrates the use of the + colorTable function. +-} + +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT +import ReadImage + +myInit :: IO () +myInit = do + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + -- Set up an inverse color table + let tableSize = 256 + t = fromIntegral (tableSize - 1) :: GLubyte + withArray [ Color3 i i i | i <- [ t, t - 1 .. 0 ] ] $ \buf -> + colorTable NoProxy ColorTable RGB' tableSize (PixelData RGB UnsignedByte buf) + colorTableStage ColorTableStage $= Enabled + +display :: Size -> PixelData a -> DisplayCallback +display size pixels = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 1 1) + drawPixels size pixels + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, args) <- getArgsAndInitialize + (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= size + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display size pixels + mainLoop diff --git a/examples/RedBook/Combiner.hs b/examples/RedBook/Combiner.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Combiner.hs @@ -0,0 +1,236 @@ +{- + Combiner.hs (adapted from combiner.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program renders a variety of quads showing different effects of + texture combiner functions. + + The first row renders an untextured polygon (so you can compare the + fragment colors) and then the 2 textures. + + The second row shows several different combiner functions on a single + texture: replace, modulate, add, add-signed, and subtract. + + The third row shows the interpolate combiner function on a single texture + with a constant color/alpha value, varying the amount of interpolation. + + The fourth row uses multitexturing with two textures and different + combiner functions. + + The fifth row are some combiner experiments: using the scaling factor and + reversing the order of subtraction for a combination function. +-} + +import Data.Bits ( (.&.) ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Create checkerboard image +imageSize :: TextureSize2D +imageSize = TextureSize2D 8 8 + +makeImage :: TextureSize2D -> (GLsizei -> GLsizei -> Color4 GLubyte) + -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () +makeImage (TextureSize2D w h) f act = + withArray [ f i j | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ] ] $ + act . PixelData RGBA UnsignedByte + +myInit :: IO (TextureObject, TextureObject, DisplayList) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + + rowAlignment Unpack $= 1 + + [texName0, texName1] <- genObjectNames 2 + + textureBinding Texture2D $= Just texName0 + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + -- horiz b & w stripes + makeImage imageSize (\i _ -> let c = if i .&. 2 == 0 then 255 else 0 in Color4 c c c 255) $ + texImage2D Nothing NoProxy 0 RGBA' imageSize 0 + + textureBinding Texture2D $= Just texName1 + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + textureFunction $= Decal + -- wider vertical 50% cyan and black stripes + makeImage imageSize (\_ j -> let c = if j .&. 4 /= 0 then 128 else 0 in Color4 0 c c 255) $ + texImage2D Nothing NoProxy 0 RGBA' imageSize 0 + + -- smooth-shaded polygon with multiple texture coordinates + let vert :: TexCoord2 GLfloat -> Color3 GLfloat -> Vertex3 GLfloat -> IO () + vert t c v = do + multiTexCoord (TextureUnit 0) t + multiTexCoord (TextureUnit 1) t + color c + vertex v + + dl <- defineNewList Compile $ + renderPrimitive Quads $ do + vert (TexCoord2 0 0) (Color3 0.5 1 0.25) (Vertex3 0 0 0) + vert (TexCoord2 0 2) (Color3 1 1 1 ) (Vertex3 0 1 0) + vert (TexCoord2 2 2) (Color3 1 1 1 ) (Vertex3 1 1 0) + vert (TexCoord2 2 0) (Color3 1 0.5 0.25) (Vertex3 1 0 0) + + return (texName0, texName1, dl) + +display :: (TextureObject, TextureObject, DisplayList) -> DisplayCallback +display (texName0, texName1, dl) = do + clear [ ColorBuffer ] + + let drawAt :: GLfloat -> GLfloat -> IO () + drawAt x y = preservingMatrix $ do + translate (Vector3 x y 0) + callList dl + + -- untextured polygon -- see the "fragment" colors + texture Texture2D $= Disabled + drawAt 0 5 + + texture Texture2D $= Enabled + -- draw ordinary textured polys; 1 texture unit; combine mode disabled + textureFunction $= Modulate + textureBinding Texture2D $= Just texName0 + drawAt 1 5 + + textureBinding Texture2D $= Just texName1 + drawAt 2 5 + + -- different combine modes enabled; 1 texture unit + -- defaults are: + -- argRGB Arg0 $= Arg SrcColor CurrentUnit + -- argRGB Arg1 $= Arg SrcColor Previous + + textureBinding Texture2D $= Just texName0 + textureFunction $= Combine + combineRGB $= Replace' + argRGB Arg0 $= Arg SrcColor CurrentUnit + drawAt 1 4 + + combineRGB $= Modulate' + argRGB Arg1 $= Arg SrcColor Previous + drawAt 2 4 + + combineRGB $= AddUnsigned' + drawAt 3 4 + + combineRGB $= AddSigned + drawAt 4 4 + + combineRGB $= Subtract + drawAt 5 4 + + -- interpolate combine with constant color; 1 texture unit + -- use different alpha values for constant color + -- defaults are: + -- argRGB Arg0 $= Arg SrcColor CurrentUnit + -- argRGB Arg1 $= Arg SrcColor Previous + -- argRGB Arg2 $= Arg SrcAlpha Constant + + constantColor $= Color4 0 0 0 0.2 + textureBinding Texture2D $= Just texName0 + textureFunction $= Combine + combineRGB $= Interpolate + argRGB Arg0 $= Arg SrcColor CurrentUnit + argRGB Arg1 $= Arg SrcColor Previous + argRGB Arg2 $= Arg SrcAlpha Constant + drawAt 1 3 + + constantColor $= Color4 0 0 0 0.4 + drawAt 2 3 + + constantColor $= Color4 0 0 0 0.6 + drawAt 3 3 + + constantColor $= Color4 0 0 0 0.8 + drawAt 4 3 + + -- combine textures 0 & 1 + -- defaults are: + -- argRGB Arg0 $= Arg SrcColor CurrentUnit + -- argRGB Arg1 $= Arg SrcColor Previous + + activeTexture $= TextureUnit 0 + texture Texture2D $= Enabled + textureBinding Texture2D $= Just texName0 + textureFunction $= Modulate + + activeTexture $= TextureUnit 1 + texture Texture2D $= Enabled + textureBinding Texture2D $= Just texName1 + textureFunction $= Combine + combineRGB $= Replace' + drawAt 1 2 + + -- try different combiner modes of texture unit 1 + combineRGB $= Modulate' + drawAt 2 2 + + combineRGB $= AddUnsigned' + drawAt 3 2 + + combineRGB $= AddSigned + drawAt 4 2 + + combineRGB $= Subtract + drawAt 5 2 + + -- some experiments + + -- see the effect of rgbScale + rgbScale $= 2 + combineRGB $= Replace' + drawAt 1 1 + + combineRGB $= Modulate' + drawAt 2 1 + rgbScale $= 1 + + -- reverse the order of subtraction Arg1-Arg0 + + textureFunction $= Combine + combineRGB $= Subtract + argRGB Arg0 $= Arg SrcColor Previous + argRGB Arg1 $= Arg SrcColor CurrentUnit + drawAt 5 1 + + activeTexture $= TextureUnit 1 -- deactivate multitexturing + texture Texture2D $= Disabled + activeTexture $= TextureUnit 0 -- activate single texture unit + + flush + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 7 0 7 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 400 400 + initialWindowPosition $= Position 100 100 + createWindow progName + texNamesAndDL <- myInit + displayCallback $= display texNamesAndDL + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/Convolution.hs b/examples/RedBook/Convolution.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Convolution.hs @@ -0,0 +1,83 @@ +{- + Convolution.hs (adapted from convolution.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Use various 2D convolutions filters to find edges in an image. +-} + +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT +import ReadImage + +data Filter = Filter String [GLfloat] + +filterTable :: [(Key,Filter)] +filterTable = [ + (Char 'h', Filter "horizontal" [ 0, -1, 0, + 0, 1, 0, + 0, 0, 0 ]), + + (Char 'v', Filter "vertical" [ 0, 0, 0, + -1, 1, 0, + 0, 0, 0 ]), + + (Char 'l', Filter "laplacian" [ -0.125, -0.125, -0.125, + -0.125, 1.0 , -0.125, + -0.125, -0.125, -0.125 ])] + +setFilter :: Filter -> IO () +setFilter (Filter filterName filterData) = do + putStrLn ("Using the " ++ filterName ++ " filter") + withArray filterData $ \buf -> + convolutionFilter2D Luminance' (Size 3 3) (PixelData Luminance Float buf) + +myInit :: IO () +myInit = do + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + setFilter (snd (head filterTable)) + convolution Convolution2D $= Enabled + +display :: Size -> PixelData a -> DisplayCallback +display size pixels = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 1 1) + drawPixels size pixels + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard key Down _ _ = + maybe (return ()) + (\f -> do setFilter f; postRedisplay Nothing) + (lookup key filterTable) +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, args) <- getArgsAndInitialize + (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) + initialDisplayMode $= [ SingleBuffered, RGBAMode ] + initialWindowSize $= size + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display size pixels + mainLoop diff --git a/examples/RedBook/Cube.hs b/examples/RedBook/Cube.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Cube.hs @@ -0,0 +1,56 @@ +{- + Cube.hs (adapted from cube.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates a single modeling transformation, scale and a + single viewing transformation, lookAt. A wireframe cube is rendered. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () + color3f (Color3 1 1 1) + loadIdentity -- clear the matrix + -- viewing transformation + lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) + scalef 1 2 1 -- modeling transformation + renderObject Wireframe (Cube 1) + flush + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + frustum (-1) 1 (-1) 1 1.5 20 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/CubeMap.hs b/examples/RedBook/CubeMap.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/CubeMap.hs @@ -0,0 +1,118 @@ +{- + CubeMap.hs (adapted from CubeMap.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates cube map textures. Six different colored checker + board textures are created and applied to a lit sphere. + + Pressing the 'f' and 'b' keys translate the viewer forward and backward. +-} + +import Data.Bits ( (.&.) ) +import Data.IORef ( IORef, newIORef ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { zTrans :: IORef GLfloat } + +makeState :: IO State +makeState = do + z <- newIORef 0 + return $ State { zTrans = z } + +imageSize :: TextureSize2D +imageSize = TextureSize2D 4 4 + +withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) + -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () +withCheckImage (TextureSize2D w h) n f act = + withArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] $ + act. PixelData RGBA UnsignedByte + +makeImage :: CubeMapTarget -> (GLubyte -> (Color4 GLubyte)) -> IO () +makeImage target f = + withCheckImage imageSize 0x1 f $ + texImage2D (Just target) NoProxy 0 RGBA' imageSize 0 + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + depthFunc $= Just Less + shadeModel $= Smooth + + rowAlignment Unpack $= 1 + textureWrapMode TextureCubeMap S $= (Repeated, Repeat) + textureWrapMode TextureCubeMap T $= (Repeated, Repeat) + textureWrapMode TextureCubeMap R $= (Repeated, Repeat) + textureFilter TextureCubeMap $= ((Nearest, Nothing), Nearest) + + makeImage TextureCubeMapPositiveX (\c -> Color4 c c c 255) + makeImage TextureCubeMapNegativeX (\c -> Color4 0 c c 255) + makeImage TextureCubeMapPositiveY (\c -> Color4 c c 0 255) + makeImage TextureCubeMapNegativeY (\c -> Color4 255 c c 255) + makeImage TextureCubeMapPositiveZ (\c -> Color4 c 0 c 255) + makeImage TextureCubeMapNegativeZ (\c -> Color4 c c 255 255) + + textureGenMode S $= Just NormalMap + textureGenMode T $= Just NormalMap + textureGenMode R $= Just NormalMap + + textureFunction $= Modulate + + texture TextureCubeMap $= Enabled + lighting $= Enabled + light (Light 0) $= Enabled + autoNormal $= Enabled + normalize $= Enabled + materialDiffuse Front $= Color4 1 1 1 1 + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + z <- get (zTrans state) + translate (Vector3 0 0 z) + renderObject Solid (Sphere' 5 20 10) + swapBuffers + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 40 (fromIntegral w / fromIntegral h) 1 300 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-20 :: GLfloat)) + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char 'f') Down _ _ = move state (-0.2) +keyboard state (Char 'b') Down _ _ = move state 0.2 +keyboard _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ _ = return () + +move :: State -> GLfloat -> IO () +move state inc = do + zTrans state $~ (+ inc) + postRedisplay Nothing + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 400 400 + initialWindowPosition $= Position 50 50 + createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + mainLoop diff --git a/examples/RedBook/DList.hs b/examples/RedBook/DList.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/DList.hs @@ -0,0 +1,85 @@ +{- + DList.hs (adapted from list.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates how to make and execute a + display list. Note that attributes, such as current + color and matrix, are changed. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO DisplayList +myInit = do + [listName] <- genObjectNames 1 + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + vertex2f = vertex :: Vertex2 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + defineList listName Compile $ do + color3f (Color3 1 0 0) -- current color red + renderPrimitive Triangles $ do + vertex2f (Vertex2 0 0) + vertex2f (Vertex2 1 0) + vertex2f (Vertex2 0 1) + translatef (Vector3 1.5 0.0 0.0) -- move position + shadeModel $= Flat + return listName + +drawLine :: IO () +drawLine = do + -- resolve overloading, not needed in "real" programs + let vertex2f = vertex :: Vertex2 GLfloat -> IO () + renderPrimitive Lines $ do + vertex2f (Vertex2 0.0 0.5) + vertex2f (Vertex2 15.0 0.5) + +display :: DisplayList -> DisplayCallback +display listName = do + -- NOTE: The following 'loadIdentity' is missing in the original + -- example, but without it the translatef calls accumulate and + -- the graphics wander out of the window after a few redraws... + loadIdentity + + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 0 1 0) -- current color green + sequence_ (replicate 10 (callList listName)) -- draw 10 triangles + drawLine -- is this line green? NO! + -- where is the line drawn? + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D 0.0 2.0 (-0.5*hf/wf) (1.5*hf/wf) + else ortho2D 0.0 (2.0*wf/hf) (-0.5) 1.5 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Open window with initial window size, title bar, +-- RGBA display mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 650 50 + createWindow progName + listName <- myInit + reshapeCallback $= Just reshape + displayCallback $= display listName + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/DOF.hs b/examples/RedBook/DOF.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/DOF.hs @@ -0,0 +1,182 @@ +{- + DOF.hs (adapted from dof.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates use of the accumulation buffer to create an + out-of-focus depth-of-field effect. The teapots are drawn several times into + the accumulation buffer. The viewing volume is jittered, except at the focal + point, where the viewing volume is at the same position, each time. In this + case, the gold teapot remains in focus. +-} + +import Data.List ( genericLength ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a +-- gaussian distribution around the origin. Use these to do model jittering for +-- scene anti-aliasing and view volume jittering for depth of field effects. Use +-- in conjunction with the accwindow routine. +j8 :: [Vector2 GLdouble] +j8 = [ + Vector2 (-0.334818) 0.435331 , + Vector2 0.286438 (-0.393495), + Vector2 0.459462 0.141540 , + Vector2 (-0.414498) (-0.192829), + Vector2 (-0.183790) 0.082102 , + Vector2 (-0.079263) (-0.317383), + Vector2 0.102254 0.299133 , + Vector2 0.164216 (-0.054399) ] + +-- The first 6 arguments are identical to the frustum call. pixD is anti-alias +-- jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD is +-- depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field +-- effects. focus is distance from eye to plane in focus. focus must be greater +-- than, but not equal to 0. Note that accFrustum calls translate. You will +-- probably want to insure that your ModelView matrix has been initialized to +-- identity before calling accFrustum. +accFrustum :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble + -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () +accFrustum left right bottom top zNear zFar + (Vector2 pixDx pixDy) (Vector2 eyeDx eyeDy) focus = do + (_, Size w h) <- get viewport + + let xWSize = right - left; + yWSize = top - bottom; + + dx = -(pixDx * xWSize / fromIntegral w + eyeDx * zNear / focus) + dy = -(pixDy * yWSize / fromIntegral h + eyeDy * zNear / focus) + + matrixMode $= Projection + loadIdentity + frustum (left + dx) (right + dx) (bottom + dy) (top + dy) zNear zFar + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 (-eyeDx) (-eyeDy) 0) + +-- The first 4 arguments are identical to the perspective call. pixD is +-- anti-alias jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD +-- is depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field +-- effects. focus is distance from eye to plane in focus. focus must be greater +-- than, but not equal to 0. Note that accPerspective calls accFrustum. +accPerspective :: GLdouble -> GLdouble -> GLdouble -> GLdouble + -> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO () +accPerspective fovY aspect zNear zFar pixD eyeD focus = do + let fov2 = ((fovY * pi) / 180) / 2 + + top = zNear / (cos fov2 / sin fov2) + bottom = -top + + right = top * aspect + left = -right + + accFrustum left right bottom top zNear zFar pixD eyeD focus + +myInit :: IO DisplayList +myInit = do + ambient (Light 0) $= Color4 0 0 0 1 + diffuse (Light 0) $= Color4 1 1 1 1 + position (Light 0) $= Vertex4 0 3 3 0 + + lightModelAmbient $= Color4 0.2 0.2 0.2 1 + lightModelLocalViewer $= Disabled + + frontFace $= CW + lighting $= Enabled + light (Light 0) $= Enabled + autoNormal $= Enabled + normalize $= Enabled + depthFunc $= Just Less + + clearColor $= Color4 0 0 0 0 + clearAccum $= Color4 0 0 0 0 + -- make teapot display list + defineNewList Compile $ + renderObject Solid (Teapot 0.5) + +-- Move object into position, specify the material properties, draw a teapot. +renderTeapot :: DisplayList -> Vector3 GLfloat -> Color4 GLfloat + -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> IO () +renderTeapot teapotList pos amb dif spec shine = + preservingMatrix $ do + translate pos + materialAmbient Front $= amb + materialDiffuse Front $= dif + materialSpecular Front $= spec + materialShininess Front $= shine * 128 + callList teapotList + +-- display draws 5 teapots into the accumulation buffer several times; each time +-- with a jittered perspective. The focal point is at z = 5.0, so the gold +-- teapot will stay in focus. The amount of jitter is adjusted by the magnitude +-- of the accPerspective jitter; in this example, 0.33. In this example, the +-- teapots are drawn 8 times. +display :: DisplayList -> DisplayCallback +display teapotList = do + (_, Size w h) <- get viewport + clear [ AccumBuffer ] + + flip mapM_ j8 $ \(Vector2 x y) -> do + clear [ ColorBuffer, DepthBuffer ] + accPerspective 45 (fromIntegral w / fromIntegral h) 1 15 + (Vector2 0 0) (Vector2 (0.33 * x) (0.33 * y)) 5 + + -- ruby, gold, silver, emerald, and cyan teapots + renderTeapot teapotList + (Vector3 (-1.1) (-0.5) (-4.5)) + (Color4 0.1745 0.01175 0.01175 1) + (Color4 0.61424 0.04136 0.04136 1) + (Color4 0.727811 0.626959 0.626959 1) + 0.6 + renderTeapot teapotList + (Vector3 (-0.5) (-0.5) (-5.0)) + (Color4 0.24725 0.1995 0.0745 1) + (Color4 0.75164 0.60648 0.22648 1) + (Color4 0.628281 0.555802 0.366065 1) + 0.4 + renderTeapot teapotList + (Vector3 0.2 (-0.5) (-5.5)) + (Color4 0.19225 0.19225 0.19225 1) + (Color4 0.50754 0.50754 0.50754 1) + (Color4 0.508273 0.508273 0.508273 1) + 0.4 + renderTeapot teapotList + (Vector3 1.0 (-0.5) (-6.0)) + (Color4 0.0215 0.1745 0.0215 1) + (Color4 0.07568 0.61424 0.07568 1) + (Color4 0.633 0.727811 0.633 1) + 0.6 + renderTeapot teapotList + (Vector3 1.8 (-0.5) (-6.5)) + (Color4 0.0 0.1 0.06 1) + (Color4 0.0 0.50980392 0.50980392 1) + (Color4 0.50196078 0.50196078 0.50196078 1) + 0.25 + accum Accum (recip (genericLength j8)) + + accum Return 1 + flush + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Be certain you request an accumulation buffer. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ] + initialWindowSize $= Size 400 400 + initialWindowPosition $= Position 100 100 + createWindow progName + teapotList <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display teapotList + mainLoop diff --git a/examples/RedBook/Data/leeds.bin b/examples/RedBook/Data/leeds.bin new file mode 100644 Binary files /dev/null and b/examples/RedBook/Data/leeds.bin differ diff --git a/examples/RedBook/Double.hs b/examples/RedBook/Double.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Double.hs @@ -0,0 +1,76 @@ +{- + Double.hs (adapted from double.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This is a simple double buffered program. + Pressing the left mouse button rotates the rectangle. + Pressing the middle mouse button stops the rotation. +-} + +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { spin :: IORef GLfloat } + +makeState :: IO State +makeState = do + s <- newIORef 0 + return $ State { spin = s } + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + preservingMatrix $ do + s <- get (spin state) + rotate s (Vector3 0 0 1) + color (Color3 1 1 1 :: Color3 GLfloat) + rect (Vertex2 (-25) (-25)) (Vertex2 25 25 :: Vertex2 GLfloat) + swapBuffers + +spinDisplay :: State -> IdleCallback +spinDisplay state = do + let wrap n s = if s > n then s - n else s + spin state $~ (wrap 360 . (+ 2)) + postRedisplay Nothing + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho (-50) 50 (-50) 50 (-1) 1 + matrixMode $= Modelview 0 + loadIdentity + +keyboardMouse :: State -> KeyboardMouseCallback +keyboardMouse state (MouseButton b) Down _ _ = + idleCallback $= case b of + LeftButton -> Just (spinDisplay state) + _ -> Nothing +-- ESC not handled in the original example, but useful nevertheless +keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboardMouse _ _ _ _ _ = return () + +-- Request double buffer display mode. +-- Register mouse input callback functions +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboardMouse state) + mainLoop diff --git a/examples/RedBook/DrawF.hs b/examples/RedBook/DrawF.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/DrawF.hs @@ -0,0 +1,62 @@ +{- + DrawF.hs (adapted from drawf.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Draws the bitmapped letter F on the screen (several times). + This demonstrates use of the bitmap call. +-} + +import Foreign ( Ptr, newArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO (Ptr GLubyte) +myInit = do + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + newArray [ + 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, + 0xff, 0x00, 0xff, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, + 0xff, 0xc0, 0xff, 0xc0 ] + +display :: Ptr GLubyte -> DisplayCallback +display rasters = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + color3f (Color3 1 1 1) + rasterPos2i (Vertex2 20 20) + sequence_ $ replicate 3 $ + bitmap (Size 10 12) (Vertex2 0 0) (Vector2 11 0) rasters + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop +-- Open window with initial window size, title bar, +-- RGBA display mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 100 100 + initialWindowPosition $= Position 100 100 + createWindow progName + rasters <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display rasters + mainLoop diff --git a/examples/RedBook/Feedback.hs b/examples/RedBook/Feedback.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Feedback.hs @@ -0,0 +1,77 @@ +{- + Feedback.hs (adapted from feedback.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates use of OpenGL feedback. First, a lighting + environment is set up and a few lines are drawn. Then feedback mode is + entered, and the same lines are drawn. The results in the feedback buffer are + printed. +-} + +import Control.Monad ( when ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Initialize lighting. +myInit :: IO () +myInit = do + lighting $= Enabled + light (Light 0) $= Enabled + +-- Draw a few lines and two points, one of which will be clipped. If in feedback +-- mode, a passthrough token is issued between each primitive +drawGeometry :: IO () +drawGeometry = do + mode <- get renderMode + -- resolve overloading, not needed in "real" programs + let normal3f = normal :: Normal3 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive LineStrip $ do + normal3f (Normal3 0 0 1) + vertex3f (Vertex3 30 30 0) + vertex3f (Vertex3 50 60 0) + vertex3f (Vertex3 70 40 0) + when (mode == Feedback) $ + passThrough (PassThroughValue 1) + renderPrimitive Points $ + vertex3f (Vertex3 (-100) (-100) (-100)) -- will be clipped + when (mode == Feedback) $ + passThrough (PassThroughValue 2) + renderPrimitive Points $ do + normal3f (Normal3 0 0 1) + vertex3f (Vertex3 50 50 0) + flush -- not in original example + +printBuffer :: Maybe [FeedbackToken] -> IO () +printBuffer = maybe (putStrLn "feedback buffer overflow") (mapM_ print) + +display :: DisplayCallback +display = do + matrixMode $= Projection + loadIdentity + ortho 0 100 0 100 0 1 + + clearColor $= Color4 0 0 0 0 + clear [ ColorBuffer ] + drawGeometry + + (_, tokens) <- getFeedbackTokens 1024 ThreeDColor drawGeometry + printBuffer tokens + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 100 100 + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/Fog.hs b/examples/RedBook/Fog.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Fog.hs @@ -0,0 +1,90 @@ +{- + Fog.hs (adapted from fog.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws 5 red spheres, each at a different z distance from the + eye, in different types of fog. Pressing the f key chooses between 3 types + of fog: exponential, exponential squared, and linear. In this program, there + is a fixed density value, as well as fixed start and end values for the + linear fog. +-} + +import Data.Char ( toLower ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + depthFunc $= Just Less + + position (Light 0) $= Vertex4 0.5 0.5 3.0 0.0 + lighting $= Enabled + light (Light 0) $= Enabled + + -- NOTE: The alpha values are missing from fog.c! + materialAmbient Front $= Color4 0.1745 0.01175 0.01175 1.0 + materialDiffuse Front $= Color4 0.61424 0.04136 0.04136 1.0 + materialSpecular Front $= Color4 0.727811 0.626959 0.626959 1.0 + materialShininess Front $= 0.6 * 128 + + fog $= Enabled + let c = Color4 0.5 0.5 0.5 1.0 + fogMode $= Exp 0.35 + fogColor $= c + hint Fog $= DontCare + clearColor $= c + +renderSpehere :: Vector3 GLfloat -> IO () +renderSpehere xyz = + preservingMatrix $ do + translate xyz + renderObject Solid (Sphere' 0.4 16 16) + +-- display draws 5 spheres at different z positions. +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + mapM_ renderSpehere [ Vector3 x (-0.5) (-3 - x) | x <- [-2 .. 2] ] + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10.0) 10.0 + else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10.0) 10.0 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char c) Down _ _ = case toLower c of + 'f' -> do + mode <- get fogMode + case mode of + Linear _ _ -> do fogMode $= Exp 0.35; putStrLn "Fog mode is Exp" + Exp _ -> do fogMode $= Exp2 0.35; putStrLn "Fog mode is Exp2" + Exp2 _ -> do fogMode $= Linear 1 5; putStrLn "Fog mode is Linear" + postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, depth buffer, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display + mainLoop diff --git a/examples/RedBook/FogCoord.hs b/examples/RedBook/FogCoord.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/FogCoord.hs @@ -0,0 +1,122 @@ +{- + FogCoord.hs (adapted from fogcoord.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the use of explicit fog coordinates. You can press + the keyboard and change the fog coordinate value at any vertex. You can also + switch between using explicit fog coordinates and the default fog generation + mode. + + Pressing the 'f' and 'b' keys move the viewer forward and backwards. Pressing + 'c' initiates the default fog generation. Pressing capital 'C' restores + explicit fog coordinates. Pressing '1', '2', '3', '8', '9', and '0' add or + subtract from the fog coordinate values at one of the three vertices of the + triangle. +-} + +import Control.Monad ( when ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { f1, f2, f3 :: IORef (FogCoord1 GLfloat) } + +makeState :: IO State +makeState = do + f1' <- newIORef (FogCoord1 1) + f2' <- newIORef (FogCoord1 5) + f3' <- newIORef (FogCoord1 10) + return $ State { f1 = f1', f2 = f2', f3 = f3' } + +-- Initialize fog +myInit :: IO () +myInit = do + let theFogColor = Color4 0 0.25 0.25 1 + fog $= Enabled + fogMode $= Exp 0.25 + fogColor $= theFogColor + hint Fog $= DontCare + fogCoordSrc $= FogCoord + clearColor $= theFogColor + +drawTriangle :: State -> (State -> IORef (FogCoord1 GLfloat)) -> Vertex3 GLfloat -> IO () +drawTriangle state f v = do + fc <- get (f state) + fogCoord fc + vertex v + +-- display draws a triangle at an angle. +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + + color (Color3 1 0.75 (0 :: GLfloat)) + renderPrimitive Triangles $ do + drawTriangle state f1 (Vertex3 2 (-2) 0 ) + drawTriangle state f2 (Vertex3 (-2) 0 (-5)) + drawTriangle state f3 (Vertex3 0 2 (-10)) + + swapBuffers + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 45 1 0.25 25 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-5 :: GLfloat)) + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case c of + 'c' -> setSrc FragmentDepth + 'C' -> setSrc FogCoord + '1' -> inc f1 0.25 + '2' -> inc f2 0.25 + '3' -> inc f3 0.25 + '8' -> inc f1 (-0.25) + '9' -> inc f2 (-0.25) + '0' -> inc f3 (-0.25) + 'b' -> trans (-0.25) + 'f' -> trans 0.25 + '\27' -> exitWith ExitSuccess + _ -> return () + where setSrc :: FogCoordSrc -> IO () + setSrc s = do + fogCoordSrc $= s + postRedisplay Nothing + + inc :: (State -> IORef (FogCoord1 GLfloat)) -> GLfloat -> IO () + inc f x = do + FogCoord1 oldValue <- get (f state) + let newValue = oldValue + x + when (newValue > 0) $ do + f state $= FogCoord1 newValue + postRedisplay Nothing + + trans :: GLfloat -> IO () + trans x = do + matrixMode $= Modelview 0 + translate (Vector3 0 0 x) + postRedisplay Nothing +keyboard _ _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + createWindow progName + state <- makeState + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state + mainLoop + + diff --git a/examples/RedBook/FogIndex.hs b/examples/RedBook/FogIndex.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/FogIndex.hs @@ -0,0 +1,76 @@ +{- + FogIndex.hs (adapted from fogindex.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws 5 wireframe spheres, each at a different z distance from + the eye, in linear fog. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Initialize color map and fog. Set screen clear color to end of color ramp. +numColors, rampStart :: GLint +numColors = 32 +rampStart = 16 + +myInit :: IO () +myInit = do + depthFunc $= Just Less + + flip mapM_ [ 0 .. numColors - 1 ] $ \i -> do + let shade = fromIntegral (numColors - i) / fromIntegral numColors + colorMapEntry (Index1 (rampStart + i)) $= Color3 shade shade shade + fog $= Enabled + + fogMode $= Linear 1 6 + fogIndex $= Index1 numColors + hint Fog $= Nicest + clearIndex $= Index1 (fromIntegral (numColors + rampStart - 1)) + +renderSpehere :: Vector3 GLfloat -> IO () +renderSpehere xyz = + preservingMatrix $ do + translate xyz + renderObject Wireframe (Sphere' 0.4 16 16) + +-- display draws 5 spheres at different z positions. +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + index (Index1 rampStart) + mapM_ renderSpehere [ Vector3 x (-0.5) (-3 - x) | x <- [-2 .. 2] ] + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10.0) 10.0 + else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10.0) 10.0 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, color index +-- display mode, depth buffer, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, IndexMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display + mainLoop diff --git a/examples/RedBook/Font.hs b/examples/RedBook/Font.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Font.hs @@ -0,0 +1,127 @@ +{- + Font.hs (adapted from font.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Draws some text in a bitmapped font. Uses bitmap and other pixel routines. + Also demonstrates use of display lists. +-} + +import Control.Monad ( zipWithM_ ) +import Data.List ( genericDrop, genericLength ) +import Foreign.C.String ( castCharToCChar ) +import Foreign.Marshal.Array ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +space :: [GLubyte] +space = [ + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 ] + +letters :: [[GLubyte]] +letters = [ + [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xff, 0xc3, 0xc3, 0xc3, 0x66, 0x3c, 0x18 ], + [ 0x00, 0x00, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ], + [ 0x00, 0x00, 0x7e, 0xe7, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xe7, 0x7e ], + [ 0x00, 0x00, 0xfc, 0xce, 0xc7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc7, 0xce, 0xfc ], + [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0xc0, 0xc0, 0xfc, 0xc0, 0xc0, 0xc0, 0xc0, 0xff ], + [ 0x00, 0x00, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xfc, 0xc0, 0xc0, 0xc0, 0xff ], + [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xcf, 0xc0, 0xc0, 0xc0, 0xc0, 0xe7, 0x7e ], + [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xff, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], + [ 0x00, 0x00, 0x7e, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x7e ], + [ 0x00, 0x00, 0x7c, 0xee, 0xc6, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06 ], + [ 0x00, 0x00, 0xc3, 0xc6, 0xcc, 0xd8, 0xf0, 0xe0, 0xf0, 0xd8, 0xcc, 0xc6, 0xc3 ], + [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0 ], + [ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xdb, 0xff, 0xff, 0xe7, 0xc3 ], + [ 0x00, 0x00, 0xc7, 0xc7, 0xcf, 0xcf, 0xdf, 0xdb, 0xfb, 0xf3, 0xf3, 0xe3, 0xe3 ], + [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xe7, 0x7e ], + [ 0x00, 0x00, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ], + [ 0x00, 0x00, 0x3f, 0x6e, 0xdf, 0xdb, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0x66, 0x3c ], + [ 0x00, 0x00, 0xc3, 0xc6, 0xcc, 0xd8, 0xf0, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ], + [ 0x00, 0x00, 0x7e, 0xe7, 0x03, 0x03, 0x07, 0x7e, 0xe0, 0xc0, 0xc0, 0xe7, 0x7e ], + [ 0x00, 0x00, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0xff ], + [ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], + [ 0x00, 0x00, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], + [ 0x00, 0x00, 0xc3, 0xe7, 0xff, 0xff, 0xdb, 0xdb, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ], + [ 0x00, 0x00, 0xc3, 0x66, 0x66, 0x3c, 0x3c, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3 ], + [ 0x00, 0x00, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3 ], + [ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0x60, 0x30, 0x7e, 0x0c, 0x06, 0x03, 0x03, 0xff ]] + +charToGLubyte :: Char -> GLubyte +charToGLubyte = fromIntegral . castCharToCChar + +makeRasterFont :: IO DisplayList +makeRasterFont = do + rowAlignment Unpack $= 1 + + fontDisplayLists@(fontOffset:_) <- genObjectNames 128 + let listsStartingWith ch = genericDrop (charToGLubyte ch) fontDisplayLists + makeLetter dl letter = + defineList dl Compile $ + withArray letter $ + bitmap (Size 8 13) (Vertex2 0 2) (Vector2 10 0) + + zipWithM_ makeLetter (listsStartingWith 'A') letters + makeLetter (head (listsStartingWith ' ')) space + return fontOffset + +myInit :: IO DisplayList +myInit = do + shadeModel $= Flat + makeRasterFont + +printString :: DisplayList -> String -> IO () +printString fontOffset s = + preservingAttrib [ ListAttributes ] $ do + listBase $= fontOffset + withArray (map charToGLubyte s) $ + callLists (genericLength s) UnsignedByte + +-- Everything above this line could be in a library +-- that defines a font. To make it work, you've got +-- to call makeRasterFont before you start making +-- calls to printString. +display :: DisplayList -> DisplayCallback +display fontOffset = do + let white = Color3 1 1 1 + + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + color3f white + + rasterPos2i (Vertex2 20 60) + printString fontOffset "THE QUICK BROWN FOX JUMPS" + rasterPos2i (Vertex2 20 40) + printString fontOffset "OVER A LAZY DOG" + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop +-- Open window with initial window size, title bar, +-- RGBA display mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 300 100 + initialWindowPosition $= Position 100 100 + createWindow progName + fontOffset <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display fontOffset + mainLoop diff --git a/examples/RedBook/Hello.hs b/examples/RedBook/Hello.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Hello.hs @@ -0,0 +1,55 @@ +{- + Hello.hs (adapted from hello.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This is a simple, introductory OpenGL program. +-} + +import Graphics.UI.GLUT + +display :: DisplayCallback +display = do + -- clear all pixels + clear [ ColorBuffer ] + + -- draw white polygon (rectangle) with corners at + -- (0.25, 0.25, 0.0) and (0.75, 0.75, 0.0) + color (Color3 1.0 1.0 (1.0 :: GLfloat)) + -- resolve overloading, not needed in "real" programs + let vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Polygon $ mapM_ vertex3f [ + Vertex3 0.25 0.25 0.0, + Vertex3 0.75 0.25 0.0, + Vertex3 0.75 0.75 0.0, + Vertex3 0.25 0.75 0.0] + + -- don't wait! + -- start processing buffered OpenGL routines + flush + +myInit :: IO () +myInit = do + -- select clearing color + clearColor $= Color4 0 0 0 0 + + -- initialize viewing values + matrixMode $= Projection + loadIdentity + ortho 0 1 0 1 (-1) 1 + +-- Declare initial window size, position, and display mode (single buffer and +-- RGBA). Open window with "hello" in its title bar. Call initialization +-- routines. Register callback function to display graphics. Enter main loop and +-- process events. +main :: IO () +main = do + getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + createWindow "hello" + myInit + displayCallback $= display + mainLoop diff --git a/examples/RedBook/Histogram.hs b/examples/RedBook/Histogram.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Histogram.hs @@ -0,0 +1,85 @@ +{- + Histogram.hs (adapted from histogram.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Compute the histogram of the image. This program illustrates the use of + the histogram function. +-} + +import Control.Monad ( zipWithM_ ) +import Foreign ( allocaArray, peekArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT +import ReadImage + +histogramSize :: Int +histogramSize = 256 -- Must be a power of 2 + +myInit :: IO () +myInit = do + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + + histogram NoProxy $= Just (fromIntegral histogramSize, RGB', PassThrough) + +display :: Size -> PixelData a -> DisplayCallback +display size pixels = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 1 1) + drawPixels size pixels + + values <- allocaArray histogramSize $ \buf -> do + -- Note: The example in the Red Book uses GL_UNSIGNED_SHORT here, + -- but we are more honest by using Short... + getHistogram Reset (PixelData RGB Short buf) + peekArray histogramSize buf + + -- Plot histogram + zipWithM_ (plotHistogram values) + [ Color3 1 0 0, Color3 0 1 0, Color3 0 0 1 ] + [\(Color3 r _ _) -> r, \(Color3 _ g _) -> g, \(Color3 _ _ b) -> b ] + flush + +plotHistogram :: + [Color3 GLshort] -> Color3 GLfloat -> (Color3 GLshort -> GLshort) -> IO () +plotHistogram values c selectComponent = + renderPrimitive LineStrip $ do + color c + zipWithM_ (\i h -> vertex (Vertex2 i (selectComponent h))) [ 0 .. ] values + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral histogramSize) 0 10000 (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char 's') Down _ _ = do + Just (width, format, sink) <- get (histogram NoProxy) + let newSink = if sink == Sink then PassThrough else Sink + histogram NoProxy $= Just (width, format, newSink) + postRedisplay Nothing +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, args) <- getArgsAndInitialize + (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= size + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display size pixels + mainLoop diff --git a/examples/RedBook/Image.hs b/examples/RedBook/Image.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Image.hs @@ -0,0 +1,116 @@ +{- + Image.hs (adapted from image.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates drawing pixels and shows the effect of + drawPixels, copyPixels, and pixelZoom. + + Interaction: moving the mouse while pressing the mouse button will copy + the image in the lower-left corner of the window to the mouse position, + using the current pixel zoom factors. There is no attempt to prevent you + from drawing over the original image. If you press the 'r' key, the + original image and zoom factors are reset. If you press the 'z' or 'Z' + keys, you change the zoom factors. +-} + +import Data.Bits ( (.&.) ) +import Data.IORef ( IORef, newIORef ) +import Foreign ( newArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { zoomFactor :: IORef GLfloat } + +makeState :: IO State +makeState = do + z <- newIORef 1 + return $ State { zoomFactor = z } + +-- Create checkerboard image +checkImageSize :: Size +checkImageSize = Size 64 64 + +type Image = PixelData (Color3 GLubyte) + +makeCheckImage :: Size -> GLsizei -> (GLubyte -> (Color3 GLubyte)) -> IO Image +makeCheckImage (Size w h) n f = + fmap (PixelData RGB UnsignedByte) $ + newArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] + +myInit :: IO Image +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + rowAlignment Unpack $= 1 + makeCheckImage checkImageSize 0x8 (\c -> Color3 c c c) + +display :: Image -> DisplayCallback +display pixelData = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 0 0) + drawPixels checkImageSize pixelData + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + matrixMode $= Modelview 0 + loadIdentity + +motion :: State -> MotionCallback +motion state (Position x y) = do + Size _ height <- get windowSize + let screenY = height - y + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 x screenY) + z <- get (zoomFactor state) + pixelZoom $= (z, z) + copyPixels (Position 0 0) checkImageSize CopyColor + pixelZoom $= (1, 1) + flush + +resetZoomFactor :: State -> IO () +resetZoomFactor state = do + zoomFactor state $= 1.0 + postRedisplay Nothing + putStrLn "zoomFactor reset to 1.0" + +incZoomFactor :: State -> GLfloat -> IO () +incZoomFactor state inc = do + zoomFactor state $~! (max 0.5 . min 3.0 . (+ inc)) + get (zoomFactor state) >>= putStrLn . ("zoomFactor is now " ++) . show + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char 'r') Down _ _ = resetZoomFactor state +keyboard state (Char 'R') Down _ _ = resetZoomFactor state +keyboard state (Char 'z') Down _ _ = incZoomFactor state 0.5 +keyboard state (Char 'Z') Down _ _ = incZoomFactor state (-0.5) +keyboard _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + createWindow progName + state <- makeState + checkImage <- myInit + displayCallback $= display checkImage + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + motionCallback $= Just (motion state) + mainLoop diff --git a/examples/RedBook/Light.hs b/examples/RedBook/Light.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Light.hs @@ -0,0 +1,62 @@ +{- + Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the use of the OpenGL lighting model. A sphere + is drawn using a grey material characteristic. A single light source + illuminates the object. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 50 + position (Light 0) $= Vertex4 1 1 1 0 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + renderObject Solid (Sphere' 1 20 16) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-1.5) 1.5 (-1.5 * hf/wf) (1.5 * hf/wf) (-10) 10 + else ortho (-1.5 * wf/hf) (1.5 * wf/hf) (-1.5) 1.5 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/Lines.hs b/examples/RedBook/Lines.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Lines.hs @@ -0,0 +1,88 @@ +{- + Lines.hs (adapted from lines.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates geometric primitives and their attributes. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +drawOneLine :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO () +drawOneLine p1 p2 = renderPrimitive Lines $ do vertex p1; vertex p2 + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + -- select white for all lines + color (Color3 1.0 1.0 1.0 :: Color3 GLfloat) + + -- in 1st row, 3 lines, each with a different stipple + lineStipple $= Just (1, 0x0101) -- dotted + drawOneLine (Vertex2 50 125) (Vertex2 150 125) + lineStipple $= Just (1, 0x00FF) -- dashed + drawOneLine (Vertex2 150 125) (Vertex2 50 125) + lineStipple $= Just (1, 0x1C47) -- dash/dot/dash + drawOneLine (Vertex2 250 125) (Vertex2 350 125) + + -- in 2nd row, 3 wide lines, each with different stipple + lineWidth $= 5.0 + lineStipple $= Just (1, 0x0101) -- dotted + drawOneLine (Vertex2 50 100) (Vertex2 150 100) + lineStipple $= Just (1, 0x00FF) -- dashed + drawOneLine (Vertex2 150 100) (Vertex2 250 100) + lineStipple $= Just (1, 0x1C47) -- dash/dot/dash + drawOneLine (Vertex2 250 100) (Vertex2 350 100) + lineWidth $= 1.0 + + -- in 3rd row, 6 lines, with dash/dot/dash stipple + -- as part of a single connected line strip + lineStipple $= Just (1, 0x1C47) -- dash/dot/dash + renderPrimitive LineStrip $ mapM_ vertex [ Vertex2 (50+(i*50)) (75 :: GLint) | i <- [0..6] ] + + -- in 4th row, 6 independent lines with same stipple + sequence_ [ drawOneLine (Vertex2 (50+( i *50)) 50) + (Vertex2 (50+((i+1)*50)) 50) | i <- [0..5] ] + + -- in 5th row, 1 line, with dash/dot/dash stipple + -- and a stipple repeat factor of 5 + lineStipple $= Just (5, 0x1C47) -- dash/dot/dash + drawOneLine (Vertex2 50 25) (Vertex2 350 25) + + lineStipple $= Nothing + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + -- the following line is not in the original example, but it's good style... + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Request double buffer display mode. +-- Register mouse input callback functions +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 400 150 + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/MVArray.hs b/examples/RedBook/MVArray.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/MVArray.hs @@ -0,0 +1,87 @@ +{- + MVArray.hs (adapted from mvarray.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates multiple vertex arrays, specifically the OpenGL + routine multiDrawElements. +-} + +import Control.Monad ( unless ) +import Data.List ( genericLength ) +import Foreign ( Storable, Ptr, newArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(..) ) +import Graphics.UI.GLUT + +data MultiDrawInfo a = MultiDrawInfo (Ptr GLsizei) (Ptr (Ptr a)) GLsizei + +makeMultiDrawInfo :: Storable a => [[a]] -> IO (MultiDrawInfo a) +makeMultiDrawInfo indicesLists = do + count <- newArray $ map genericLength indicesLists + indices <- newArray =<< mapM newArray indicesLists + return $ MultiDrawInfo count indices (genericLength indicesLists) + +setupPointer :: IO () +setupPointer = do + clientState VertexArray $= Enabled + vertices <- newArray ([ + Vertex2 25 25, + Vertex2 75 75, + Vertex2 100 125, + Vertex2 150 75, + Vertex2 200 175, + Vertex2 250 150, + Vertex2 300 125, + Vertex2 100 200, + Vertex2 150 250, + Vertex2 200 225, + Vertex2 250 300, + Vertex2 300 250 ] :: [Vertex2 GLint]) + arrayPointer VertexArray $= VertexArrayDescriptor 2 Int 0 vertices + +myInit :: IO (MultiDrawInfo GLubyte) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + setupPointer + makeMultiDrawInfo [ [ 0, 1, 2, 3, 4, 5, 6 ], + [ 1, 7, 8, 9, 10, 11 ] ] + +display :: MultiDrawInfo GLubyte -> DisplayCallback +display (MultiDrawInfo count indices primCount) = do + clear [ ColorBuffer ] + color (Color3 1 1 1 :: Color3 GLfloat) + multiDrawElements LineStrip count UnsignedByte indices primCount + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + -- the following line is not in the original example, but it's good style... + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 350 350 + initialWindowPosition $= Position 100 100 + createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + exts <- get glExtensions + unless ("GL_EXT_multi_draw_arrays" `elem` exts) $ do + putStrLn "Sorry, this demo requires the GL_EXT_multi_draw_arrays extension." + exitFailure + multiDrawInfo <- myInit + displayCallback $= display multiDrawInfo + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/Material.hs b/examples/RedBook/Material.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Material.hs @@ -0,0 +1,149 @@ +{- + Material.hs (adapted from material.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the use of the GL lighting model. Several + objects are drawn using different material characteristics. A single + light source illuminates the objects. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Initialize z-buffer, projection matrix, light source, and lighting model. +-- Do not specify a material property here. + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0.1 0.1 0 + depthFunc $= Just Less + shadeModel $= Smooth + + ambient (Light 0) $= Color4 0 0 0 1 + diffuse (Light 0) $= Color4 1 1 1 1 + position (Light 0) $= Vertex4 0 3 2 0 + lightModelAmbient $= Color4 0.4 0.4 0.4 1 + lightModelLocalViewer $= Disabled + + lighting $= Enabled + light (Light 0) $= Enabled + +-- Draw twelve spheres in 3 rows with 4 columns. +-- The spheres in the first row have materials with no ambient reflection. +-- The second row has materials with significant ambient reflection. +-- The third row has materials with colored ambient reflection. +-- +-- The first column has materials with blue, diffuse reflection only. +-- The second column has blue diffuse reflection, as well as specular +-- reflection with a low shininess exponent. +-- The third column has blue diffuse reflection, as well as specular +-- reflection with a high shininess exponent (a more concentrated highlight). +-- The fourth column has materials which also include an emissive component. +-- +-- translate is used to move spheres to their appropriate locations. + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + + let draw :: GLfloat -> GLfloat -> Color4 GLfloat -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> Color4 GLfloat -> IO () + draw row column amb dif spc shi emi = + preservingMatrix $ do + translate (Vector3 (2.5 * (column - 2.5)) (3 * (2 - row)) 0) + materialAmbient Front $= amb + materialDiffuse Front $= dif + materialSpecular Front $= spc + materialShininess Front $= shi + materialEmission Front $= emi + renderObject Solid (Sphere' 1 16 16) + + noMat = Color4 0 0 0 1 + matAmbient = Color4 0.7 0.7 0.7 1 + matAmbientColor = Color4 0.8 0.8 0.2 1 + matDiffuse = Color4 0.1 0.5 0.8 1 + matSpecular = Color4 1 1 1 1 + noShininess = 0 + lowShininess = 5 + highShininess = 100 + matEmission = Color4 0.3 0.2 0.2 0 + + -- draw sphere in first row, first column + -- diffuse reflection only; no ambient or specular + draw 1 1 noMat matDiffuse noMat noShininess noMat + + -- draw sphere in first row, second column + -- diffuse and specular reflection; low shininess; no ambient + draw 1 2 noMat matDiffuse matSpecular lowShininess noMat + + -- draw sphere in first row, third column + -- diffuse and specular reflection; high shininess; no ambient + draw 1 3 noMat matDiffuse matSpecular highShininess noMat + + -- draw sphere in first row, fourth column + -- diffuse reflection; emission; no ambient or specular reflection + draw 1 4 noMat matDiffuse noMat noShininess matEmission + + -- draw sphere in second row, first column + -- ambient and diffuse reflection; no specular + draw 2 1 matAmbient matDiffuse noMat noShininess noMat + + -- draw sphere in second row, second column + -- ambient, diffuse and specular reflection; low shininess + draw 2 2 matAmbient matDiffuse matSpecular lowShininess noMat + + -- draw sphere in second row, third column + -- ambient, diffuse and specular reflection; high shininess + draw 2 3 matAmbient matDiffuse matSpecular highShininess noMat + + -- draw sphere in second row, fourth column + -- ambient and diffuse reflection; emission; no specular + draw 2 4 matAmbient matDiffuse noMat noShininess matEmission + + -- draw sphere in third row, first column + -- colored ambient and diffuse reflection; no specular + draw 3 1 matAmbientColor matDiffuse noMat noShininess noMat + + -- draw sphere in third row, second column + -- colored ambient, diffuse and specular reflection; low shininess + draw 3 2 matAmbientColor matDiffuse matSpecular lowShininess noMat + + -- draw sphere in third row, third column + -- colored ambient, diffuse and specular reflection; high shininess + draw 3 3 matAmbientColor matDiffuse matSpecular highShininess noMat + + -- draw sphere in third row, fourth column + -- colored ambient and diffuse reflection; emission; no specular + draw 3 4 matAmbientColor matDiffuse noMat noShininess matEmission + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h * 2 + then ortho (-6) 6 (-3 * (hf * 2) / wf) (3 * (hf * 2) / wf) (-10) 10 + else ortho (-6 * wf / (hf * 2)) (6 * wf / (hf * 2)) (-3) 3 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 600 450 + createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/Minmax.hs b/examples/RedBook/Minmax.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Minmax.hs @@ -0,0 +1,64 @@ +{- + Minmax.hs (adapted from minmax.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Determine the minimum and maximum values of a group of pixels. This + demonstrates use of the minmax function. +-} + +import Foreign ( allocaArray, peekArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT +import ReadImage + +myInit :: IO () +myInit = do + rowAlignment Unpack $= 1 + clearColor $= Color4 0 0 0 0 + minmax $= Just (RGB', PassThrough) + +display :: Size -> PixelData a -> DisplayCallback +display size pixels = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let rasterPos2i = rasterPos :: Vertex2 GLint -> IO () + rasterPos2i (Vertex2 1 1) + drawPixels size pixels + flush + + [Color3 minR minG minB, Color3 maxR maxG maxB] <- allocaArray 2 $ \buf -> do + getMinmax Reset (PixelData RGB UnsignedByte buf) + peekArray 2 buf :: IO [Color3 GLubyte] + putStrLn (" Red : min = " ++ show minR ++ " max = " ++ show maxR) + putStrLn (" Green : min = " ++ show minG ++ " max = " ++ show maxG) + putStrLn (" Blue : min = " ++ show minB ++ " max = " ++ show maxB) + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, args) <- getArgsAndInitialize + (size, pixels) <- readImage (if null args then "Data/leeds.bin" else head args) + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= size + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display size pixels + mainLoop diff --git a/examples/RedBook/Mipmap.hs b/examples/RedBook/Mipmap.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Mipmap.hs @@ -0,0 +1,97 @@ +{- + Mipmap.hs (adapted from mipmap.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates using mipmaps for texture maps. To overtly show + the effect of mipmaps, each mipmap reduction level has a solidly colored, + contrasting texture image. Thus, the quadrilateral which is drawn is drawn + with several different colors. +-} + +import Control.Monad ( when ) +import Data.Maybe ( isJust, listToMaybe ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +makeImage :: Level -> TextureSize2D -> Color4 GLubyte -> IO () +makeImage level size@(TextureSize2D w h) col = + withArray (replicate (fromIntegral (w * h)) col) $ + texImage2D Nothing NoProxy level RGBA' size 0 . PixelData RGBA UnsignedByte + +makeImages :: [Color4 GLubyte] -> IO () +makeImages colors = sequence_ $ zipWith3 makeImage levels sizes colors + where numLevels = length colors + levels = [ 0 .. fromIntegral numLevels - 1 ] + sizes = reverse (take numLevels [ TextureSize2D s s | s <- iterate (* 2) 1 ]) + +myInit :: IO (Maybe TextureObject) +myInit = do + depthFunc $= Just Less + shadeModel $= Flat + + translate (Vector3 0 0 (-3.6 :: GLfloat)) + rowAlignment Unpack $= 1 + + exts <- get glExtensions + mbTexName <- if "GL_EXT_texture_object" `elem` exts + then fmap listToMaybe $ genObjectNames 1 + else return Nothing + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Just Nearest), Nearest) + + makeImages [ Color4 255 255 0 255, + Color4 255 0 255 255, + Color4 255 0 0 255, + Color4 0 255 0 255, + Color4 0 0 255 255, + Color4 255 255 255 255 ] + + textureFunction $= Decal + texture Texture2D $= Enabled + return mbTexName + +display :: Maybe TextureObject -> DisplayCallback +display mbTexName = do + clear [ ColorBuffer, DepthBuffer ] + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + -- resolve overloading, not needed in "real" programs + let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 ( -2) (-1) 0 ) + texCoord2f (TexCoord2 0 8); vertex3f (Vertex3 ( -2) 1 0 ) + texCoord2f (TexCoord2 8 8); vertex3f (Vertex3 2000 1 (-6000)) + texCoord2f (TexCoord2 8 0); vertex3f (Vertex3 2000 (-1) (-6000)) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30000 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 50 50 + createWindow progName + texName <- myInit + displayCallback $= display texName + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/Model.hs b/examples/RedBook/Model.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Model.hs @@ -0,0 +1,86 @@ +{- + Model.hs (adapted from model.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates modeling transformations. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +drawTriangle :: IO () +drawTriangle = do + -- resolve overloading, not needed in "real" programs + let vertex2f = vertex :: Vertex2 GLfloat -> IO () + renderPrimitive LineLoop $ do + vertex2f (Vertex2 0 25 ) + vertex2f (Vertex2 25 (-25)) + vertex2f (Vertex2 (-25) (-25)) + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + color3f (Color3 1 1 1) + + loadIdentity + color3f (Color3 1 1 1) + drawTriangle + + lineStipple $= Just (1, 0xF0F0) + loadIdentity + translatef (Vector3 (-20) 0 0) + drawTriangle + + lineStipple $= Just (1, 0xF00F) + loadIdentity + scalef 1.5 0.5 1.0 + drawTriangle + + lineStipple $= Just (1, 0x8888) + loadIdentity + rotatef 90 (Vector3 0 0 1) + drawTriangle + lineStipple $= Nothing + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-50) 50 (-50 * hf/wf) (50 * hf/wf) (-1) 1 + else ortho (-50 * wf/hf) (50 * wf/hf) (-50) 50 (-1) 1 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/MoveLight.hs b/examples/RedBook/MoveLight.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/MoveLight.hs @@ -0,0 +1,85 @@ +{- + MoveLight.hs (adapted from movelight.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates when to issue lighting and transformation + commands to render a model with a light which is moved by a + modeling transformation (rotate or translate). The light position + is reset after the modeling transformation is called. The eye + position does not change. + + A sphere is drawn using a grey material characteristic. A single + light source illuminates the object. + + Interaction: pressing the left mouse button alters the modeling + transformation (x rotation) by 30 degrees. The scene is then + redrawn with the light in a new position. +-} + +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { spin :: IORef Int } + +makeState :: IO State +makeState = do + s <- newIORef 0 + return $ State { spin = s } + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) + preservingMatrix $ do + s <- get (spin state) + rotate (fromIntegral s :: GLdouble) (Vector3 1 0 0) + position (Light 0) $= Vertex4 0 0 1.5 1 + translate (Vector3 0 0 1.5 :: Vector3 GLdouble) + lighting $= Disabled + color (Color3 0 1 1 :: Color3 GLfloat) + renderObject Wireframe (Cube 0.1) + lighting $= Enabled + renderObject Solid (Torus 0.275 0.85 8 15) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 40 (fromIntegral w / fromIntegral h) 1 20 + matrixMode $= Modelview 0 + loadIdentity + +keyboardMouse :: State -> KeyboardMouseCallback +keyboardMouse state (MouseButton LeftButton) Down _ _ = do + spin state $~ ((`mod` 360) . (+ 30)) + postRedisplay Nothing +keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboardMouse _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboardMouse state) + mainLoop diff --git a/examples/RedBook/MultiTex.hs b/examples/RedBook/MultiTex.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/MultiTex.hs @@ -0,0 +1,109 @@ +{- + MultiTex.hs (adapted from multitex.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( unless ) +import Foreign ( withArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +specifyTexture :: TextureSize2D -> (GLubyte -> GLubyte -> Color4 GLubyte) -> IO () +specifyTexture size@(TextureSize2D w h) f = + withArray [ f i j | i <- [ 0 .. fromIntegral w - 1 ], + j <- [ 0 .. fromIntegral h - 1] ] $ + texImage2D Nothing NoProxy 0 RGBA' size 0 . PixelData RGBA UnsignedByte + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + rowAlignment Unpack $= 1 + + [texName0, texName1] <- genObjectNames 2 + textureBinding Texture2D $= Just texName0 + -- Note: We use much brighter colors than in the original example where + -- everything was almost black. + specifyTexture (TextureSize2D 32 32) (\i j -> Color4 (i*8) (j*8) ((i*j) `div` 4) 255) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + + textureBinding Texture2D $= Just texName1 + specifyTexture (TextureSize2D 16 16) (\i j -> Color4 255 (i*16) (j*16) 255) + textureFilter Texture2D $= ((Linear', Nothing), Linear') + textureWrapMode Texture2D S $= (Repeated, ClampToEdge) + textureWrapMode Texture2D T $= (Repeated, ClampToEdge) + -- Use the two texture objects to define two texture units + -- for use in multitexturing + activeTexture $= TextureUnit 0 + texture Texture2D $= Enabled + textureBinding Texture2D $= Just texName0 + textureFunction $= Replace + matrixMode $= Texture + loadIdentity + translate (Vector3 0.5 0.5 (0 :: GLfloat)) + rotate (45 :: GLfloat) (Vector3 0 0 1) + translate (Vector3 (-0.5) (-0.5) (0 :: GLfloat)) + matrixMode $= Modelview 0 + activeTexture $= TextureUnit 1 + texture Texture2D $= Enabled + textureBinding Texture2D $= Just texName1 + textureFunction $= Modulate + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + -- resolve overloading, not needed in "real" programs + let multiTexCoord2f = multiTexCoord :: TextureUnit -> TexCoord2 GLfloat -> IO () + vertex2f = vertex :: Vertex2 GLfloat -> IO () + renderPrimitive Triangles $ do + multiTexCoord2f (TextureUnit 0) (TexCoord2 0 0) + multiTexCoord2f (TextureUnit 1) (TexCoord2 1 0) + vertex2f (Vertex2 0 0) + multiTexCoord2f (TextureUnit 0) (TexCoord2 0.5 1) + multiTexCoord2f (TextureUnit 1) (TexCoord2 0.5 0) + vertex2f (Vertex2 50 100) + multiTexCoord2f (TextureUnit 0) (TexCoord2 1 0) + multiTexCoord2f (TextureUnit 1) (TexCoord2 1 1) + vertex2f (Vertex2 100 0) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D 0 100 0 (100*hf/wf) + else ortho2D 0 (100*wf/hf) 0 100 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + 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 diff --git a/examples/RedBook/Multisamp.hs b/examples/RedBook/Multisamp.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Multisamp.hs @@ -0,0 +1,137 @@ +{- + Multisamp.hs (adapted from multisamp.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws shows how to use multisampling to draw anti-aliased + geometric primitives. The same display list, a pinwheel of triangles and + lines of varying widths, is rendered twice. Multisampling is enabled when the + left side is drawn. Multisampling is disabled when the right side is drawn. + + Pressing the 'b' key toggles drawing of the checkerboard background. + Antialiasing is sometimes easier to see when objects are rendered over a + contrasting background. +-} + +import Control.Monad ( when ) +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { bgToggle :: IORef Bool } + +makeState :: IO State +makeState = do + b <- newIORef True + return $ State { bgToggle = b } + +data DisplayLists = DisplayLists { pinwheelList, backgroundList :: DisplayList } + +-- Print out state values related to multisampling. Create display list with +-- "pinwheel" of lines and triangles. +myInit :: IO DisplayLists +myInit = do + clearColor $= Color4 0 0 0 0 + sb <- get sampleBuffers + putStrLn ("number of sample buffers is " ++ show sb) + s <- get samples + putStrLn ("number of samples is " ++ show s) + + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + vertex2f = vertex :: Vertex2 GLfloat -> IO () + + p <- defineNewList Compile $ do + flip mapM_ [ 0 .. 18 ] $ \i -> + preservingMatrix $ do + rotate (360 * fromIntegral i / 19 :: GLfloat) (Vector3 0 0 1) + color3f (Color3 1 1 1) + lineWidth $= fromIntegral ((i `mod` 3 :: Int) + 1) + renderPrimitive Lines $ do + vertex2f (Vertex2 0.25 0.05) + vertex2f (Vertex2 0.9 0.2) + color3f (Color3 0 1 1) + renderPrimitive Triangles $ do + vertex2f (Vertex2 0.25 0) + vertex2f (Vertex2 0.9 0) + vertex2f (Vertex2 0.875 0.1) + + b <- defineNewList Compile $ do + color3f (Color3 1 0.5 0) + renderPrimitive Quads $ + flip mapM_ [ 0 .. 15 ] $ \i -> + flip mapM_ [ 0 .. 15 ] $ \j -> + when (((i + j) `mod` 2 :: Int) == 0) $ do + let ii = fromIntegral i * 0.25 + jj = fromIntegral j * 0.25 + vertex2f (Vertex2 (-2.0 + ii) (-2.0 + jj)) + vertex2f (Vertex2 (-2.0 + ii) (-1.75 + jj)) + vertex2f (Vertex2 (-1.75 + ii) (-1.75 + jj)) + vertex2f (Vertex2 (-1.75 + ii) (-2.0 + jj)) + + return $ DisplayLists { pinwheelList = p, backgroundList = b } + +-- Draw two sets of primitives, so that you can compare the user of +-- multisampling against its absence. +-- +-- This code enables antialiasing and draws one display list and disables and +-- draws the other display list +display :: State -> DisplayLists -> DisplayCallback +display state displayLists = do + clear [ ColorBuffer ] + + t <- get (bgToggle state) + when t $ + callList (backgroundList displayLists) + + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + + multisample $= Enabled + preservingMatrix $ do + translatef (Vector3 (-1) 0 0) + callList (pinwheelList displayLists) + + multisample $= Disabled + preservingMatrix $ do + translatef (Vector3 1 0 0) + callList (pinwheelList displayLists) + + swapBuffers + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= 2 * h + then ortho2D (-2) 2 (-2*hf/wf) (2*hf/wf) + else ortho2D (-2*wf/hf) (2*wf/hf) (-2) 2 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'b' -> do bgToggle state $~ not; postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode, Multisampling ] + initialWindowSize $= Size 600 300 + createWindow progName + state <- makeState + displayLists <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state displayLists + mainLoop diff --git a/examples/RedBook/PickDepth.hs b/examples/RedBook/PickDepth.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/PickDepth.hs @@ -0,0 +1,126 @@ +{- + PickDepth.hs (adapted from pickdepth.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Picking is demonstrated in this program. In rendering mode, three + overlapping rectangles are drawn. When the left mouse button is pressed, + selection mode is entered with the picking matrix. Rectangles which are drawn + under the cursor position are "picked." Pay special attention to the depth + value range, which is returned. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + depthFunc $= Just Less + shadeModel $= Flat + depthRange $= (0, 1) -- The default z mapping + +-- The nine squares are drawn. Each square is given two names: one for the row +-- and the other for the column on the grid. The color of each square is +-- determined by its position on the grid, and the value in the board array. +-- Note: In contrast to the the original example, we always give names to +-- squares, regardless of the render mode. This simplifies the code a bit and +-- is even suggested by the Red Book. + +-- The three rectangles are drawn, each with a different name. Note that each +-- rectangle is drawn with a different z value. Note: In contrast to the the +-- original example, we always give names to squares, regardless of the render +-- mode. This simplifies the code a bit and is even suggested by the Red Book. +drawRects :: IO () +drawRects = do + -- resolve overloading, not needed in "real" programs + let color3 = color :: Color3 GLfloat -> IO () + vertex3 = vertex :: Vertex3 GLint -> IO () + loadName (Name 1) + renderPrimitive Quads $ do + color3 (Color3 1.0 1.0 0.0) + vertex3 (Vertex3 2 0 0) + vertex3 (Vertex3 2 6 0) + vertex3 (Vertex3 6 6 0) + vertex3 (Vertex3 6 0 0) + loadName (Name 2) + renderPrimitive Quads $ do + color3 (Color3 0.0 1.0 1.0) + vertex3 (Vertex3 3 2 (-1)) + vertex3 (Vertex3 3 8 (-1)) + vertex3 (Vertex3 8 8 (-1)) + vertex3 (Vertex3 8 2 (-1)) + loadName (Name 3) + renderPrimitive Quads $ do + color3 (Color3 1.0 0.0 1.0) + vertex3 (Vertex3 0 2 (-2)) + vertex3 (Vertex3 0 7 (-2)) + vertex3 (Vertex3 5 7 (-2)) + vertex3 (Vertex3 5 2 (-2)) + +-- processHits prints the hit records. +processHits :: Maybe[HitRecord] -> IO () +processHits Nothing = putStrLn "selection buffer overflow" +processHits (Just hitRecords) = do + putStrLn ("hits = " ++ show (length hitRecords)) + flip mapM_ hitRecords $ \(HitRecord z1 z2 names) -> do + putStrLn (" number of names for hit = " ++ show (length names)) + putStr (" z1 is " ++ show z1) + putStrLn ("; z2 is " ++ show z2) + putStr " the name is" + sequence_ [ putStr (" " ++ show n) | Name n <- names ] + putChar '\n' + +-- pickRects() sets up selection mode, name stack, and projection matrix for +-- picking. Then the objects are drawn. + +bufSize :: GLsizei +bufSize = 512 + +pickRects :: KeyboardMouseCallback +pickRects (MouseButton LeftButton) Down _ (Position x y) = do + vp@(_, (Size _ height)) <- get viewport + (_, maybeHitRecords) <- getHitRecords bufSize $ + withName (Name 0) $ do + matrixMode $= Projection + preservingMatrix $ do + loadIdentity + -- create 5x5 pixel picking region near cursor location + pickMatrix (fromIntegral x, fromIntegral height - fromIntegral y) (5, 5) vp + ortho 0 8 0 8 (-0.5) 2.5 + drawRects + flush + processHits maybeHitRecords + postRedisplay Nothing +pickRects (Char '\27') Down _ _ = exitWith ExitSuccess +pickRects _ _ _ _ = return () + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + drawRects + flush + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho 0 8 0 8 (-0.5) 2.5 + matrixMode $= Modelview 0 + loadIdentity + +-- Main Loop +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 200 200 + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just pickRects + mainLoop diff --git a/examples/RedBook/PickSquare.hs b/examples/RedBook/PickSquare.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/PickSquare.hs @@ -0,0 +1,119 @@ +{- + PickSquare.hs (adapted from picksquare.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Use of multiple names and picking are demonstrated. A 3x3 grid of squares is + drawn. When the left mouse button is pressed, all squares under the cursor + position have their color changed. +-} + +import Data.Array ( Array, listArray, (!) ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +type Board = Array (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 diff --git a/examples/RedBook/Planet.hs b/examples/RedBook/Planet.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Planet.hs @@ -0,0 +1,83 @@ +{- + Planet.hs (adapted from planet.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program shows how to composite modeling transformations to draw + translated and rotated models. Interaction: pressing the d and y keys + (day and year) alters the rotation of the planet around the sun. +-} + +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { year, day :: IORef GLint } + +makeState :: IO State +makeState = do + y <- newIORef 0 + d <- newIORef 0 + return $ State { year = y, day = d } + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + color3f (Color3 1 1 1) + + preservingMatrix $ do + renderObject Wireframe (Sphere' 1 20 16) -- draw sun + y <- get (year state) + rotate (fromIntegral y :: GLfloat) (Vector3 0 1 0) + translatef (Vector3 2 0 0) + d <- get (day state) + rotate (fromIntegral d :: GLfloat) (Vector3 0 1 0) + renderObject Wireframe (Sphere' 0.2 10 8) -- draw smaller planet + + swapBuffers + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 20 + matrixMode $= Modelview 0 + loadIdentity + lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case c of + 'd' -> update day 10 + 'D' -> update day (-10) + 'y' -> update year 10 + 'Y' -> update year (-10) + '\27' -> exitWith ExitSuccess + _ -> return () + where update angle inc = do + angle state $~ ((`mod` 360) . (+ inc)) + postRedisplay Nothing +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + mainLoop diff --git a/examples/RedBook/PointP.hs b/examples/RedBook/PointP.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/PointP.hs @@ -0,0 +1,145 @@ +{- + PointP.hs (adapted from pointp.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates point parameters and their effect on point + primitives. 250 points are randomly generated within a 10 by 10 by 40 region, + centered at the origin. In some modes (including the default), points that + are closer to the viewer will appear larger. + + Pressing the 'c', 'l', and 'q' keys switch the point parameters attenuation + mode to constant, linear, or quadratic, respectively. + + Pressing the 'f' and 'b' keys move the viewer forward and backwards. In + either linear or quadratic attenuation mode, the distance from the viewer to + the point will change the size of the point primitive. + + Pressing the '+' and '-' keys will change the current point size. In this + program, the point size is bounded, so it will not get less than 2, nor + greater than the maximum returned by pointSizeRange. +-} + +import Control.Monad ( when, unless ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure ) +import System.Random ( randomRIO ) +import Graphics.UI.GLUT + +type Attenuation = (GLfloat,GLfloat,GLfloat) + +constant, linear, quadratic :: Attenuation +constant = (1, 0, 0 ) +linear = (0, 0.12, 0 ) +quadratic = (0, 0, 0.01) + +data State = State { distance :: IORef GLfloat } + +makeState :: IO State +makeState = do + d <- newIORef (-10) + return $ State { distance = d } + +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 diff --git a/examples/RedBook/PolyOff.hs b/examples/RedBook/PolyOff.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/PolyOff.hs @@ -0,0 +1,151 @@ +{- + PolyOff.hs (adapted from polyoff.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates polygon offset to draw a shaded polygon and its + wireframe counterpart without ugly visual artifacts ("stitching"). +-} + +import Control.Monad ( when ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure ) +import Graphics.UI.GLUT + +data State = State { + spinX, spinY :: IORef GLfloat, + tDist :: IORef GLfloat, + polyFactor :: IORef GLfloat, + polyUnits :: IORef GLfloat + } + +makeState :: IO State +makeState = do + x <- newIORef 0 + y <- newIORef 0 + t <- newIORef 0 + f <- newIORef 1 + u <- newIORef 1 + return $ State { spinX = x, spinY = y, tDist = t, polyFactor = f, polyUnits = u } + +-- display draws two spheres, one with a gray, diffuse material, the other +-- sphere with a magenta material with a specular highlight. +display :: State -> DisplayList -> DisplayCallback +display state sphereList = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + t <- get (tDist state) + translate (Vector3 0 0 t) + x <- get (spinX state) + rotate x (Vector3 1 0 0) + y <- get (spinY state) + rotate y (Vector3 0 1 0) + + materialAmbientAndDiffuse Front $= Color4 0.8 0.8 0.8 1 + materialSpecular Front $= Color4 0 0 0 1 + materialShininess Front $= 0 + lighting $= Enabled + light (Light 0) $= Enabled + polygonOffsetFill $= Enabled + f <- get (polyFactor state) + u <- get (polyUnits state) + polygonOffset $= (f, u) + callList sphereList + polygonOffsetFill $= Disabled + + lighting $= Disabled + light (Light 0) $= Disabled + color (Color3 1 1 (1 :: GLfloat)) + polygonMode $= (Line, Line) + callList sphereList + polygonMode $= (Fill, Fill) + + flush + +-- specify initial properties +-- create display list with sphere +-- initialize lighting and depth buffer +gfxinit :: IO DisplayList +gfxinit = do + clearColor $= Color4 0 0 0 1 + + sphereList <- defineNewList Compile $ + renderObject Solid (Sphere' 1 20 12) + + depthFunc $= Just Less + + ambient (Light 0) $= Color4 0 0 0 1 + diffuse (Light 0) $= Color4 1 1 1 1 + specular (Light 0) $= Color4 1 1 1 1 + position (Light 0) $= Vertex4 1 1 1 0 + lightModelAmbient $= Color4 0.2 0.2 0.2 1 + + return sphereList + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 45 (fromIntegral w / fromIntegral h) 1 10 + matrixMode $= Modelview 0 + loadIdentity + lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0) + +incSpin :: IORef GLfloat -> IO () +incSpin spinRef = do + let wrap n s = if s > n then s - n else s + spinRef $~ (wrap 360 . (+ 5)) + postRedisplay Nothing + +incDist :: State -> GLfloat -> IO () +incDist state inc = do + newDist <- fmap (+ inc) $ get (tDist state) + when (-5 <= newDist && newDist <= 4) $ do + tDist state $= newDist + postRedisplay Nothing + +incPoly :: String -> IORef GLfloat -> GLfloat -> IO () +incPoly name polyRef inc = do + polyRef $~ (+ inc) + p <- get polyRef + putStrLn (name ++ " is " ++ show p) + postRedisplay Nothing + +keyboardMouse :: State -> KeyboardMouseCallback +keyboardMouse state k Down _ _ = case k of + (MouseButton LeftButton) -> incSpin (spinX state) + (MouseButton MiddleButton) -> incSpin (spinY state) + (MouseButton RightButton) -> exitWith ExitSuccess + (Char 't') -> incDist state 0.5 + (Char 'T') -> incDist state (-0.5) + (Char 'F') -> incPoly "polyFactor" (polyFactor state) 0.1 + (Char 'f') -> incPoly "polyFactor" (polyFactor state) (-0.1) + (Char 'U') -> incPoly "polyUnits" (polyUnits state) 1 + (Char 'u') -> incPoly "polyUnits" (polyUnits state) (-1) + _ -> return () +keyboardMouse _ _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + createWindow progName + + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + version <- get (majorMinor glVersion) + when (version == (1,0)) $ do + putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." + putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," + putStrLn "you may be able to modify this program to make it run." + exitFailure + + state <- makeState + sphereList <- gfxinit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboardMouse state) + displayCallback $= display state sphereList + mainLoop diff --git a/examples/RedBook/Polys.hs b/examples/RedBook/Polys.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Polys.hs @@ -0,0 +1,84 @@ +{- + Polys.hs (adapted from polys.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates polygon stippling. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +fly :: IO GLpolygonstipple +fly = newPolygonStipple [ + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x03, 0x80, 0x01, 0xC0, 0x06, 0xC0, 0x03, 0x60, + 0x04, 0x60, 0x06, 0x20, 0x04, 0x30, 0x0C, 0x20, + 0x04, 0x18, 0x18, 0x20, 0x04, 0x0C, 0x30, 0x20, + 0x04, 0x06, 0x60, 0x20, 0x44, 0x03, 0xC0, 0x22, + 0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22, + 0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22, + 0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22, + 0x66, 0x01, 0x80, 0x66, 0x33, 0x01, 0x80, 0xCC, + 0x19, 0x81, 0x81, 0x98, 0x0C, 0xC1, 0x83, 0x30, + 0x07, 0xe1, 0x87, 0xe0, 0x03, 0x3f, 0xfc, 0xc0, + 0x03, 0x31, 0x8c, 0xc0, 0x03, 0x33, 0xcc, 0xc0, + 0x06, 0x64, 0x26, 0x60, 0x0c, 0xcc, 0x33, 0x30, + 0x18, 0xcc, 0x33, 0x18, 0x10, 0xc4, 0x23, 0x08, + 0x10, 0x63, 0xC6, 0x08, 0x10, 0x30, 0x0c, 0x08, + 0x10, 0x18, 0x18, 0x08, 0x10, 0x00, 0x00, 0x08] + +halftone :: IO GLpolygonstipple +halftone = newPolygonStipple . take 128 . cycle $ [ + 0xAA, 0xAA, 0xAA, 0xAA, 0x55, 0x55, 0x55, 0x55] + +display :: (GLpolygonstipple, GLpolygonstipple) -> DisplayCallback +display (flyStipple, halftoneStipple) = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + rectf = rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO () + color3f (Color3 1 1 1) + + -- draw one solid, unstippled rectangle, + -- then two stippled rectangles + rectf (Vertex2 25 25) (Vertex2 125 125) + polygonStipple $= Just flyStipple + rectf (Vertex2 125 25) (Vertex2 225 125) + polygonStipple $= Just halftoneStipple + rectf (Vertex2 225 25) (Vertex2 325 125) + polygonStipple $= (Nothing :: Maybe GLpolygonstipple) + + flush + +myInit :: IO (GLpolygonstipple, GLpolygonstipple) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + flyStipple <- fly + halftoneStipple <- halftone + return (flyStipple, halftoneStipple) + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0.0 (fromIntegral w) 0.0 (fromIntegral h) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 350 150 + createWindow progName + stipples <- myInit + displayCallback $= display stipples + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/Quadric.hs b/examples/RedBook/Quadric.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Quadric.hs @@ -0,0 +1,106 @@ +{- + Quadric.hs (adapted from quadric.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the use of the renderQuadric routine. Quadric + objects are created with some quadric properties and errors are reported. + Note that the cylinder has no top or bottom and the circle has a hole in it. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO (DisplayList, DisplayList, DisplayList, DisplayList) +myInit = do + clearColor $= Color4 0 0 0 0 + + materialAmbient Front $= Color4 0.5 0.5 0.5 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 50 + position (Light 0) $= Vertex4 1 1 1 0 + lightModelAmbient $= Color4 0.5 0.5 0.5 1 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + + -- Create 4 display lists, each with a different quadric object. + -- Different drawing styles and surface normal specifications + -- are demonstrated. + -- smooth shaded + dl1 <- newQuadricDL (Just Smooth) FillStyle (Sphere 0.75 15 10) + -- flat shaded + dl2 <- newQuadricDL (Just Flat) FillStyle (Cylinder 0.5 0.3 1 15 5) + -- all polygons wireframe + dl3 <- newQuadricDL Nothing LineStyle (Disk 0.25 1 20 4) + -- boundary only + dl4 <- newQuadricDL Nothing SilhouetteStyle (PartialDisk 0 1 20 4 0 225) + return (dl1, dl2, dl3, dl4) + +newQuadricDL :: QuadricNormal -> QuadricDrawStyle -> QuadricPrimitive -> IO DisplayList +newQuadricDL n s p = + defineNewList Compile $ do + renderQuadric (QuadricStyle n NoTextureCoordinates Outside s) p + reportErrors + +display :: (DisplayList, DisplayList, DisplayList, DisplayList) -> DisplayCallback +display (dl1, dl2, dl3, dl4) = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + color3f = color :: Color3 GLfloat -> IO () + + lighting $= Enabled + shadeModel $= Smooth + translatef (Vector3 (-1) (-1) 0) + callList dl1 + + shadeModel $= Flat + translatef (Vector3 0 2 0) + preservingMatrix $ do + rotatef 300 (Vector3 1 0 0) + callList dl2 + + lighting $= Disabled + color3f (Color3 0 1 1) + translatef (Vector3 2 (-2) 0) + callList dl3 + + color3f (Color3 1 1 0) + translatef (Vector3 0 2 0) + callList dl4 + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10) 10 + else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10) 10 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + displayLists <- myInit + displayCallback $= display displayLists + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/ReadImage.hs b/examples/RedBook/ReadImage.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/ReadImage.hs @@ -0,0 +1,65 @@ +{- + ReadImage.hs (adapted from readImage.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + Support for reading a file of raw RGB data: + 4 bytes big-endian width + 4 bytes big-endian height + width * height RGB byte triples +-} + +module ReadImage ( readImage ) where + +import Data.Word ( Word8, Word32 ) +import Control.Exception ( bracket ) +import Control.Monad ( when ) +import System.IO ( Handle, IOMode(ReadMode), openBinaryFile, hGetBuf, hClose ) +import System.IO.Error ( mkIOError, eofErrorType ) +import Foreign ( Ptr, alloca, mallocBytes, Storable(..) ) +import Graphics.UI.GLUT + +-- This is probably overkill, but anyway... +newtype Word32BigEndian = Word32BigEndian Word32 + +word32BigEndianToGLsizei :: Word32BigEndian -> GLsizei +word32BigEndianToGLsizei (Word32BigEndian x) = fromIntegral x + +instance Storable Word32BigEndian where + sizeOf ~(Word32BigEndian x) = sizeOf x + alignment ~(Word32BigEndian x) = alignment x + peek ptr = do + let numBytes = sizeOf (undefined :: Word32BigEndian) + bytes <- mapM (peekByteOff ptr) [ 0 .. numBytes - 1 ] :: IO [Word8] + let value = foldl (\val byte -> val * 256 + fromIntegral byte) 0 bytes + return $ Word32BigEndian value + poke = error "" + +-- This is the reason for all this stuff above... +readGLsizei :: Handle -> IO GLsizei +readGLsizei handle = + alloca $ \buf -> do + hGetBufFully handle buf (sizeOf (undefined :: Word32BigEndian)) + fmap word32BigEndianToGLsizei $ peek buf + +-- A handy variant of hGetBuf with additional error checking +hGetBufFully :: Handle -> Ptr a -> Int -> IO () +hGetBufFully handle ptr numBytes = do + bytesRead <- hGetBuf handle ptr numBytes + when (bytesRead /= numBytes) $ + ioError $ mkIOError eofErrorType "hGetBufFully" (Just handle) Nothing + +-- Closing a file is nice, even when an error occurs during reading. +withBinaryFile :: FilePath -> (Handle -> IO a) -> IO a +withBinaryFile filePath = bracket (openBinaryFile filePath ReadMode) hClose + +readImage :: FilePath -> IO (Size, PixelData a) +readImage filePath = + withBinaryFile filePath $ \handle -> do + width <- readGLsizei handle + height <- readGLsizei handle + let numBytes = fromIntegral (3 * width * height) + buf <- mallocBytes numBytes + hGetBufFully handle buf numBytes + return (Size width height, PixelData RGB UnsignedByte buf) diff --git a/examples/RedBook/Robot.hs b/examples/RedBook/Robot.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Robot.hs @@ -0,0 +1,89 @@ +{- + Robot.hs (adapted from robot.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program shows how to composite modeling transformations to draw + translated and rotated hierarchical models. Interaction: pressing the s + and e keys (shoulder and elbow) alters the rotation of the robot arm. +-} + +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { shoulder, elbow :: IORef GLint } + +makeState :: IO State +makeState = do + s <- newIORef 0 + e <- newIORef 0 + return $ State { shoulder = s, elbow = e } + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () + preservingMatrix $ do + translatef (Vector3 (-1) 0 0) + s <- get (shoulder state) + rotate (fromIntegral s :: GLfloat) (Vector3 0 0 1) + translatef (Vector3 1 0 0) + preservingMatrix $ do + scalef 2 0.4 1 + renderObject Wireframe (Cube 1) + translatef (Vector3 1 0 0) + e <- get (elbow state) + rotate (fromIntegral e :: GLfloat) (Vector3 0 0 1) + translatef (Vector3 1 0 0) + preservingMatrix $ do + scalef 2 0.4 1 + renderObject Wireframe (Cube 1) + swapBuffers + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 65 (fromIntegral w / fromIntegral h) 1 20 + matrixMode $= Modelview 0 + loadIdentity + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + translatef (Vector3 0 0 (-5)) + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case c of + 's' -> update shoulder 5 + 'S' -> update shoulder (-5) + 'e' -> update elbow 5 + 'E' -> update elbow (-5) + '\27' -> exitWith ExitSuccess + _ -> return () + where update joint inc = do + joint state $~ ((`mod` 360) . (+ inc)) + postRedisplay Nothing +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ DoubleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + mainLoop diff --git a/examples/RedBook/Scene.hs b/examples/RedBook/Scene.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Scene.hs @@ -0,0 +1,73 @@ +{- + Scene.hs (adapted from scene.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the use of the GL lighting model. Objects are + drawn using a grey material characteristic. A single light source + illuminates the objects. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Initialize material property and light source. +myInit :: IO () +myInit = do + ambient (Light 0) $= Color4 0 0 0 1 + diffuse (Light 0) $= Color4 1 1 1 1 + specular (Light 0) $= Color4 1 1 1 1 + -- light position is NOT default value + position (Light 0) $= Vertex4 1 1 1 0 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + rotate (20 :: GLfloat) (Vector3 1 0 0) + preservingMatrix $ do + translate (Vector3 (-0.75) 0.5 (0 :: GLfloat)) + rotate (90 :: GLfloat) (Vector3 1 0 0) + renderObject Solid (Torus 0.275 0.85 15 15) + preservingMatrix $ do + translate (Vector3 (-0.75) (-0.5) (0 :: GLfloat)) + rotate (270 :: GLfloat) (Vector3 1 0 0) + renderObject Solid (Cone 1 2 15 15) + preservingMatrix $ do + translate (Vector3 0.75 0 (-1 :: GLfloat)) + renderObject Solid (Sphere' 1 15 15) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-2.5) 2.5 (-2.5 * hf/wf) (2.5 * hf/wf) (-10) 10 + else ortho (-2.5 * wf/hf) (2.5 * wf/hf) (-2.5) 2.5 (-10) 10 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/Select.hs b/examples/RedBook/Select.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Select.hs @@ -0,0 +1,150 @@ +{- + Select.hs (adapted from select.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This is an illustration of the selection mode and name stack, which detects + whether objects which collide with a viewing volume. First, four triangles + and a rectangular box representing a viewing volume are drawn (drawScene + routine). The green triangle and yellow triangles appear to lie within the + viewing volume, but the red triangle appears to lie outside it. Then the + selection mode is entered (selectObjects routine). Drawing to the screen + ceases. To see if any collisions occur, the four triangles are called. In + this example, the green triangle causes one hit with the name 1, and the + yellow triangles cause one hit with the name 3. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- draw a triangle with vertices at (x1, y1), (x2, y2) and (x3, y3) at z units +-- away from the origin. +drawTriangle :: + Vertex2 GLfloat -> Vertex2 GLfloat -> Vertex2 GLfloat -> GLfloat -> IO () +drawTriangle (Vertex2 x1 y1) (Vertex2 x2 y2) (Vertex2 x3 y3) z = do + renderPrimitive Triangles $ mapM_ vertex [ + Vertex3 x1 y1 z, + Vertex3 x2 y2 z, + Vertex3 x3 y3 z] + +-- draw a rectangular box with these outer x, y, and z values +drawViewVolume :: Vertex3 GLfloat -> Vertex3 GLfloat -> IO () +drawViewVolume (Vertex3 x1 y1 z1) (Vertex3 x2 y2 z2) = do + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 1 1 1) + renderPrimitive LineLoop $ mapM_ vertex [ + Vertex3 x1 y1 (-z1), + Vertex3 x2 y1 (-z1), + Vertex3 x2 y2 (-z1), + Vertex3 x1 y2 (-z1)] + + renderPrimitive LineLoop $ mapM_ vertex [ + Vertex3 x1 y1 (-z2), + Vertex3 x2 y1 (-z2), + Vertex3 x2 y2 (-z2), + Vertex3 x1 y2 (-z2)] + + renderPrimitive Lines $ mapM_ vertex [ -- 4 lines + Vertex3 x1 y1 (-z1), + Vertex3 x1 y1 (-z2), + Vertex3 x1 y2 (-z1), + Vertex3 x1 y2 (-z2), + Vertex3 x2 y1 (-z1), + Vertex3 x2 y1 (-z2), + Vertex3 x2 y2 (-z1), + Vertex3 x2 y2 (-z2)] + +-- drawScene draws 4 triangles and a wire frame which represents the viewing +-- volume. +drawScene :: IO () +drawScene = do + matrixMode $= Projection + loadIdentity + perspective 40 (4/3) 1 100 + + matrixMode $= Modelview 0 + loadIdentity + lookAt (Vertex3 7.5 7.5 12.5) (Vertex3 2.5 2.5 (-5)) (Vector3 0 1 0) + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 0 1 0) -- green triangle + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-5) + color3f (Color3 1 0 0) -- red triangle + drawTriangle (Vertex2 2 7) (Vertex2 3 7) (Vertex2 2.5 8) (-5) + color3f (Color3 1 1 0) -- yellow triangles + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-1) + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-9) + drawViewVolume (Vertex3 0 0 0) (Vertex3 5 5 10) + +processHits :: Maybe [HitRecord] -> IO () +processHits Nothing = putStrLn "selection buffer overflow" +processHits (Just hitRecords) = do + putStrLn ("hits = " ++ show (length hitRecords)) + mapM_ (\(HitRecord z1 z2 names) -> do + putStrLn (" number of names for hit = " ++ show (length names)) + putStr (" z1 is " ++ show z1) + putStrLn ("; z2 is " ++ show z2) + putStr " the name is" + sequence_ [ putStr (" " ++ show n) | Name n <- names ] + putChar '\n') + hitRecords + +-- selectObjects "draws" the triangles in selection mode, assigning names for +-- the triangles. Note that the third and fourth triangles share one name, so +-- that if either or both triangles intersects the viewing/clipping volume, +-- only one hit will be registered. + +bufSize :: GLsizei +bufSize = 512 + +selectObjects :: IO () +selectObjects = do + (_, maybeHitRecords) <- getHitRecords bufSize $ do + withName (Name 0) $ do + preservingMatrix $ do + matrixMode $= Projection + loadIdentity + ortho 0 5 0 5 0 10 + matrixMode $= Modelview 0 + loadIdentity + loadName (Name 1) + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-5) + loadName (Name 2) + drawTriangle (Vertex2 2 7) (Vertex2 3 7) (Vertex2 2.5 8) (-5) + loadName (Name 3) + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-1) + drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-9) + flush + processHits maybeHitRecords + +myInit :: IO () +myInit = do + depthFunc $= Just Less + shadeModel $= Flat + +display :: DisplayCallback +display = do + clearColor $= Color4 0 0 0 0 + clear [ ColorBuffer, DepthBuffer ] + drawScene + selectObjects + flush + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 200 200 + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/ShadowMap.hs b/examples/RedBook/ShadowMap.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/ShadowMap.hs @@ -0,0 +1,255 @@ +{- + ShadowMap.hs (adapted from shadowmap.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE +-} + +import Control.Monad ( when, unless ) +import Data.IORef ( IORef, newIORef ) +import Foreign.Marshal.Array ( allocaArray ) +import Foreign.Ptr ( nullPtr ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +shadowMapSize :: TextureSize2D +shadowMapSize = TextureSize2D 256 256 + +fovy, nearPlane, farPlane :: GLdouble +fovy = 60 +nearPlane = 10 +farPlane = 100 + +lightPos :: Vertex4 GLfloat +lightPos = Vertex4 25 25 25 1 + +lookat :: Vertex3 GLdouble +lookat = Vertex3 0 0 0 + +up :: Vector3 GLdouble +up = Vector3 0 0 1 + +data State = State { + angle :: IORef GLdouble, + torusAngle :: IORef GLfloat, + showShadow :: IORef Bool, + animate :: IORef Bool, + funcMode :: IORef ComparisonFunction } + +makeState :: IO State +makeState = do + a <- newIORef 0 + t <- newIORef 0 + s <- newIORef False + n <- newIORef True + f <- newIORef Lequal + return $ State { angle = a, torusAngle = t, showShadow = s, + animate = n, funcMode = f } + +myInit :: IO () +myInit = do + texImage2D Nothing NoProxy 0 DepthComponent' shadowMapSize 0 + (PixelData DepthComponent UnsignedByte nullPtr) + + position (Light 0) $= lightPos + let white = Color4 1 1 1 1 + specular (Light 0) $= white + diffuse (Light 0) $= white + + textureWrapMode Texture2D S $= (Repeated, ClampToEdge) + textureWrapMode Texture2D T $= (Repeated, ClampToEdge) + textureFilter Texture2D $= ((Linear', Nothing), Linear') + textureCompareMode Texture2D $= Just Lequal + depthTextureMode Texture2D $= Luminance' + + colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse) + + cullFace $= Just Back + + depthFunc $= Just Less + light (Light 0) $= Enabled + lighting $= Enabled + texture Texture2D $= Enabled + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective fovy (fromIntegral w / fromIntegral h) nearPlane farPlane + matrixMode $= Modelview 0 + +idle :: State -> IdleCallback +idle state = do + angle state $~! (+ (pi / 10000)) + torusAngle state $~! (+ 0.1) + postRedisplay Nothing + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = do + case c of + '\27' -> exitWith ExitSuccess + 't' -> + texture Texture2D $~ \cap -> if cap == Enabled then Disabled else Enabled + 'm' -> do + fm <- get (funcMode state) + textureCompareMode Texture2D $~ maybe (Just fm) (const Nothing) + compareMode <- get (textureCompareMode Texture2D) + putStrLn ("Compare mode " ++ maybe "Off" (const "On") compareMode) + 'f' -> do + funcMode state $~ \fm -> if fm == Lequal then Gequal else Lequal + fm <- get (funcMode state) + putStrLn ("Operator " ++ show fm) + textureCompareMode Texture2D $~ maybe Nothing (const (Just fm)) + 's' -> showShadow state $~ not + 'p' -> do + animate state $~ not + animate' <- get (animate state) + idleCallback $= if animate' then Just (idle state) else Nothing + _ -> return () + postRedisplay Nothing +keyboard _ _ _ _ _ = return () + +drawObjects :: GLfloat -> Bool -> IO () +drawObjects torusAngle' shadowRender = do + textureOn <- get (texture Texture2D) + + when shadowRender $ + texture Texture2D $= Disabled + + -- resolve overloading, not needed in "real" programs + let normal3f = normal :: Normal3 GLfloat -> IO () + color3f = color :: Color3 GLfloat -> IO () + rectf = rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + + unless shadowRender $ do + normal3f (Normal3 0 0 1) + color3f (Color3 1 1 1) + rectf (Vertex2 (-20) (-20)) (Vertex2 20 20) + + preservingMatrix $ do + translatef (Vector3 11 11 11) + rotatef 54.73 (Vector3 (-5) 5 0) + rotate torusAngle' (Vector3 1 0 0) + color3f (Color3 1 0 0) + renderObject Solid (Torus 1 4 8 36) + + preservingMatrix $ do + translatef (Vector3 2 2 2) + color3f (Color3 0 0 1) + renderObject Solid (Cube 4) + + preservingMatrix $ do + getLightPos Vector3 >>= translate + color3f (Color3 1 1 1) + renderObject Wireframe (Sphere' 0.5 6 6) + + when (shadowRender && textureOn == Enabled) $ + texture Texture2D $= Enabled + +getLightPos :: (GLdouble -> GLdouble -> GLdouble -> a) -> IO a +getLightPos f = do + Vertex4 x y z _ <- get (position (Light 0)) + return $ f (realToFrac x) (realToFrac y) (realToFrac z) + +generateShadowMap :: GLfloat -> Bool -> IO () +generateShadowMap torusAngle' showShadow' = do + lightPos' <- getLightPos Vertex3 + let (TextureSize2D shadowMapWidth shadowMapHeight) = shadowMapSize + shadowMapSize' = Size shadowMapWidth shadowMapHeight + + preservingViewport $ do + viewport $= (Position 0 0, shadowMapSize') + + clear [ ColorBuffer, DepthBuffer ] + + matrixMode $= Projection + preservingMatrix $ do + loadIdentity + perspective 80 1 10 1000 + matrixMode $= Modelview 0 + preservingMatrix $ do + loadIdentity + lookAt lightPos' lookat up + drawObjects torusAngle' True + matrixMode $= Projection + matrixMode $= Modelview 0 + + copyTexImage2D Nothing 0 DepthComponent' (Position 0 0) shadowMapSize 0 + + when showShadow' $ do + let numShadowMapPixels = fromIntegral (shadowMapWidth * shadowMapHeight) + allocaArray numShadowMapPixels $ \depthImage -> do + let pixelData fmt = PixelData fmt Float depthImage :: PixelData GLfloat + readPixels (Position 0 0) shadowMapSize' (pixelData DepthComponent) + (_, Size viewPortWidth _) <- get viewport + windowPos (Vertex2 (fromIntegral viewPortWidth / 2 :: GLfloat) 0) + drawPixels shadowMapSize' (pixelData Luminance) + swapBuffers + +-- Note: preservingViewport is not exception safe, but it doesn't matter here +preservingViewport :: IO a -> IO a +preservingViewport act = do + v <- get viewport + x <- act + viewport $= v + return x + +generateTextureMatrix :: IO () +generateTextureMatrix = do + -- Set up projective texture matrix. We use the Modelview matrix stack and + -- OpenGL matrix commands to make the matrix. + m <- preservingMatrix $ do + loadIdentity + -- resolve overloading, not needed in "real" programs + let translatef = translate :: Vector3 GLfloat -> IO () + scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () + translatef (Vector3 0.5 0.5 0.0) + scalef 0.5 0.5 1.0 + perspective 60 1 1 1000 + lightPos' <- getLightPos Vertex3 + lookAt lightPos' lookat up + get (matrix (Just (Modelview 0))) + + [ sx, sy, sz, sw, + tx, ty, tz, tw, + rx, ry, rz, rw, + qx, qy, qz, qw ] <- getMatrixComponents RowMajor (m :: GLmatrix GLdouble) + + textureGenMode S $= Just (ObjectLinear (Plane sx sy sz sw)) + textureGenMode T $= Just (ObjectLinear (Plane tx ty tz tw)) + textureGenMode R $= Just (ObjectLinear (Plane rx ry rz rw)) + textureGenMode Q $= Just (ObjectLinear (Plane qx qy qz qw)) + +display :: State -> DisplayCallback +display state = do + let radius = 30 + torusAngle' <- get (torusAngle state) + showShadow' <- get (showShadow state) + generateShadowMap torusAngle' showShadow' + generateTextureMatrix + unless showShadow' $ do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + angle' <- get (angle state) + lookAt (Vertex3 (radius * cos angle') (radius * sin angle') 30) lookat up + drawObjects torusAngle' False + swapBuffers + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ RGBAMode, WithDepthBuffer, DoubleBuffered ] + initialWindowSize $= Size 521 512 + initialWindowPosition $= Position 100 100 + createWindow progName + state <- makeState + myInit + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + idleCallback $= Just (idle state) + + mainLoop diff --git a/examples/RedBook/Smooth.hs b/examples/RedBook/Smooth.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Smooth.hs @@ -0,0 +1,65 @@ +{- + Smooth.hs (adapted from smooth.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates smooth shading. A smooth shaded polygon is drawn in + a 2-D projection. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + +triangle :: IO () +triangle = + -- resolve overloading, not needed in "real" programs + let vertex2f = vertex :: Vertex2 GLfloat -> IO () + color3f = color :: Color3 GLfloat -> IO () + in renderPrimitive Triangles $ do + color3f (Color3 1 0 0) + vertex2f (Vertex2 5 5) + color3f (Color3 0 1 0) + vertex2f (Vertex2 25 5) + color3f (Color3 0 0 1) + vertex2f (Vertex2 5 25) + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + triangle + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D 0 30 0 (30 * hf/wf) + else ortho2D 0 (30 * wf/hf) 0 30 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/Stencil.hs b/examples/RedBook/Stencil.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Stencil.hs @@ -0,0 +1,123 @@ +{- + Stencil.hs (adapted from stencil.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates use of the stencil buffer for masking + nonrectangular regions. Whenever the window is redrawn, a value of 1 is drawn + into a diamond-shaped region in the stencil buffer. Elsewhere in the stencil + buffer, the value is 0. Then a blue sphere is drawn where the stencil value + is 1, and yellow torii are drawn where the stencil value is not 1. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data DisplayLists = DisplayLists { yellowMat, blueMat :: DisplayList } + +myInit :: IO DisplayLists +myInit = do + y <- defineNewList Compile $ do + materialDiffuse Front $= Color4 0.7 0.7 0 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 64 + + b <- defineNewList Compile $ do + materialDiffuse Front $= Color4 0.1 0.1 0.7 1 + materialSpecular Front $= Color4 0.1 1 1 1 + materialShininess Front $= 45 + + position (Light 0) $= Vertex4 1 1 1 0 + + light (Light 0) $= Enabled + lighting $= Enabled + depthFunc $= Just Less + + clearStencil $= 0 + stencilTest $= Enabled + + return $ DisplayLists { yellowMat = y, blueMat = b } + +-- Draw a sphere in a diamond-shaped section in the middle of a window with 2 +-- torii. +display :: DisplayLists -> DisplayCallback +display displayLists = do + clear [ ColorBuffer, DepthBuffer ] + + -- draw blue sphere where the stencil is 1 + stencilFunc $= (Equal, 1, 1) + stencilOp $= (OpKeep, OpKeep, OpKeep) + callList (blueMat displayLists) + renderObject Solid (Sphere' 0.5 15 15) + + -- resolve overloading, not needed in "real" programs + let rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO () + + -- draw the tori where the stencil is not 1 + stencilFunc $= (Notequal, 1, 1) + preservingMatrix $ do + rotatef 45 (Vector3 0 0 1) + rotatef 45 (Vector3 0 1 0) + callList (yellowMat displayLists) + renderObject Solid (Torus 0.275 0.85 15 15) + preservingMatrix $ do + rotatef 90 (Vector3 1 0 0) + renderObject Solid (Torus 0.275 0.85 15 15) + + flush + +-- Whenever the window is reshaped, redefine the coordinate system and redraw +-- the stencil area. +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + + -- create a diamond shaped stencil area + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D (-3) 3 (-3*hf/wf) (3*hf/wf) + else ortho2D (-3*wf/hf) (3*wf/hf) (-3) 3 + matrixMode $= Modelview 0 + loadIdentity + + -- resolve overloading, not needed in "real" programs + let vertex2f = vertex :: Vertex2 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + + clear [ StencilBuffer ] + stencilFunc $= (Always, 1, 1) + stencilOp $= (OpReplace, OpReplace, OpReplace) + renderPrimitive Quads $ do + vertex2f (Vertex2 (-1) 0) + vertex2f (Vertex2 0 1) + vertex2f (Vertex2 1 0) + vertex2f (Vertex2 0 (-1)) + + matrixMode $= Projection + loadIdentity + perspective 45 (wf/hf) 3 7 + matrixMode $= Modelview 0 + loadIdentity + translatef (Vector3 0 0 (-5)) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop: Be certain to request stencil bits. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer, WithStencilBuffer ] + initialWindowSize $= Size 400 400 + initialWindowPosition $= Position 100 100 + createWindow progName + displayLists <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display displayLists + mainLoop diff --git a/examples/RedBook/Stroke.hs b/examples/RedBook/Stroke.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Stroke.hs @@ -0,0 +1,127 @@ +{- + Stroke.hs (adapted from stroke.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates some characters of a stroke (vector) font. The + characters are represented by display lists, which are given numbers which + correspond to the ASCII values of the characters. Use of callLists is + demonstrated. +-} + +import Data.List ( genericLength ) +import Foreign.C.String ( castCharToCChar ) +import Foreign.Marshal.Array ( withArray ) +import Graphics.UI.GLUT +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) + +aData, eData, pData, rData, sData :: [[Vertex2 GLfloat]] +aData = [ + [ Vertex2 0 0, Vertex2 0 9, Vertex2 1 10, Vertex2 4 10, Vertex2 5 9, + Vertex2 5 0 ], + [ Vertex2 0 5, Vertex2 5 5 ] ] + +eData = [ + [ Vertex2 5 0, Vertex2 0 0, Vertex2 0 10, Vertex2 5 10 ], + [ Vertex2 0 5, Vertex2 4 5 ] ] + +pData = [ + [ Vertex2 0 0, Vertex2 0 10, Vertex2 4 10, Vertex2 5 9, Vertex2 5 6, + Vertex2 4 5, Vertex2 0 5 ] ] + +rData = [ + [ Vertex2 0 0, Vertex2 0 10, Vertex2 4 10, Vertex2 5 9, Vertex2 5 6, + Vertex2 4 5, Vertex2 0 5 ], + [ Vertex2 3 5, Vertex2 5 0 ] ] + +sData = [ + [ Vertex2 0 1, Vertex2 1 0, Vertex2 4 0, Vertex2 5 1, Vertex2 5 4, + Vertex2 4 5, Vertex2 1 5, Vertex2 0 6, Vertex2 0 9, Vertex2 1 10, + Vertex2 4 10, Vertex2 5 9 ] ] + +advance :: IO () +advance = translate (Vector3 8 0 (0 :: GLfloat)) + +-- drawLetter renders a letter with line segments given by the list of line +-- strips. +drawLetter :: [[Vertex2 GLfloat]] -> IO () +drawLetter lineStrips = do + mapM_ (renderPrimitive LineStrip . mapM_ vertex) lineStrips + advance + +charToGLubyte :: Char -> GLubyte +charToGLubyte = fromIntegral . castCharToCChar + +myInit :: IO () +myInit = do + shadeModel $= Flat + + (base@(DisplayList b):_) <- genObjectNames 128 + listBase $= base + let charToDisplayList c = DisplayList (b + fromIntegral (charToGLubyte c)) + mapM_ (\(c, d) -> defineList (charToDisplayList c) Compile d) + [ ('A', drawLetter aData), + ('E', drawLetter eData), + ('P', drawLetter pData), + ('R', drawLetter rData), + ('S', drawLetter sData), + (' ', advance) ] + +test1, test2 :: String +test1 = "A SPARE SERAPE APPEARS AS" +test2 = "APES PREPARE RARE PEPPERS" + +printStrokedString :: String -> IO () +printStrokedString s = + withArray (map charToGLubyte s) $ + callLists (genericLength s) UnsignedByte + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + + color3f (Color3 1 1 1) + preservingMatrix $ do + scalef 2 2 2 + translatef (Vector3 10 30 0) + printStrokedString test1 + preservingMatrix $ do + scalef 2 2 2 + translatef (Vector3 10 13 0) + printStrokedString test2 + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char c) Down _ _ = case c of + ' ' -> postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ = return () + +-- Main Loop: Open window with initial window size, title bar, RGBA display +-- mode, and handle input events. +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 440 120 + createWindow progName + myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + displayCallback $= display + mainLoop diff --git a/examples/RedBook/SurfPoints.hs b/examples/RedBook/SurfPoints.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/SurfPoints.hs @@ -0,0 +1,129 @@ +{- + SurfPoints.hs (adapted from surfpoints.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program is a modification of the earlier Surface.hs program. The + vertex data are not directly rendered, but are instead passed to the + callback function. The values of the tessellated vertices are printed + out there. + + This program draws a NURBS surface in the shape of a symmetrical hill. + The 'c' keyboard key allows you to toggle the visibility of the control + points themselves. Note that some of the control points are hidden by + the surface itself. + + NOTE: This example does NOT demonstrate the final NURBS API, it's currently + just a test for the internals... +-} + +import Control.Monad ( when ) +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import Foreign.Marshal ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess), 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 diff --git a/examples/RedBook/Surface.hs b/examples/RedBook/Surface.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Surface.hs @@ -0,0 +1,112 @@ +{- + Surface.hs (adapted from surface.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws a NURBS surface in the shape of a symmetrical hill. + The 'c' keyboard key allows you to toggle the visibility of the control + points themselves. Note that some of the control points are hidden by + the surface itself. + + NOTE: This example does NOT demonstrate the final NURBS API, it's currently + just a test for the internals... +-} + +import Control.Monad ( when ) +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import Foreign.Marshal ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { showPoints :: IORef Bool } + +makeState :: IO State +makeState = do + s <- newIORef False + return $ State { showPoints = s } + +-- The control points of the surface form a small hill and +-- range from -3 to +3 in x, y, and z. +ctlPoints :: [[Vertex3 GLfloat]] +ctlPoints = + [ [ Vertex3 (2 * u - 3) + (2 * v - 3) + (if (u == 1 || u ==2) && (v == 1 || v == 2) then 3 else -3) + | v <- [ 0 .. 3 ] ] + | u <- [ 0 .. 3 ]] + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + materialDiffuse Front $= Color4 0.7 0.7 0.7 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 100 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + autoNormal $= Enabled + normalize $= Enabled + +-------------------------------------------------------------------------------- + +display :: State -> DisplayCallback +display state = do + let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + rotate (330 :: GLfloat) (Vector3 1 0 0) + scale 0.5 0.5 (0.5 :: GLfloat) + + withNURBSObj () $ \nurbsObj -> do + setSamplingMethod nurbsObj (PathLength 25) + setDisplayMode' nurbsObj Fill' + checkForNURBSError nurbsObj $ + nurbsBeginEndSurface nurbsObj $ + withArray (concat ctlPoints) $ \cBuf -> + withArray knots $ \kBuf -> + nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4 + + s <- get (showPoints state) + when s $ do + pointSize $= 5 + lighting $= Disabled + color (Color3 1 1 (0 :: GLfloat)) + renderPrimitive Points $ + mapM_ (mapM_ vertex) ctlPoints + lighting $= Enabled + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 45 (fromIntegral w / fromIntegral h) 3 8 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-5 :: GLfloat)) + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'c' -> do showPoints state $~ not; postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + state <- makeState + myInit + reshapeCallback $= Just reshape + displayCallback $= display state + keyboardMouseCallback $= Just (keyboard state) + mainLoop diff --git a/examples/RedBook/Teapots.hs b/examples/RedBook/Teapots.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Teapots.hs @@ -0,0 +1,226 @@ +{- + Teapots.hs (adapted from teapots.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates lots of material properties. A single light + source illuminates the objects. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Initialize depth buffer, projection matrix, light source, and lighting +-- model. Do not specify a material property here. +myInit :: IO DisplayList +myInit = do + ambient (Light 0) $= Color4 0 0 0 1 + diffuse (Light 0) $= Color4 1 1 1 1 + position (Light 0) $= Vertex4 0 3 3 0 + lightModelAmbient $= Color4 0.2 0.2 0.2 1 + lightModelLocalViewer $= Disabled + + frontFace $= CW + lighting $= Enabled + light (Light 0) $= Enabled + autoNormal $= Enabled + normalize $= Enabled + depthFunc $= Just Less + -- be efficient--make teapot display list + defineNewList Compile $ + renderObject Solid (Teapot 1) + +-- Move object into position, specify the material properties, draw a teapot. +renderTeapot :: DisplayList -> Vector3 GLfloat -> Color4 GLfloat + -> Color4 GLfloat -> Color4 GLfloat -> GLfloat -> IO () +renderTeapot teapotList pos amb dif spec shine = do + preservingMatrix $ do + translate pos + materialAmbient Front $= amb + materialDiffuse Front $= dif + materialSpecular Front $= spec + materialShininess Front $= shine * 128 + callList teapotList + +-- 1st column: emerald, jade, obsidian, pearl, ruby, turquoise +-- 2nd column: brass, bronze, chrome, copper, gold, silver +-- 3rd column: black, cyan, green, red, white, yellow plastic +-- 4th column: black, cyan, green, red, white, yellow rubber +display :: DisplayList -> DisplayCallback +display teapotList = do + clear [ ColorBuffer, DepthBuffer ] + renderTeapot teapotList + (Vector3 2 17 0) + (Color4 0.0215 0.1745 0.0215 1) + (Color4 0.07568 0.61424 0.07568 1) + (Color4 0.633 0.727811 0.633 1) + 0.6 + renderTeapot teapotList + (Vector3 2 14 0) + (Color4 0.135 0.2225 0.1575 1) + (Color4 0.54 0.89 0.63 1) + (Color4 0.316228 0.316228 0.316228 1) + 0.1 + renderTeapot teapotList + (Vector3 2 11 0) + (Color4 0.05375 0.05 0.06625 1) + (Color4 0.18275 0.17 0.22525 1) + (Color4 0.332741 0.328634 0.346435 1) + 0.3 + renderTeapot teapotList + (Vector3 2 8 0) + (Color4 0.25 0.20725 0.20725 1) + (Color4 1 0.829 0.829 1) + (Color4 0.296648 0.296648 0.296648 1) + 0.088 + renderTeapot teapotList + (Vector3 2 5 0) + (Color4 0.1745 0.01175 0.01175 1) + (Color4 0.61424 0.04136 0.04136 1) + (Color4 0.727811 0.626959 0.626959 1) + 0.6 + renderTeapot teapotList + (Vector3 2 2 0) + (Color4 0.1 0.18725 0.1745 1) + (Color4 0.396 0.74151 0.69102 1) + (Color4 0.297254 0.30829 0.306678 1) + 0.1 + renderTeapot teapotList + (Vector3 6 17 0) + (Color4 0.329412 0.223529 0.027451 1) + (Color4 0.780392 0.568627 0.113725 1) + (Color4 0.992157 0.941176 0.807843 1) + 0.21794872 + renderTeapot teapotList + (Vector3 6 14 0) + (Color4 0.2125 0.1275 0.054 1) + (Color4 0.714 0.4284 0.18144 1) + (Color4 0.393548 0.271906 0.166721 1) + 0.2 + renderTeapot teapotList + (Vector3 6 11 0) + (Color4 0.25 0.25 0.25 1) + (Color4 0.4 0.4 0.4 1) + (Color4 0.774597 0.774597 0.774597 1) + 0.6 + renderTeapot teapotList + (Vector3 6 8 0) + (Color4 0.19125 0.0735 0.0225 1) + (Color4 0.7038 0.27048 0.0828 1) + (Color4 0.256777 0.137622 0.086014 1) + 0.1 + renderTeapot teapotList + (Vector3 6 5 0) + (Color4 0.24725 0.1995 0.0745 1) + (Color4 0.75164 0.60648 0.22648 1) + (Color4 0.628281 0.555802 0.366065 1) + 0.4 + renderTeapot teapotList + (Vector3 6 2 0) + (Color4 0.19225 0.19225 0.19225 1) + (Color4 0.50754 0.50754 0.50754 1) + (Color4 0.508273 0.508273 0.508273 1) + 0.4 + renderTeapot teapotList + (Vector3 10 17 0) + (Color4 0 0 0 1) + (Color4 0.01 0.01 0.01 1) + (Color4 0.50 0.50 0.50 1) + 0.25 + renderTeapot teapotList + (Vector3 10 14 0) + (Color4 0 0.1 0.06 1) + (Color4 0 0.50980392 0.50980392 1) + (Color4 0.50196078 0.50196078 0.50196078 1) + 0.25 + renderTeapot teapotList + (Vector3 10 11 0) + (Color4 0 0 0 1) + (Color4 0.1 0.35 0.1 1) + (Color4 0.45 0.55 0.45 1) + 0.25 + renderTeapot teapotList + (Vector3 10 8 0) + (Color4 0 0 0 1) + (Color4 0.5 0 0 1) + (Color4 0.7 0.6 0.6 1) + 0.25 + renderTeapot teapotList + (Vector3 10 5 0) + (Color4 0 0 0 1) + (Color4 0.55 0.55 0.55 1) + (Color4 0.70 0.70 0.70 1) + 0.25 + renderTeapot teapotList + (Vector3 10 2 0) + (Color4 0 0 0 1) + (Color4 0.5 0.5 0 1) + (Color4 0.60 0.60 0.50 1) + 0.25 + renderTeapot teapotList + (Vector3 14 17 0) + (Color4 0.02 0.02 0.02 1) + (Color4 0.01 0.01 0.01 1) + (Color4 0.4 0.4 0.4 1) + 0.078125 + renderTeapot teapotList + (Vector3 14 14 0) + (Color4 0 0.05 0.05 1) + (Color4 0.4 0.5 0.5 1) + (Color4 0.04 0.7 0.7 1) + 0.078125 + renderTeapot teapotList + (Vector3 14 11 0) + (Color4 0 0.05 0 1) + (Color4 0.4 0.5 0.4 1) + (Color4 0.04 0.7 0.04 1) + 0.078125 + renderTeapot teapotList + (Vector3 14 8 0) + (Color4 0.05 0 0 1) + (Color4 0.5 0.4 0.4 1) + (Color4 0.7 0.04 0.04 1) + 0.078125 + renderTeapot teapotList + (Vector3 14 5 0) + (Color4 0.05 0.05 0.05 1) + (Color4 0.5 0.5 0.5 1) + (Color4 0.7 0.7 0.7 1) + 0.078125 + renderTeapot teapotList + (Vector3 14 2 0) + (Color4 0.05 0.05 0 1) + (Color4 0.5 0.5 0.4 1) + (Color4 0.7 0.7 0.04 1) + 0.078125 + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho 0 16 0 (16 * hf/wf) (-10) 10 + else ortho 0 (16 * wf/hf) 0 16 (-10) 10 + matrixMode $= Modelview 0 + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 600 + initialWindowPosition $= Position 50 50 + createWindow progName + teapotList <- myInit + reshapeCallback $= Just reshape + displayCallback $= display teapotList + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/Tess.hs b/examples/RedBook/Tess.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Tess.hs @@ -0,0 +1,117 @@ +{- + Tess.hs (adapted from tess.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates polygon tessellation. Two tesselated objects are + drawn. The first is a rectangle with a triangular hole. The second is a + smooth shaded, self-intersecting star. + + Note the exterior rectangle is drawn with its vertices in counter-clockwise + order, but its interior clockwise. Note the combineCallback is needed for the + self-intersecting star. Also note that removing the TessProperty for the + star will make the interior unshaded (TessWindingOdd). +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +display :: [DisplayList] -> DisplayCallback +display displayLists = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + color3f (Color3 1 1 1) + mapM callList displayLists + flush + +-- 'Float' is a dummy, any marshalable type would do +type DontCare = Float + +rectangle :: ComplexContour DontCare +rectangle = ComplexContour [ + AnnotatedVertex (Vertex3 50 50 0) 0, + AnnotatedVertex (Vertex3 200 50 0) 0, + AnnotatedVertex (Vertex3 200 200 0) 0, + AnnotatedVertex (Vertex3 50 200 0) 0 ] + +tri :: ComplexContour DontCare +tri = ComplexContour [ + AnnotatedVertex (Vertex3 75 75 0) 0, + AnnotatedVertex (Vertex3 125 175 0) 0, + AnnotatedVertex (Vertex3 175 75 0) 0 ] + +rectAndTri :: ComplexPolygon DontCare +rectAndTri = ComplexPolygon [ rectangle, tri ] + +noOpCombiner :: Combiner DontCare +noOpCombiner _newVertex _weightedProperties = 0 + +star :: ComplexPolygon (Color3 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 diff --git a/examples/RedBook/TessWind.hs b/examples/RedBook/TessWind.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/TessWind.hs @@ -0,0 +1,195 @@ +{- + TessWind.hs (adapted from tesswind.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the winding rule polygon tessellation property. + Four tessellated objects are drawn, each with very different contours. When + the w key is pressed, the objects are drawn with a different winding rule. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { currentWindingRule :: IORef TessWinding } + +makeState :: IO State +makeState = do + c <- newIORef TessWindingOdd + return $ State { currentWindingRule = c } + +type DisplayLists = (DisplayList, DisplayList, DisplayList, DisplayList) + +-- 'Float' is a dummy, any marshalable type would do +type DontCare = Float + +rect1 :: ComplexContour DontCare +rect1 = ComplexContour [ + AnnotatedVertex (Vertex3 50 50 0) 0, + AnnotatedVertex (Vertex3 300 50 0) 0, + AnnotatedVertex (Vertex3 300 300 0) 0, + AnnotatedVertex (Vertex3 50 300 0) 0 ] + +rect2 :: ComplexContour DontCare +rect2 = ComplexContour [ + AnnotatedVertex (Vertex3 100 100 0) 0, + AnnotatedVertex (Vertex3 250 100 0) 0, + AnnotatedVertex (Vertex3 250 250 0) 0, + AnnotatedVertex (Vertex3 100 250 0) 0 ] + +rect3 :: ComplexContour DontCare +rect3 = ComplexContour [ + AnnotatedVertex (Vertex3 150 150 0) 0, + AnnotatedVertex (Vertex3 200 150 0) 0, + AnnotatedVertex (Vertex3 200 200 0) 0, + AnnotatedVertex (Vertex3 150 200 0) 0 ] + +rects1 :: ComplexPolygon DontCare +rects1 = ComplexPolygon [ rect1, rect2, rect3 ] + +rects2 :: ComplexPolygon DontCare +rects2 = ComplexPolygon [ + rect1, reverseComplexContour rect2, reverseComplexContour rect3 ] + +spiral :: ComplexPolygon DontCare +spiral = ComplexPolygon [ + ComplexContour [ + AnnotatedVertex (Vertex3 400 250 0) 0, + AnnotatedVertex (Vertex3 400 50 0) 0, + AnnotatedVertex (Vertex3 50 50 0) 0, + AnnotatedVertex (Vertex3 50 400 0) 0, + AnnotatedVertex (Vertex3 350 400 0) 0, + AnnotatedVertex (Vertex3 350 100 0) 0, + AnnotatedVertex (Vertex3 100 100 0) 0, + AnnotatedVertex (Vertex3 100 350 0) 0, + AnnotatedVertex (Vertex3 300 350 0) 0, + AnnotatedVertex (Vertex3 300 150 0) 0, + AnnotatedVertex (Vertex3 150 150 0) 0, + AnnotatedVertex (Vertex3 150 300 0) 0, + AnnotatedVertex (Vertex3 250 300 0) 0, + AnnotatedVertex (Vertex3 250 200 0) 0, + AnnotatedVertex (Vertex3 200 200 0) 0, + AnnotatedVertex (Vertex3 200 250 0) 0 ] ] + +quad1 :: ComplexContour DontCare +quad1 = ComplexContour [ + AnnotatedVertex (Vertex3 50 150 0) 0, + AnnotatedVertex (Vertex3 350 150 0) 0, + AnnotatedVertex (Vertex3 350 200 0) 0, + AnnotatedVertex (Vertex3 50 200 0) 0 ] + +quad2 :: ComplexContour DontCare +quad2 = ComplexContour [ + AnnotatedVertex (Vertex3 100 100 0) 0, + AnnotatedVertex (Vertex3 300 100 0) 0, + AnnotatedVertex (Vertex3 300 350 0) 0, + AnnotatedVertex (Vertex3 100 350 0) 0 ] + +tri :: ComplexContour DontCare +tri = ComplexContour [ + AnnotatedVertex (Vertex3 200 50 0) 0, + AnnotatedVertex (Vertex3 250 300 0) 0, + AnnotatedVertex (Vertex3 150 300 0) 0 ] + +quadsAndTri :: ComplexPolygon DontCare +quadsAndTri = ComplexPolygon [ quad1, quad2, tri ] + +reverseComplexContour :: ComplexContour DontCare -> ComplexContour DontCare +reverseComplexContour (ComplexContour avs) = ComplexContour (reverse avs) + +makeNewLists :: State -> DisplayLists -> IO () +makeNewLists state (dl1, dl2, dl3, dl4) = do + windingRule <- get (currentWindingRule state) + print windingRule -- not in original program, but useful + compileList windingRule dl1 rects1 + compileList windingRule dl2 rects2 + compileList windingRule dl3 spiral + compileList windingRule dl4 quadsAndTri + +compileList :: TessWinding -> DisplayList -> ComplexPolygon DontCare -> IO () +compileList windingRule displayList complexPolygon = + defineList displayList Compile $ + drawSimplePolygon =<< + tessellate windingRule 0 (Normal3 0 0 0) noOpCombiner complexPolygon + +noOpCombiner :: Combiner DontCare +noOpCombiner _newVertex _weightedProperties = 0 + +drawSimplePolygon :: SimplePolygon DontCare -> IO () +drawSimplePolygon (SimplePolygon primitives) = + flip mapM_ primitives $ \(Primitive primitiveMode vertices) -> + renderPrimitive primitiveMode $ + flip mapM_ vertices $ \(AnnotatedVertex plainVertex _) -> + vertex plainVertex + +display :: DisplayLists -> DisplayCallback +display (dl1, dl2, dl3, dl4) = do + clear [ ColorBuffer ] + -- resolve overloading, not needed in "real" programs + let color3f = color :: Color3 GLfloat -> IO () + translatef = translate :: Vector3 GLfloat -> IO () + color3f (Color3 1 1 1) + preservingMatrix $ do + callList dl1 + translatef (Vector3 0 500 0) + callList dl2 + translatef (Vector3 500 (-500) 0) + callList dl3 + translatef (Vector3 0 500 0) + callList dl4 + flush + +myInit :: State -> IO DisplayLists +myInit state = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + [dl1, dl2, dl3, dl4] <- genObjectNames 4 + let displayLists = (dl1, dl2, dl3, dl4) + makeNewLists state displayLists + return displayLists + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho2D 0 1000 0 (1000 * hf/wf) + else ortho2D 0 (1000 * wf/hf) 0 1000 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: State -> DisplayLists -> KeyboardMouseCallback +keyboard state displayLists (Char c) Down _ _ = case toLower c of + 'w' -> do currentWindingRule state $~ nextWindingRule + makeNewLists state displayLists + postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ _ = return () + +nextWindingRule :: TessWinding -> TessWinding +nextWindingRule r = case r of + TessWindingOdd -> TessWindingNonzero + TessWindingNonzero -> TessWindingPositive + TessWindingPositive -> TessWindingNegative + TessWindingNegative -> TessWindingAbsGeqTwo + TessWindingAbsGeqTwo -> TessWindingOdd + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + createWindow progName + state <- makeState + displayLists <- myInit state + displayCallback $= display displayLists + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state displayLists) + mainLoop diff --git a/examples/RedBook/TexBind.hs b/examples/RedBook/TexBind.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/TexBind.hs @@ -0,0 +1,108 @@ +{- + TexBind.hs (adapted from texbind.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates using textureBinding by creating and managing + two textures. +-} + +import Control.Monad ( when ) +import Data.Bits ( (.&.) ) +import Foreign ( withArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Create checkerboard image +checkImageSize :: TextureSize2D +checkImageSize = TextureSize2D 64 64 + +withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) + -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () +withCheckImage (TextureSize2D w h) n f act = + withArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] $ + act . PixelData RGBA UnsignedByte + +myInit :: IO (TextureObject, TextureObject) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + rowAlignment Unpack $= 1 + + [texName0, texName1] <- genObjectNames 2 + textureBinding Texture2D $= Just texName0 + textureWrapMode Texture2D S $= (Repeated, Clamp) + textureWrapMode Texture2D T $= (Repeated, Clamp) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + withCheckImage checkImageSize 0x08 (\c -> Color4 c c c 255) $ + texImage2D Nothing NoProxy 0 RGBA' checkImageSize 0 + + textureBinding Texture2D $= Just texName1 + textureWrapMode Texture2D S $= (Repeated, Clamp) + textureWrapMode Texture2D T $= (Repeated, Clamp) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + textureFunction $= Decal + withCheckImage checkImageSize 0x10 (\c -> Color4 c 0 0 255) $ + texImage2D Nothing NoProxy 0 RGBA' checkImageSize 0 + texture Texture2D $= Enabled + return (texName0, texName1) + +display :: (TextureObject, TextureObject) -> DisplayCallback +display (texName0, texName1) = do + clear [ ColorBuffer, DepthBuffer ] + -- resolve overloading, not needed in "real" programs + let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + textureBinding Texture2D $= Just texName0 + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) + textureBinding Texture2D $= Just texName1 + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-3.6 :: GLfloat)) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + version <- get (majorMinor glVersion) + when (version == (1,0)) $ do + putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." + putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," + putStrLn "you may be able to modify this program to make it run." + exitFailure + texNames <- myInit + reshapeCallback $= Just reshape + displayCallback $= display texNames + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/TexGen.hs b/examples/RedBook/TexGen.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/TexGen.hs @@ -0,0 +1,132 @@ +{- + TexGen.hs (adapted from texgen.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws a texture mapped teapot with automatically generated + texture coordinates. The texture is rendered as stripes on the teapot. + Initially, the object is drawn with texture coordinates based upon the + object coordinates of the vertex and distance from the plane x = 0. + Pressing the 'e' key changes the coordinate generation to eye coordinates + of the vertex. Pressing the 'o' key switches it back to the object + coordinates. Pressing the 's' key changes the plane to a slanted one + (x + y + z = 0). Pressing the 'x' key switches it back to x = 0. +-} + +import Control.Monad ( when ) +import Data.Char ( toLower ) +import Data.Maybe ( isJust, listToMaybe ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +stripeImageWidth :: TextureSize1D +stripeImageWidth = TextureSize1D 32 + +xEqualZero, slanted :: Plane GLdouble +xEqualZero = Plane 1 0 0 0 +slanted = Plane 1 1 1 0 + +withStripeImage :: (PixelData (Color4 GLubyte) -> IO a) -> IO a +withStripeImage act = + withArray [ Color4 (if j <= 4 then 255 else 0) + (if j > 4 then 255 else 0) + 0 + 255 + | j <- [ 0 .. w - 1 ] ] $ + act . PixelData RGBA UnsignedByte + where TextureSize1D w = stripeImageWidth + +myInit :: IO (Maybe TextureObject) +myInit = do + clearColor $= Color4 0 0 0 0 + depthFunc $= Just Less + shadeModel $= Smooth + rowAlignment Unpack $= 1 + + exts <- get glExtensions + mbTexName <- if "GL_EXT_texture_object" `elem` exts + then fmap listToMaybe $ genObjectNames 1 + else return Nothing + when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName + + textureWrapMode Texture1D S $= (Repeated, Repeat) + textureFilter Texture1D $= ((Linear', Nothing), Linear') + withStripeImage $ texImage1D NoProxy 0 RGBA' stripeImageWidth 0 + + textureFunction $= Modulate + textureGenMode S $= Just (ObjectLinear xEqualZero) + + texture Texture1D $= Enabled + lighting $= Enabled + light (Light 0) $= Enabled + autoNormal $= Enabled + normalize $= Enabled + frontFace $= CW + cullFace $= Just Back + materialShininess Front $= 64 + return mbTexName + +display :: Maybe TextureObject -> DisplayCallback +display mbTexName = do + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + rotate (45 :: GLfloat) (Vector3 0 0 1) + when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName + renderObject Solid (Teapot 2) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-3.5) 3.5 (-3.5*hf/wf) (3.5*hf/wf) (-3.5) 3.5 + else ortho (-3.5*wf/hf) (3.5*wf/hf) (-3.5) 3.5 (-3.5) 3.5 + matrixMode $= Modelview 0 + loadIdentity + +keyboard :: KeyboardMouseCallback +keyboard (Char c) Down _ _ = case toLower c of + 'e' -> setGenMode EyeLinear + 'o' -> setGenMode ObjectLinear + 's' -> setPlane slanted + 'x' -> setPlane xEqualZero + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ = return () + +setGenMode :: (Plane GLdouble -> TextureGenMode) -> IO () +setGenMode mode = do + currentGenMode <- get (textureGenMode S) + case currentGenMode of + Just (EyeLinear plane) -> textureGenMode S $= Just (mode plane) + Just (ObjectLinear plane) -> textureGenMode S $= Just (mode plane) + _ -> error "setGenMode: should never happen..." + postRedisplay Nothing + +setPlane :: Plane GLdouble -> IO () +setPlane plane = do + currentGenMode <- get (textureGenMode S) + case currentGenMode of + Just (EyeLinear _) -> textureGenMode S $= Just (EyeLinear plane) + Just (ObjectLinear _) -> textureGenMode S $= Just (ObjectLinear plane) + _ -> error "setPlane: should never happen..." + postRedisplay Nothing + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 256 256 + initialWindowPosition $= Position 100 100 + createWindow progName + mbTexName <- myInit + displayCallback $= display mbTexName + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/TexProx.hs b/examples/RedBook/TexProx.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/TexProx.hs @@ -0,0 +1,58 @@ +{- + TexProx.hs (adapted from texprox.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + The brief program illustrates use of texture proxies. This program only + prints out some messages about whether certain size textures are supported + and then exits. +-} + +import Control.Monad ( when ) +import Foreign.Ptr ( nullPtr ) +import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +myInit :: IO () +myInit = do + let check = do + ok <- get (textureProxyOK (Left Texture2D) 0) + putStrLn ("proxy allocation " ++ if ok then "succeeded" else "failed") + + texImage2D Nothing Proxy 0 RGBA8 (TextureSize2D 64 64) 0 (PixelData RGBA UnsignedByte nullPtr) + check + + -- Note: We use a larger texture size here to demonstrate failure, + -- modern graphic cards can handle the original size. + texImage2D Nothing Proxy 0 RGBA16 (TextureSize2D 8192 8192) 0 (PixelData RGBA UnsignedShort nullPtr) + check + + +display :: DisplayCallback +display = exitWith ExitSuccess + +reshape :: ReshapeCallback +reshape size = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + version <- get (majorMinor glVersion) + when (version == (1,0)) $ do + putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." + putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," + putStrLn "you may be able to modify this program to make it run." + exitFailure + myInit + displayCallback $= display + reshapeCallback $= Just reshape + mainLoop diff --git a/examples/RedBook/TexSub.hs b/examples/RedBook/TexSub.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/TexSub.hs @@ -0,0 +1,120 @@ +{- + TexSub.hs (adapted from texsub.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program texture maps a checkerboard image onto two rectangles. This + program clamps the texture, if the texture coordinates fall outside 0.0 + and 1.0. If the s key is pressed, a texture subimage is used to alter the + original texture. If the r key is pressed, the original texture is restored. +-} + +import Control.Monad ( when ) +import Data.Char ( toLower ) +import Data.Bits ( (.&.) ) +import Foreign ( newArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +checkImageSize, subImageSize :: TextureSize2D +checkImageSize = TextureSize2D 64 64 +subImageSize = TextureSize2D 16 16 + +type Image = PixelData (Color4 GLubyte) + +makeCheckImage :: + TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) -> IO Image +makeCheckImage (TextureSize2D w h) n f = + fmap (PixelData RGBA UnsignedByte) $ + newArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] + +myInit :: IO (TextureObject, Image, Image) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + + checkImage <- makeCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) + subImage <- makeCheckImage subImageSize 0x4 (\c -> Color4 c 0 0 255) + rowAlignment Unpack $= 1 + + [texName] <- genObjectNames 1 + textureBinding Texture2D $= Just texName + + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + texImage2D Nothing NoProxy 0 RGBA' checkImageSize 0 checkImage + return (texName, checkImage, subImage) + +display :: TextureObject -> DisplayCallback +display texName = do + clear [ ColorBuffer, DepthBuffer ] + texture Texture2D $= Enabled + textureFunction $= Decal + textureBinding Texture2D $= Just texName + + -- resolve overloading, not needed in "real" programs + let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) + + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 ) + texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) + texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) + flush + texture Texture2D $= Disabled + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-3.6 :: GLfloat)) + +keyboard :: TextureObject -> Image -> Image -> KeyboardMouseCallback +keyboard texName checkImage subImage (Char c) Down _ _ = case toLower c of + 's' -> do + textureBinding Texture2D $= Just texName + texSubImage2D Nothing 0 (TexturePosition2D 12 44) subImageSize subImage + postRedisplay Nothing + 'r' -> do + textureBinding Texture2D $= Just texName + texImage2D Nothing NoProxy 0 RGBA' checkImageSize 0 checkImage + postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + version <- get (majorMinor glVersion) + when (version == (1,0)) $ do + putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." + putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," + putStrLn "you may be able to modify this program to make it run." + exitFailure + (texName, checkImage, subImage) <- myInit + displayCallback $= display texName + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard texName checkImage subImage) + mainLoop diff --git a/examples/RedBook/Texture3D.hs b/examples/RedBook/Texture3D.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Texture3D.hs @@ -0,0 +1,94 @@ +{- + Texture3D.hs (adapted from texture3d.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates using a three-dimensional texture. It creates + a 3D texture and then renders two rectangles with different texture + coordinates to obtain different "slices" of the 3D texture. +-} + +import Control.Monad ( unless ) +import Foreign ( withArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Create checkerboard image +imageSize :: TextureSize3D +imageSize = TextureSize3D 16 16 16 + +withImage :: (PixelData (Color3 GLubyte) -> IO ()) -> IO () +withImage act = + withArray [ Color3 (s * 17) (t * 17) (r * 17) | + r <- [ 0 .. fromIntegral d - 1 ], + t <- [ 0 .. fromIntegral h - 1 ], + s <- [ 0 .. fromIntegral w - 1 ] ] $ + act . PixelData RGB UnsignedByte + where (TextureSize3D w h d) = imageSize + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + rowAlignment Unpack $= 1 + + [texName] <- genObjectNames 1 + textureBinding Texture3D $= Just texName + textureWrapMode Texture3D S $= (Repeated, Clamp) + textureWrapMode Texture3D T $= (Repeated, Clamp) + textureWrapMode Texture3D R $= (Repeated, Clamp) + textureFilter Texture3D $= ((Nearest, Nothing), Nearest) + withImage $ texImage3D NoProxy 0 RGB' imageSize 0 + texture Texture3D $= Enabled + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + -- resolve overloading, not needed in "real" programs + let texCoord3f = texCoord :: TexCoord3 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Quads $ do + texCoord3f (TexCoord3 0 0 0); vertex3f (Vertex3 (-2.25) (-1) 0) + texCoord3f (TexCoord3 0 1 0); vertex3f (Vertex3 (-2.25) 1 0) + texCoord3f (TexCoord3 1 1 1); vertex3f (Vertex3 (-0.25) 1 0) + texCoord3f (TexCoord3 1 0 1); vertex3f (Vertex3 (-0.25) (-1) 0) + + texCoord3f (TexCoord3 0 0 1); vertex3f (Vertex3 0.25 (-1) 0) + texCoord3f (TexCoord3 0 1 1); vertex3f (Vertex3 0.25 1 0) + texCoord3f (TexCoord3 1 1 0); vertex3f (Vertex3 2.25 1 0) + texCoord3f (TexCoord3 1 0 0); vertex3f (Vertex3 2.25 (-1) 0) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-4 :: GLfloat)) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + exts <- get glExtensions + unless ("GL_EXT_texture3D" `elem` exts) $ do + putStrLn "Sorry, this demo requires the GL_EXT_texture3D extension." + exitFailure + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/TextureSurf.hs b/examples/RedBook/TextureSurf.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/TextureSurf.hs @@ -0,0 +1,99 @@ +{- + TextureSurf.hs (adapted from texturesurf.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program uses evaluators to generate a curved surface and automatically + generated texture coordinates. +-} + +import Data.List ( transpose ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +ctrlPoints :: [[Vertex3 GLfloat]] +ctrlPoints = [ + [ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0, + Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ], + [ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0, + Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ], + [ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0, + Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ], + [ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0), + Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]] + +texPts :: [[TexCoord2 GLfloat]] +texPts = [ + [ TexCoord2 0 0, TexCoord2 0 1 ], + [ TexCoord2 1 0, TexCoord2 1 1 ]] + +display :: DisplayCallback +display = do + clear [ ColorBuffer, DepthBuffer ] + color (Color3 1 1 1 :: Color3 GLfloat) + evalMesh2 Fill (0, 20) (0, 20) + flush + +imageSize :: TextureSize2D +imageSize = TextureSize2D 64 64 + +withImage :: (PixelData (Color3 GLubyte) -> IO ()) -> IO () +withImage act = + withArray [ Color3 (s (sin ti)) (s (cos (2 * tj))) (s (cos (ti + tj))) | + i <- [ 0 .. fromIntegral w - 1 ], + let ti = 2 * pi * i / fromIntegral w, + j <- [ 0 .. fromIntegral h - 1 ], + let tj = 2 * pi * j / fromIntegral h ] $ + act . PixelData RGB UnsignedByte + where (TextureSize2D w h) = imageSize + s :: Double -> GLubyte + s x = truncate (127 * (1 + x)) + +myInit :: IO () +myInit = do + m <- newMap2 (0, 1) (0, 1) (transpose ctrlPoints) + map2 $= Just (m :: GLmap2 Vertex3 GLfloat) + t <- newMap2 (0, 1) (0, 1) (transpose texPts) + map2 $= Just (t :: GLmap2 TexCoord2 GLfloat) + mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat))) + textureFunction $= Decal + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + withImage $ texImage2D Nothing NoProxy 0 RGB' imageSize 0 + texture Texture2D $= Enabled + depthFunc $= Just Less + shadeModel $= Flat + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + let wf = fromIntegral w + hf = fromIntegral h + if w <= h + then ortho (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0 + else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0 + matrixMode $= Modelview 0 + loadIdentity + rotate (85 :: GLfloat) (Vector3 1 1 1) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/Torus.hs b/examples/RedBook/Torus.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Torus.hs @@ -0,0 +1,93 @@ +{- + Torus.hs (adapted from torus.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2006 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates the creation of a display list. +-} + +import Data.Char ( toLower ) +import Data.IORef ( IORef, newIORef ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +data State = State { spinX, spinY :: IORef GLfloat } + +makeState :: IO State +makeState = do + x <- newIORef 0 + y <- newIORef 0 + return $ State { spinX = x, spinY = y } + +torus :: Int -> Int -> IO () +torus numC numT = do + let stepC = 2 * pi / fromIntegral numC :: GLfloat + stepT = 2 * pi / fromIntegral numT + flip mapM_ [ 0 .. numC - 1 ] $ \i -> + renderPrimitive QuadStrip $ + flip mapM_ [ 0 .. numT ] $ \j -> + flip mapM_ [ 1, 0 ] $ \k -> do + let s = (fromIntegral ((i + k) `mod` numC) + 0.5) * stepC + t = (fromIntegral ( j `mod` numT) ) * stepT + x = (1 + 0.1 * cos s) * cos t + y = (1 + 0.1 * cos s) * sin t + z = 0.1 * sin s + vertex (Vertex3 x y z) + +myInit :: IO DisplayList +myInit = do + theTorus <- defineNewList Compile $ + torus 8 25 + shadeModel $= Flat + clearColor $= Color4 0 0 0 0 + return theTorus + +display :: State -> DisplayList -> DisplayCallback +display state theTorus = do + clear [ ColorBuffer ] + loadIdentity + lookAt (Vertex3 0 0 10) (Vertex3 0 0 0) (Vector3 0 1 0) + x <- get (spinX state) + rotate x (Vector3 1 0 0) + y <- get (spinY state) + rotate y (Vector3 0 1 0) + color (Color3 1 1 (1 :: GLfloat)) + callList theTorus + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 30 (fromIntegral w / fromIntegral h) 1 100 + matrixMode $= Modelview 0 + +incSpin :: IORef GLfloat -> IO () +incSpin spinRef = do + let wrap n s = if s > n then s - n else s + spinRef $~ (wrap 360 . (+ 30)) + postRedisplay Nothing + +keyboard :: State -> KeyboardMouseCallback +keyboard state (Char c) Down _ _ = case toLower c of + 'x' -> incSpin (spinX state) + 'y' -> incSpin (spinY state) + 'i' -> do spinX state $= 0; spinY state $= 0; postRedisplay Nothing + '\27' -> exitWith ExitSuccess + _ -> return () +keyboard _ _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 200 200 + createWindow progName + state <- makeState + theTorus <- myInit + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboard state) + displayCallback $= display state theTorus + mainLoop diff --git a/examples/RedBook/Trim.hs b/examples/RedBook/Trim.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Trim.hs @@ -0,0 +1,107 @@ +{- + Trim.hs (adapted from trim.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program draws a NURBS surface in the shape of a symmetrical hill, + using both a NURBS curve and pwl (piecewise linear) curve to trim part + of the surface. + + NOTE: This example does NOT demonstrate the final NURBS API, it's currently + just a test for the internals... +-} + +import Foreign.Marshal ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- The control points of the surface form a small hill and +-- range from -3 to +3 in x, y, and z. +ctlPoints :: [[Vertex3 GLfloat]] +ctlPoints = + [ [ Vertex3 (2 * u - 3) + (2 * v - 3) + (if (u == 1 || u ==2) && (v == 1 || v == 2) then 3 else -3) + | v <- [ 0 .. 3 ] ] + | u <- [ 0 .. 3 ]] + +myInit :: IO () +myInit = do + clearColor $= Color4 0 0 0 0 + materialDiffuse Front $= Color4 0.7 0.7 0.7 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 100 + + lighting $= Enabled + light (Light 0) $= Enabled + depthFunc $= Just Less + autoNormal $= Enabled + normalize $= Enabled + +-------------------------------------------------------------------------------- + +display :: DisplayCallback +display = do + let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] + edgePt = -- counter clockwise + [ Vertex2 0 0, Vertex2 1 0, Vertex2 1 1, Vertex2 0 1, Vertex2 0 0 ] :: [Vertex2 GLfloat] + curvePt = -- clockwise + [ Vertex2 0.25 0.5, Vertex2 0.25 0.75, Vertex2 0.75 0.75, Vertex2 0.75 0.5 ] :: [Vertex2 GLfloat] + curveKnots = + [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat] + pwlPt = -- clockwise + [Vertex2 0.75 0.5, Vertex2 0.5 0.25, Vertex2 0.25 0.5 ] :: [Vertex2 GLfloat] + + clear [ ColorBuffer, DepthBuffer ] + preservingMatrix $ do + rotate (330 :: GLfloat) (Vector3 1 0 0) + scale 0.5 0.5 (0.5 :: GLfloat) + + withNURBSObj () $ \nurbsObj -> do + setSamplingMethod nurbsObj (PathLength 25) + setDisplayMode' nurbsObj Fill' + checkForNURBSError nurbsObj $ + nurbsBeginEndSurface nurbsObj $ + withArray (concat ctlPoints) $ \cBuf -> + withArray knots $ \kBuf -> do + nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4 + nurbsBeginEndTrim nurbsObj $ + withArray edgePt $ \edgePtBuf -> + pwlCurve nurbsObj 5 edgePtBuf 2 + nurbsBeginEndTrim nurbsObj $ do + withArray curveKnots $ \curveKnotsBuf -> + withArray curvePt $ \curvePtBuf -> + trimmingCurve nurbsObj 8 curveKnotsBuf 2 curvePtBuf 4 + withArray pwlPt $ \pwlPtBuf -> + pwlCurve nurbsObj 3 pwlPtBuf 2 + + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 45 (fromIntegral w / fromIntegral h) 3 8 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-5 :: GLfloat)) + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +-- Main Loop +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + myInit + reshapeCallback $= Just reshape + displayCallback $= display + keyboardMouseCallback $= Just keyboard + mainLoop diff --git a/examples/RedBook/UnProject.hs b/examples/RedBook/UnProject.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/UnProject.hs @@ -0,0 +1,54 @@ +{- + UnProject.hs (adapted from unproject.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + When the left mouse button is pressed, this program reads the mouse + position and determines two 3D points from which it was transformed. + Very little is displayed. +-} + +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +display :: DisplayCallback +display = do + clear [ ColorBuffer ] + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 45 (fromIntegral w / fromIntegral h) 1 100 + matrixMode $= Modelview 0 + loadIdentity + +keyboardMouse :: KeyboardMouseCallback +keyboardMouse (MouseButton LeftButton) Down _ (Position x y) = do + v@(_, Size _ h) <- get viewport + mvMatrix <- get (matrix (Just (Modelview 0))) :: IO (GLmatrix GLdouble) + projMatrix <- get (matrix (Just Projection)) :: IO (GLmatrix GLdouble) + let realY = h - y -1 + putStrLn ("Coordinates at cursor are (" ++ show x ++", " ++ show realY ++ ")") + w0 <- unProject (Vertex3 (fromIntegral x) (fromIntegral realY) 0) mvMatrix projMatrix v + putStrLn ("World coords at z=0.0 are " ++ show w0) + w1 <- unProject (Vertex3 (fromIntegral x) (fromIntegral realY) 1) mvMatrix projMatrix v + putStrLn ("World coords at z=1.0 are " ++ show w1) +keyboardMouse (MouseButton RightButton) Down _ _ = exitWith ExitSuccess +keyboardMouse (Char '\27') Down _ _ = exitWith ExitSuccess +keyboardMouse _ _ _ _ = return () + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 500 500 + initialWindowPosition $= Position 100 100 + createWindow progName + displayCallback $= display + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboardMouse + mainLoop diff --git a/examples/RedBook/VArray.hs b/examples/RedBook/VArray.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/VArray.hs @@ -0,0 +1,141 @@ +{- + VArray.hs (adapted from varray.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program demonstrates vertex arrays. +-} + +import Control.Monad ( when ) +import Data.IORef ( IORef, newIORef ) +import Foreign ( Ptr, newArray ) +import System.Exit ( exitFailure, exitWith, ExitCode(..) ) +import Graphics.UI.GLUT + +data SetupMethod = Pointer | Interleaved + deriving ( Eq, Bounded, Enum ) + +data DerefMethod = DrawArray | ArrayElement | DrawElements + deriving ( Eq, Bounded, Enum ) + +makeVertices :: IO (Ptr (Vertex2 GLint)) +makeVertices = newArray [ + Vertex2 25 25, + Vertex2 100 325, + Vertex2 175 25, + Vertex2 175 325, + Vertex2 250 25, + Vertex2 325 325 ] + +makeColors :: IO (Ptr (Color3 GLfloat)) +makeColors = newArray [ + Color3 1.0 0.2 0.2, + Color3 0.2 0.2 1.0, + Color3 0.8 1.0 0.2, + Color3 0.75 0.75 0.75, + Color3 0.35 0.35 0.35, + Color3 0.5 0.5 0.5 ] + +makeIntertwined :: IO (Ptr GLfloat) +makeIntertwined = newArray [ + 1.0, 0.2, 1.0, 100.0, 100.0, 0.0, + 1.0, 0.2, 0.2, 0.0, 200.0, 0.0, + 1.0, 1.0, 0.2, 100.0, 300.0, 0.0, + 0.2, 1.0, 0.2, 200.0, 300.0, 0.0, + 0.2, 1.0, 1.0, 300.0, 200.0, 0.0, + 0.2, 0.2, 1.0, 200.0, 100.0, 0.0 ] + +makeIndices :: IO (Ptr GLuint) +makeIndices = newArray [ 0, 1, 3, 4 ] + +data State = State { + vertices :: Ptr (Vertex2 GLint), + colors :: Ptr (Color3 GLfloat), + intertwined :: Ptr GLfloat, + indices :: Ptr GLuint, + setupMethod :: IORef SetupMethod, + derefMethod :: IORef DerefMethod } + +makeState :: IO State +makeState = do + v <- makeVertices + c <- makeColors + i <- makeIntertwined + n <- makeIndices + s <- newIORef Pointer + d <- newIORef DrawArray + return $ State { vertices = v, colors = c, intertwined = i, + indices = n, setupMethod = s, derefMethod = d } + +setup :: State -> IO () +setup state = do + s <- get (setupMethod state) + case s of + Pointer -> do + clientState VertexArray $= Enabled + clientState ColorArray $= Enabled + arrayPointer VertexArray $= VertexArrayDescriptor 2 Int 0 (vertices state) + arrayPointer ColorArray $= VertexArrayDescriptor 3 Float 0 (colors state) + Interleaved -> + interleavedArrays C3fV3f 0 (intertwined state) + +myInit :: State -> IO () +myInit state = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + setup state + +display :: State -> DisplayCallback +display state = do + clear [ ColorBuffer ] + d <- get (derefMethod state) + case d of + DrawArray -> drawArrays Triangles 0 6 + ArrayElement -> renderPrimitive Triangles $ mapM_ arrayElement [ 2, 3, 5 ] + DrawElements -> drawElements Polygon 4 UnsignedInt (indices state) + flush + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + -- the following line is not in the original example, but it's good style... + matrixMode $= Modelview 0 + +keyboardMouse :: State -> KeyboardMouseCallback +keyboardMouse state (MouseButton LeftButton) Down _ _ = do + setupMethod state $~ nextValue + setup state + postRedisplay Nothing +keyboardMouse state (MouseButton _) Down _ _ = do + derefMethod state $~ nextValue + postRedisplay Nothing +keyboardMouse _ (Char '\27') Down _ _ = exitWith ExitSuccess +keyboardMouse _ _ _ _ _ = return () + +nextValue :: (Eq a, Bounded a, Enum a) => a -> a +nextValue x = if x == maxBound then minBound else succ x + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode ] + initialWindowSize $= Size 350 350 + initialWindowPosition $= Position 100 100 + createWindow progName + -- we have to do this *after* createWindow, otherwise we have no OpenGL context + version <- get (majorMinor glVersion) + when (version == (1,0)) $ do + putStrLn "This program demonstrates a feature which is not in OpenGL Version 1.0." + putStrLn "If your implementation of OpenGL Version 1.0 has the right extensions," + putStrLn "you may be able to modify this program to make it run." + exitFailure + state <- makeState + myInit state + displayCallback $= display state + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just (keyboardMouse state) + mainLoop diff --git a/examples/RedBook/Wrap.hs b/examples/RedBook/Wrap.hs new file mode 100644 --- /dev/null +++ b/examples/RedBook/Wrap.hs @@ -0,0 +1,114 @@ +{- + Wrap.hs (adapted from wrap.c which is (c) Silicon Graphics, Inc) + Copyright (c) Sven Panne 2002-2005 + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This program texture maps a checkerboard image onto two rectangles. This + program demonstrates the wrapping modes, if the texture coordinates fall + outside 0.0 and 1.0. Interaction: Pressing the 's' and 'S' keys switch the + wrapping between clamping and repeating for the s parameter. The 't' and 'T' + keys control the wrapping for the t parameter. + + Texture objects are only used when GL_EXT_texture_object is supported. +-} + +import Control.Monad ( when ) +import Data.Maybe ( isJust, listToMaybe ) +import Data.Bits ( (.&.) ) +import Foreign ( withArray ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Graphics.UI.GLUT + +-- Create checkerboard image +checkImageSize :: TextureSize2D +checkImageSize = TextureSize2D 64 64 + +withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) + -> (PixelData (Color4 GLubyte) -> IO ()) -> IO () +withCheckImage (TextureSize2D w h) n f act = + withArray [ f c | + i <- [ 0 .. w - 1 ], + j <- [ 0 .. h - 1 ], + let c | (i .&. n) == (j .&. n) = 0 + | otherwise = 255 ] $ + act. PixelData RGBA UnsignedByte + +myInit :: IO (Maybe TextureObject) +myInit = do + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + depthFunc $= Just Less + rowAlignment Unpack $= 1 + + exts <- get glExtensions + mbTexName <- if "GL_EXT_texture_object" `elem` exts + then fmap listToMaybe $ genObjectNames 1 + else return Nothing + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + withCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) $ + texImage2D Nothing NoProxy 0 RGBA' checkImageSize 0 + return mbTexName + +display :: Maybe TextureObject -> DisplayCallback +display mbTexName = do + clear [ ColorBuffer, DepthBuffer ] + texture Texture2D $= Enabled + textureFunction $= Decal + when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName + + -- resolve overloading, not needed in "real" programs + let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () + vertex3f = vertex :: Vertex3 GLfloat -> IO () + renderPrimitive Quads $ do + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 3); vertex3f (Vertex3 (-2.0) 1.0 0.0 ) + texCoord2f (TexCoord2 3 3); vertex3f (Vertex3 0.0 1.0 0.0 ) + texCoord2f (TexCoord2 3 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 ) + + texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 ) + texCoord2f (TexCoord2 0 3); vertex3f (Vertex3 1.0 1.0 0.0 ) + texCoord2f (TexCoord2 3 3); vertex3f (Vertex3 2.41421 1.0 (-1.41421)) + texCoord2f (TexCoord2 3 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421)) + flush + texture Texture2D $= Disabled + +reshape :: ReshapeCallback +reshape size@(Size w h) = do + viewport $= (Position 0 0, size) + matrixMode $= Projection + loadIdentity + perspective 60 (fromIntegral w / fromIntegral h) 1 30 + matrixMode $= Modelview 0 + loadIdentity + translate (Vector3 0 0 (-3.6 :: GLfloat)) + +keyboard :: KeyboardMouseCallback +keyboard (Char 's' ) Down _ _ = setClamping S Clamp +keyboard (Char 'S' ) Down _ _ = setClamping S Repeat +keyboard (Char 't' ) Down _ _ = setClamping T Clamp +keyboard (Char 'T' ) Down _ _ = setClamping T Repeat +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess +keyboard _ _ _ _ = return () + +setClamping :: TextureCoordName -> Clamping -> IO () +setClamping coord clamp = do + textureWrapMode Texture2D coord $= (Repeated, clamp); + postRedisplay Nothing + +main :: IO () +main = do + (progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ] + initialWindowSize $= Size 250 250 + initialWindowPosition $= Position 100 100 + createWindow progName + mbTexName <- myInit + displayCallback $= display mbTexName + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just keyboard + mainLoop