From 139f67a37dfac0531fa7d4bde7d1d6a0219002e0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?St=C3=A9phane=20Glondu?= Date: Tue, 17 Dec 2013 15:31:14 +0100 Subject: Import lablgl_1.05.orig.tar.gz [dgit import orig lablgl_1.05.orig.tar.gz] --- .cvsignore | 1 + CHANGES | 166 ++ COPYRIGHT | 26 + LablGlut/COPYRIGHT | 33 + LablGlut/ChangeLog | 56 + LablGlut/README | 31 + LablGlut/THANKS | 15 + LablGlut/TODO | 3 + LablGlut/examples/README | 3 + LablGlut/examples/caml-images/ChangeLog | 26 + LablGlut/examples/caml-images/Makefile | 14 + LablGlut/examples/caml-images/OCamlMakefile | 802 ++++++ LablGlut/examples/caml-images/main.ml | 160 ++ LablGlut/examples/caml-images/ppm.ppm | 112 + LablGlut/examples/lablGL/README | 5 + LablGlut/examples/lablGL/checker.ml | 70 + LablGlut/examples/lablGL/gears.ml | 253 ++ LablGlut/examples/lablGL/morph3d.ml | 602 ++++ LablGlut/examples/lablGL/planet.ml | 125 + LablGlut/examples/lablGL/scene.ml | 108 + LablGlut/examples/lablGL/simple.ml | 31 + LablGlut/examples/lablGL/test_glsl.ml | 143 + LablGlut/examples/lablGL/texturesurf.ml | 99 + LablGlut/examples/nehe/lesson2.ml | 75 + LablGlut/examples/nehe/lesson3.ml | 78 + LablGlut/examples/nehe/lesson4.ml | 91 + LablGlut/examples/nehe/lesson5.ml | 148 + LablGlut/lgcompile | 21 + LablGlut/src/.cvsignore | 1 + LablGlut/src/.depend | 12 + LablGlut/src/Makefile | 94 + LablGlut/src/glut.ml | 987 +++++++ LablGlut/src/glut.mli | 392 +++ LablGlut/src/lablglut.bat | 2 + LablGlut/src/ml_gl.h | 132 + LablGlut/src/wrap_gl.c | 154 + LablGlut/src/wrap_glut.c | 414 +++ META | 19 + Makefile | 48 + Makefile.common | 57 + Makefile.config.ex | 68 + Makefile.config.freebsd | 60 + Makefile.config.linux.mdk | 60 + Makefile.config.mingw | 78 + Makefile.config.msvc | 74 + Makefile.config.osx | 54 + Makefile.config.ubuntu | 60 + README | 376 +++ Togl/examples/Makefile | 4 + Togl/examples/README | 3 + Togl/examples/checker.ml | 73 + Togl/examples/double.ml | 124 + Togl/examples/gears.ml | 245 ++ Togl/examples/gears_a.ml | 261 ++ Togl/examples/morph3d.ml | 599 ++++ Togl/examples/planet.ml | 120 + Togl/examples/scene.ml | 111 + Togl/examples/simple.ml | 35 + Togl/examples/tennis.ml | 517 ++++ Togl/examples/tesselate.ml | 26 + Togl/examples/texturesurf.ml | 101 + Togl/src/.cvsignore | 1 + Togl/src/.depend | 2 + Togl/src/Makefile | 91 + Togl/src/Togl/LICENSE | 27 + Togl/src/Togl/Togl.html | 1081 +++++++ Togl/src/Togl/ben.rgb | Bin 0 -> 49959 bytes Togl/src/Togl/double.c | 280 ++ Togl/src/Togl/double.tcl | 103 + Togl/src/Togl/gears.c | 402 +++ Togl/src/Togl/gears.tcl | 76 + Togl/src/Togl/image.c | 249 ++ Togl/src/Togl/image.h | 14 + Togl/src/Togl/index.c | 184 ++ Togl/src/Togl/index.tcl | 51 + Togl/src/Togl/overlay.c | 194 ++ Togl/src/Togl/overlay.tcl | 49 + Togl/src/Togl/stereo.c | 352 +++ Togl/src/Togl/stereo.tcl | 108 + Togl/src/Togl/texture.c | 608 ++++ Togl/src/Togl/texture.tcl | 283 ++ Togl/src/Togl/tkFont.h | 226 ++ Togl/src/Togl/togl.c | 4034 +++++++++++++++++++++++++++ Togl/src/Togl/togl.h | 243 ++ Togl/src/Togl/tree2.rgba | Bin 0 -> 66048 bytes Togl/src/lablgl.bat | 2 + Togl/src/ml_togl.c | 156 ++ Togl/src/togl.ml | 276 ++ Togl/src/togl.mli | 62 + Togl/src/togl_tags.var | 11 + src/.cvsignore | 18 + src/.depend | 63 + src/Makefile | 99 + src/build.ml.in | 128 + src/gl.ml | 89 + src/gl.mli | 64 + src/glArray.ml | 54 + src/glArray.mli | 62 + src/glClear.ml | 20 + src/glClear.mli | 12 + src/glDraw.ml | 56 + src/glDraw.mli | 42 + src/glFunc.ml | 66 + src/glFunc.mli | 43 + src/glLight.ml | 53 + src/glLight.mli | 49 + src/glList.ml | 29 + src/glList.mli | 30 + src/glMap.ml | 38 + src/glMap.mli | 39 + src/glMat.ml | 77 + src/glMat.mli | 37 + src/glMisc.ml | 63 + src/glMisc.mli | 38 + src/glPix.ml | 107 + src/glPix.mli | 80 + src/glShader.ml | 99 + src/glShader.mli | 81 + src/glTex.ml | 121 + src/glTex.mli | 53 + src/gl_tags.var | 283 ++ src/gluMat.ml | 28 + src/gluMat.mli | 16 + src/gluMisc.ml | 38 + src/gluMisc.mli | 15 + src/gluNurbs.ml | 77 + src/gluNurbs.mli | 42 + src/gluQuadric.ml | 40 + src/gluQuadric.mli | 30 + src/gluTess.ml | 18 + src/gluTess.mli | 20 + src/glu_tags.var | 38 + src/ml_gl.c | 730 +++++ src/ml_gl.h | 133 + src/ml_glarray.c | 113 + src/ml_glu.c | 307 ++ src/ml_glu.h | 17 + src/ml_glutess.c | 230 ++ src/ml_raw.c | 507 ++++ src/ml_raw.h | 23 + src/ml_shader.c | 1251 +++++++++ src/raw.ml | 84 + src/raw.mli | 83 + src/raw_tags.var | 2 + src/var2def.ml | 45 + src/var2switch.ml | 33 + 146 files changed, 23836 insertions(+) create mode 100644 .cvsignore create mode 100644 CHANGES create mode 100644 COPYRIGHT create mode 100644 LablGlut/COPYRIGHT create mode 100644 LablGlut/ChangeLog create mode 100644 LablGlut/README create mode 100644 LablGlut/THANKS create mode 100644 LablGlut/TODO create mode 100644 LablGlut/examples/README create mode 100644 LablGlut/examples/caml-images/ChangeLog create mode 100644 LablGlut/examples/caml-images/Makefile create mode 100644 LablGlut/examples/caml-images/OCamlMakefile create mode 100644 LablGlut/examples/caml-images/main.ml create mode 100644 LablGlut/examples/caml-images/ppm.ppm create mode 100644 LablGlut/examples/lablGL/README create mode 100644 LablGlut/examples/lablGL/checker.ml create mode 100644 LablGlut/examples/lablGL/gears.ml create mode 100644 LablGlut/examples/lablGL/morph3d.ml create mode 100644 LablGlut/examples/lablGL/planet.ml create mode 100644 LablGlut/examples/lablGL/scene.ml create mode 100644 LablGlut/examples/lablGL/simple.ml create mode 100644 LablGlut/examples/lablGL/test_glsl.ml create mode 100644 LablGlut/examples/lablGL/texturesurf.ml create mode 100644 LablGlut/examples/nehe/lesson2.ml create mode 100644 LablGlut/examples/nehe/lesson3.ml create mode 100644 LablGlut/examples/nehe/lesson4.ml create mode 100644 LablGlut/examples/nehe/lesson5.ml create mode 100755 LablGlut/lgcompile create mode 100644 LablGlut/src/.cvsignore create mode 100644 LablGlut/src/.depend create mode 100644 LablGlut/src/Makefile create mode 100644 LablGlut/src/glut.ml create mode 100644 LablGlut/src/glut.mli create mode 100755 LablGlut/src/lablglut.bat create mode 100644 LablGlut/src/ml_gl.h create mode 100644 LablGlut/src/wrap_gl.c create mode 100644 LablGlut/src/wrap_glut.c create mode 100644 META create mode 100644 Makefile create mode 100644 Makefile.common create mode 100644 Makefile.config.ex create mode 100644 Makefile.config.freebsd create mode 100644 Makefile.config.linux.mdk create mode 100644 Makefile.config.mingw create mode 100644 Makefile.config.msvc create mode 100644 Makefile.config.osx create mode 100644 Makefile.config.ubuntu create mode 100644 README create mode 100644 Togl/examples/Makefile create mode 100644 Togl/examples/README create mode 100644 Togl/examples/checker.ml create mode 100644 Togl/examples/double.ml create mode 100644 Togl/examples/gears.ml create mode 100644 Togl/examples/gears_a.ml create mode 100644 Togl/examples/morph3d.ml create mode 100644 Togl/examples/planet.ml create mode 100644 Togl/examples/scene.ml create mode 100644 Togl/examples/simple.ml create mode 100644 Togl/examples/tennis.ml create mode 100644 Togl/examples/tesselate.ml create mode 100644 Togl/examples/texturesurf.ml create mode 100644 Togl/src/.cvsignore create mode 100644 Togl/src/.depend create mode 100644 Togl/src/Makefile create mode 100644 Togl/src/Togl/LICENSE create mode 100644 Togl/src/Togl/Togl.html create mode 100644 Togl/src/Togl/ben.rgb create mode 100644 Togl/src/Togl/double.c create mode 100644 Togl/src/Togl/double.tcl create mode 100644 Togl/src/Togl/gears.c create mode 100755 Togl/src/Togl/gears.tcl create mode 100644 Togl/src/Togl/image.c create mode 100644 Togl/src/Togl/image.h create mode 100644 Togl/src/Togl/index.c create mode 100644 Togl/src/Togl/index.tcl create mode 100644 Togl/src/Togl/overlay.c create mode 100644 Togl/src/Togl/overlay.tcl create mode 100644 Togl/src/Togl/stereo.c create mode 100644 Togl/src/Togl/stereo.tcl create mode 100644 Togl/src/Togl/texture.c create mode 100644 Togl/src/Togl/texture.tcl create mode 100644 Togl/src/Togl/tkFont.h create mode 100644 Togl/src/Togl/togl.c create mode 100644 Togl/src/Togl/togl.h create mode 100644 Togl/src/Togl/tree2.rgba create mode 100755 Togl/src/lablgl.bat create mode 100644 Togl/src/ml_togl.c create mode 100644 Togl/src/togl.ml create mode 100644 Togl/src/togl.mli create mode 100644 Togl/src/togl_tags.var create mode 100644 src/.cvsignore create mode 100644 src/.depend create mode 100644 src/Makefile create mode 100755 src/build.ml.in create mode 100644 src/gl.ml create mode 100644 src/gl.mli create mode 100644 src/glArray.ml create mode 100644 src/glArray.mli create mode 100644 src/glClear.ml create mode 100644 src/glClear.mli create mode 100644 src/glDraw.ml create mode 100644 src/glDraw.mli create mode 100644 src/glFunc.ml create mode 100644 src/glFunc.mli create mode 100644 src/glLight.ml create mode 100644 src/glLight.mli create mode 100644 src/glList.ml create mode 100644 src/glList.mli create mode 100644 src/glMap.ml create mode 100644 src/glMap.mli create mode 100644 src/glMat.ml create mode 100644 src/glMat.mli create mode 100644 src/glMisc.ml create mode 100644 src/glMisc.mli create mode 100644 src/glPix.ml create mode 100644 src/glPix.mli create mode 100644 src/glShader.ml create mode 100644 src/glShader.mli create mode 100644 src/glTex.ml create mode 100644 src/glTex.mli create mode 100644 src/gl_tags.var create mode 100644 src/gluMat.ml create mode 100644 src/gluMat.mli create mode 100644 src/gluMisc.ml create mode 100644 src/gluMisc.mli create mode 100644 src/gluNurbs.ml create mode 100644 src/gluNurbs.mli create mode 100644 src/gluQuadric.ml create mode 100644 src/gluQuadric.mli create mode 100644 src/gluTess.ml create mode 100644 src/gluTess.mli create mode 100644 src/glu_tags.var create mode 100644 src/ml_gl.c create mode 100644 src/ml_gl.h create mode 100644 src/ml_glarray.c create mode 100644 src/ml_glu.c create mode 100644 src/ml_glu.h create mode 100644 src/ml_glutess.c create mode 100644 src/ml_raw.c create mode 100644 src/ml_raw.h create mode 100644 src/ml_shader.c create mode 100644 src/raw.ml create mode 100644 src/raw.mli create mode 100644 src/raw_tags.var create mode 100644 src/var2def.ml create mode 100644 src/var2switch.ml diff --git a/.cvsignore b/.cvsignore new file mode 100644 index 0000000..ce9e37c --- /dev/null +++ b/.cvsignore @@ -0,0 +1 @@ +Makefile.config diff --git a/CHANGES b/CHANGES new file mode 100644 index 0000000..6708f39 --- /dev/null +++ b/CHANGES @@ -0,0 +1,166 @@ +LablGL 1.05: +------------ +2013-09-20: +* make it work with the OCaml 4.01 windows installer + (both lablglut and togl) + +2013-09-11: +* add configuration file for Ubuntu + +2012-10-18: +* allow building with make -j + +2012-06-05: +* switch to Togl 1.7, doesn't need Tk internals anymore + +2012-03-06: +* add `bgr and `bgra to Gl.format and GlTex.format (reported by Vu Ngoc San) + +2010-06-16: +* fix Glut.special_of_int to raise no exception (reported by malc) + +2010-03-11: +* merge glShader support by Florent Monnier + +LablGL 1.04: +------------ +2008-12-21: +* support windows compilation for ocaml 3.11 + +2008-10-25: +* support Tcl/Tk 8.5 +* require Raw.static in GlArray (reported by malc) +* check for GL_ARB_texture_non_power_of_two in GlTex (reported by malc) + +2008-01-10: +* fix GlMap.eval_coord2 (reported by Florent Monnier) + +LablGL 1.03: +--------------------- +2007-04-13: [Jacques] +* add glPolygonOffset +* fix Glut.createMenu +* fix GlTex.gen_textures + +2006-07-29: [Jacques] +* make LablGlut's callback window dependent +* simplify glutInit + +2006-03-23: [Jacques] +* avoid all uses of stderr in stubs (caused incompatibilities) +* use mingw import libraries +* mingw build works again (but togl only works in dll mode) + +LablGL 1.02: +------------ +2005-10-28: [Jacques] +* fix GlMat.mult_transpose (Gregory Guyomarc'h) + +2005-10-20: [Jacques] +* correct GlTex.image2d border bug (Eric Cooper) + +2005-10-14: [Jacques] +* add glGetError + +2004-07-20: [Jacques] +* add index_logic_op and color_logic_op + +LablGL 1.01: +------------ +2004-07-13: [Jacques] +* merge Jon Harrop's tesselator support + +LablGL 1.00: +------------ +2003-10-01: [Jacques] +* split togl, move examples to Togl/examples +* add mingw support + +2003-09-29: [Jacques] +* reorganized directories and Makefiles + +2003-09-25: [Christophe] +* merge ijtrotts' LablGlut + +2003-09-24: [Christophe] +* add glArray support + +LablGL 0.99: +------------ + +* add texture binding functions, contributed by Chris Hecker + +* add support for Tcl/Tk8.4 + +* allow compiling and installing without Tk + +LablGL 0.98: +------------ + +* add windows port + +* add lablGL.spec (Ben Martin) + +* add GLU_VERSION and GLU_EXTENSIONS tags + +* check returned strings + +LablGL 0.97: +------------ + +* support ocaml 3.04 + +LablGL 0.96: +------------ + +* adapt to new label mode / new variant syntax + +* split library into lablgl.cma and togl.cma to support ocaml dynamic + linking + +LablGL 0.95: +------------ + +* corrected variant matching for Objective Caml 3.01 + +* add variance annotations + +* some bug fixes + +LablGL 0.94: +------------ + +* corrected syntax for Objective Caml 3.00 + +LablGL 0.93: +------------ + +* use Objective Caml 2.99 instead of Objective Label. + +* a few functions changed, to comply with the new semantics + for optional arguments. + +* togl.cmo is not included in lablgl.cma, to allow easy linking + with lablgtk. + +LablGL 0.92: +------------ + +* allow use of newer patch levels for Tk. + +* corrected bugs in the Raw module. Now, it handles correctly + alignment constraints on doubles. + +* added the Raw.sub function, which extracts a slice from an existing + raw array. Values are still physically shared with the original + array. + +LablGL 0.91: +------------ + +* switched to Togl-1.5. The previous versions had problems on Linux. + +LablGL 0.9: +----------- + +* first public release diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 index 0000000..13accdc --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,26 @@ +Copyright (c) 1997-2001 Jacques Garrigue and Kyoto University. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the University 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 AUTHOR 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 AUTHOR 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/LablGlut/COPYRIGHT b/LablGlut/COPYRIGHT new file mode 100644 index 0000000..46f8d1d --- /dev/null +++ b/LablGlut/COPYRIGHT @@ -0,0 +1,33 @@ +LablGLUT, copyright (c) 2003 Issac Trotts. All rights reserved. +This copyright does not apply to any of the bundled demos by +Mike Kilgard or others, nor to the (modified) code by Hugues Casse contained +in the c2ml directory, nor to the (modified) code by Xavier Leroy contained +in the camlidl directory. + +Many of the demos are derived from original C sources in Mark Kilgard's +GLUT distribution. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. The name of the author may not be used to endorse or promote + products derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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/LablGlut/ChangeLog b/LablGlut/ChangeLog new file mode 100644 index 0000000..fb873a0 --- /dev/null +++ b/LablGlut/ChangeLog @@ -0,0 +1,56 @@ +2002-09-11 Issac Trotts + + * examples/glut3.7/test/joy_test.ml, examples/glut3.7/test/test10.ml, examples/glut3.7/test/test2.ml, examples/glut3.7/test/test26.ml, examples/glut3.7/test/test4.ml, examples/glut3.7/test/test8.ml: + updated calls to Glut.idleFunc + + * lablGL-0.98/gl_tags.var, lablGL-0.98/gluMat.ml, lablGL-0.98/gluMat.mli, lablGL-0.98/gluMisc.ml, lablGL-0.98/gluMisc.mli, lablGL-0.98/gluNurbs.ml, lablGL-0.98/gluNurbs.mli, lablGL-0.98/gluQuadric.ml, lablGL-0.98/gluQuadric.mli, lablGL-0.98/gluTess.ml, lablGL-0.98/gluTess.mli, lablGL-0.98/glu_tags.var, lablGL-0.98/lablGL.spec, lablGL-0.98/lablgl.bat, lablGL-0.98/lablgl.in, lablGL-0.98/ml_gl.c, lablGL-0.98/ml_gl.h, lablGL-0.98/ml_glu.c, lablGL-0.98/ml_raw.c, lablGL-0.98/ml_raw.h, lablGL-0.98/raw.ml, lablGL-0.98/raw.mli, lablGL-0.98/raw_tags.var, lablGL-0.98/var2def.ml, lablGL-0.98/var2switch.ml, lablGL-0.98/.cvsignore, lablGL-0.98/.depend, lablGL-0.98/CHANGES, lablGL-0.98/COPYRIGHT, lablGL-0.98/Makefile, lablGL-0.98/Makefile.config, lablGL-0.98/Makefile.config.ex, lablGL-0.98/README, lablGL-0.98/gl.ml, lablGL-0.98/gl.mli, lablGL-0.98/glClear.ml, lablGL-0.98/glClear.mli, lablGL-0.98/glDraw.ml, lablGL-0.98/glDraw.mli, lablGL-0.98/glFunc.ml, lablGL-0.98/glFunc.mli, lablGL-0.98/glLight.ml, lablGL-0.98/glLight.mli, lablGL-0.98/glList.ml, lablGL-0.98/glList.mli, lablGL-0.98/glMap.ml, lablGL-0.98/glMap.mli, lablGL-0.98/glMat.ml, lablGL-0.98/glMat.mli, lablGL-0.98/glMisc.ml, lablGL-0.98/glMisc.mli, lablGL-0.98/glPix.ml, lablGL-0.98/glPix.mli, lablGL-0.98/glTex.ml, lablGL-0.98/glTex.mli, examples/glut3.7/trackball/Makefile, examples/glut3.7/trackball/teaspin.ml, examples/glut3.7/test/joy_test.ml, examples/glut3.7/test/keyup_test.ml, examples/glut3.7/test/menu_test.ml, examples/glut3.7/test/shape_test.ml, examples/glut3.7/test/test1.ml, examples/glut3.7/test/test10.ml, examples/glut3.7/test/test11.ml, examples/glut3.7/test/test12.ml, examples/glut3.7/test/test13.ml, examples/glut3.7/test/test14.ml, examples/glut3.7/test/test15.ml, examples/glut3.7/test/test16.ml, examples/glut3.7/test/test17.ml, examples/glut3.7/test/test18.ml, examples/glut3.7/test/test19.ml, examples/glut3.7/test/test2.ml, examples/glut3.7/test/test20.ml, examples/glut3.7/test/test21.ml, examples/glut3.7/test/test22.ml, examples/glut3.7/test/test23.ml, examples/glut3.7/test/test24.ml, examples/glut3.7/test/test25.ml, examples/glut3.7/test/test26.ml, examples/glut3.7/test/test27.ml, examples/glut3.7/test/test28.ml, examples/glut3.7/test/test3.ml, examples/glut3.7/test/test4.ml, examples/glut3.7/test/test7.ml, examples/glut3.7/test/test8.ml, examples/glut3.7/test/test9.ml, examples/glut3.7/test/timer_test.ml, examples/glut3.7/test/cursor_test.ml, examples/nehe/lesson2.ml, examples/nehe/lesson3.ml, examples/nehe/lesson4.ml, examples/nehe/lesson5.ml, examples/etc/draw2d.ml, examples/lablGL/README, examples/lablGL/checker.ml, examples/lablGL/gears, examples/lablGL/gears.ml, examples/lablGL/morph3d.ml, examples/lablGL/planet.ml, examples/lablGL/scene.ml, examples/lablGL/simple.ml, examples/lablGL/texturesurf.ml, examples/checker.ml, examples/gears.ml, examples/morph3d.ml, examples/planet.ml, examples/scene.ml, examples/simple.ml, examples/texturesurf.ml: + . + + * src_lablglut/ml_glut.h, src_lablglut/ml_raw.h: + changed glutIdleFunc to take a function option so we can have a + null idle function and not burn up the cpu + + * src_lablglut/ezgl.mli, src_lablglut/ezglut, src_lablglut/ezgl.ml: . + +2002-09-02 Issac Trotts + + * examples/glut3.7/trackball/Makefile, examples/glut3.7/trackball/teaspin.ml, examples/glut3.7/trackball/trackball.ml, examples/glut3.7/trackball/trackball.mli: + . + + * examples/glut3.7/not_yet_ported/Makefile, examples/glut3.7/not_yet_ported/teaspin.ml, examples/glut3.7/not_yet_ported/trackball.c, examples/glut3.7/not_yet_ported/trackball.h, examples/glut3.7/not_yet_ported/trackball.ml, examples/glut3.7/not_yet_ported/trackball.mli: + removed some files + + * examples/glut3.7/not_yet_ported/teaspin.ml: - colored lights + - "Spin me" + + * examples/glut3.7/not_yet_ported/teaspin.ml: + - disabled back-face culling, so now the teapot renders correctly + + * examples/glut3.7/not_yet_ported/Makefile, examples/glut3.7/not_yet_ported/teaspin.ml: + Got teaspin to work, though it's still rough around the edges. + + * examples/glut3.7/not_yet_ported/Makefile, examples/glut3.7/not_yet_ported/dinospin.c, examples/glut3.7/not_yet_ported/dinospin.ml, examples/glut3.7/not_yet_ported/scube.c, examples/glut3.7/not_yet_ported/scube.ml, examples/glut3.7/not_yet_ported/splatlogo.c, examples/glut3.7/not_yet_ported/splatlogo.ml, examples/glut3.7/not_yet_ported/spots.c, examples/glut3.7/not_yet_ported/spots.ml, examples/glut3.7/not_yet_ported/stars.c, examples/glut3.7/not_yet_ported/stars.ml, examples/glut3.7/not_yet_ported/teaspin.ml, examples/glut3.7/not_yet_ported/trackball.c, examples/glut3.7/not_yet_ported/trackball.h, examples/glut3.7/not_yet_ported/trackball.ml, examples/glut3.7/not_yet_ported/trackball.mli: + . + +2002-09-01 Issac Trotts + + * THANKS, lgcompile, lgport.py: . + +2002-07-26 Issac Trotts + + * examples/README, examples/checker.ml, examples/gears.ml, examples/morph3d.ml, examples/planet.ml, examples/scene.ml, examples/simple.ml, examples/texturesurf.ml: + New file. + + * examples/README, examples/checker.ml, examples/gears.ml, examples/morph3d.ml, examples/planet.ml, examples/scene.ml, examples/simple.ml, examples/texturesurf.ml: + just getting started. + + + + * CHANGES, COPYRIGHT, README, TODO, build, src_lablglut/Makefile, src_lablglut/OCamlMakefile, src_lablglut/ezgl.ml, src_lablglut/ezgl.mli, src_lablglut/ezglut, src_lablglut/glut.ml, src_lablglut/glut.mli, src_lablglut/wrap_gl.c, src_lablglut/wrap_glut.c, toplevel_lablglut/Makefile, toplevel_lablglut/OCamlMakefile, toplevel_lablglut/lablglut: + New file. + + * CHANGES, COPYRIGHT, README, TODO, build, src_lablglut/Makefile, src_lablglut/OCamlMakefile, src_lablglut/ezgl.ml, src_lablglut/ezgl.mli, src_lablglut/ezglut, src_lablglut/glut.ml, src_lablglut/glut.mli, src_lablglut/wrap_gl.c, src_lablglut/wrap_glut.c, toplevel_lablglut/Makefile, toplevel_lablglut/OCamlMakefile, toplevel_lablglut/lablglut: + just getting started. + + + diff --git a/LablGlut/README b/LablGlut/README new file mode 100644 index 0000000..97407ec --- /dev/null +++ b/LablGlut/README @@ -0,0 +1,31 @@ +*LablGLUT* A GLUT Binding for OCaml Last change: 2003 Oct 22 + + LablGLUT + Issac Trotts + ijtrotts@ucdavis.edu + with nehe demo ports by Jeffrey Palmer + +Introduction +============ + +The LablGLUT library is an OCaml binding for GLUT version 3.7. GLUT +(GL Utility Toolkit) is a portable windowing library for OpenGL, +written by Mark Kilgard. GLUT tends to be easier to install and use than +other OpenGL windowing alternatives. It is very portable, depending +only on libraries for OpenGL and the underlying window system. + +Installation +============ + + The easy way is to become root and say + + ./build all opt install clean test + + Otherwise it's necessary to modify installation targets in the + Makefiles. + +License +======= + +LablGLUT is under a BSD-style license. + diff --git a/LablGlut/THANKS b/LablGlut/THANKS new file mode 100644 index 0000000..336d8f8 --- /dev/null +++ b/LablGlut/THANKS @@ -0,0 +1,15 @@ + THANKS TO + +- Jeffrey Palmer for contributing the nehe demo ports +- Mark Kilgard for creating GLUT +- Jacques Garrigue for writing LablGL +- Markus Mottl for writing OCamlMakefile +- Hugues Casse for writing FrontC, the basis for the program c2ml + included with LablGLUT. This program was very helpful in porting the + original GLUT demos written in C. +- Xavier Leroy for writing Camlidl, a wrapper generator for OCaml. + LablGLUT comes with a modified version of Camlidl that can handle + [bigarray,in] void* arguments, as well as arrays of GLdoubles and GLfloats. + Camlidl was used to write LablGLUT's simplified bindings for GL and GLU. +- The OCaml team + diff --git a/LablGlut/TODO b/LablGlut/TODO new file mode 100644 index 0000000..73e7de0 --- /dev/null +++ b/LablGlut/TODO @@ -0,0 +1,3 @@ +- port lots of demos +- add reading of .pnm files + diff --git a/LablGlut/examples/README b/LablGlut/examples/README new file mode 100644 index 0000000..0712d70 --- /dev/null +++ b/LablGlut/examples/README @@ -0,0 +1,3 @@ +$Id: README,v 1.2 2003-09-26 08:25:07 garrigue Exp $ + +Here are a few examples for LablGL. diff --git a/LablGlut/examples/caml-images/ChangeLog b/LablGlut/examples/caml-images/ChangeLog new file mode 100644 index 0000000..37e8afd --- /dev/null +++ b/LablGlut/examples/caml-images/ChangeLog @@ -0,0 +1,26 @@ +2002-09-20 Issac Trotts + + * main.ml: + Added a check so we don't do the expensive rescale unless we have to. + + * main.ml: Fixed up the aspect ratio. + + * main.ml: + Added rescaling to next highest power of two along each axis. + Changed texture coordinates so the image no longer appears rotated by 90 deg. + + * main.ml: + Added conversion from camlimages to lablGL's preferred raw format. + In order to make the image a power of two, I truncate the image. + This needs to be replaced with scaling up to the next largest power of + two and rescaling the square to have the proper aspect ratio. + + * .Makefile.swp: . + + * .Makefile.swp, Makefile, OCamlMakefile, main.ml: + Just displays a checkerboard at the moment. + + + + + diff --git a/LablGlut/examples/caml-images/Makefile b/LablGlut/examples/caml-images/Makefile new file mode 100644 index 0000000..9103eb5 --- /dev/null +++ b/LablGlut/examples/caml-images/Makefile @@ -0,0 +1,14 @@ +include $(OCAML)/camlimages/Makefile.config + +all: dc + +RESULT=ciglut +SOURCES=main.ml +LIBS=lablgl lablglut +INCDIRS=+camlimages +lablGL +lablglut +OCAMLFLAGS=$(COMPFLAGS_CAMLIMAGES) +#OCAMLLDFLAGS=$(COMPFLAGS_CAMLIMAGES) $(LINKFLAGS_CAMLIMAGES) +OCAMLLDFLAGS=$(COMPFLAGS_CAMLIMAGES) $(LINKFLAGS_CAMLIMAGES) + +include ./OCamlMakefile + diff --git a/LablGlut/examples/caml-images/OCamlMakefile b/LablGlut/examples/caml-images/OCamlMakefile new file mode 100644 index 0000000..00122ba --- /dev/null +++ b/LablGlut/examples/caml-images/OCamlMakefile @@ -0,0 +1,802 @@ +########################################################################### +# OCamlMakefile +# Copyright (C) 1999-2002 Markus Mottl +# +# For updates see: +# http://www.oefai.at/~markus/ocaml_sources +# +# $Id: OCamlMakefile,v 1.1 2003-09-25 13:54:01 raffalli Exp $ +# +########################################################################### + +# Set these variables to the names of the sources to be processed and +# the result variable. Order matters during linkage! + +ifndef SOURCES + SOURCES := foo.ml +endif +export SOURCES + +ifndef RES_CLIB_SUF + RES_CLIB_SUF := _stubs +endif +export RES_CLIB_SUF + +ifndef RESULT + RESULT := foo +endif +export RESULT + +ifndef DOC_FILES + DOC_FILES := $(filter %.mli, $(SOURCES)) +endif +export DOC_FILES + +export BCSUFFIX +export NCSUFFIX + +ifndef TOPSUFFIX + TOPSUFFIX := .top +endif + +export TOPSUFFIX + +# Eventually set include- and library-paths, libraries to link, +# additional compilation-, link- and ocamlyacc-flags +# Path- and library information needs not be written with "-I" and such... +# Define THREADS if you need it, otherwise leave it unset (same for +# USE_CAMLP4)! + +export THREADS +export USE_CAMLP4 + +export INCDIRS +export LIBDIRS +export OCAML_DEFAULT_DIRS +export OCAML_LIB_INSTALL + +export LIBS +export CLIBS + +export OCAMLFLAGS +export OCAMLNCFLAGS +export OCAMLBCFLAGS + +export OCAMLLDFLAGS +export OCAMLNLDFLAGS +export OCAMLBLDFLAGS + +ifndef OCAMLCPFLAGS + OCAMLCPFLAGS := a +endif + +export OCAMLCPFLAGS + +export YFLAGS +export IDLFLAGS + +export OCAMLDOCFLAGS + +export DVIPSFLAGS + +export STATIC + +# Add a list of optional trash files that should be deleted by "make clean" +export TRASH + +#################### variables depending on your OCaml-installation + +ifdef MINGW + export MINGW + WIN32 := 1 +endif +ifdef MSVC + export MSVC + WIN32 := 1 + EXT_OBJ := obj + EXT_LIB := lib + ifeq ($(CC),gcc) + # work around GNU Make default value + CC := cl + endif + ifeq ($(CXX),g++) + # work around GNU Make default value + CXX := cl + endif + CFLAG_O := -Fo +endif +ifdef WIN32 + EXT_CXX := cpp + EXE := .exe +endif + +ifndef EXT_OBJ + EXT_OBJ := o +endif +ifndef EXT_LIB + EXT_LIB := a +endif +ifndef EXT_CXX + EXT_CXX := cc +endif +ifndef EXE + EXE := # empty +endif +ifndef CFLAG_O + CFLAG_O := -o # do not delete this comment (preserves trailing whitespace)! +endif + +export CC +export CXX +export CFLAGS +export CXXFLAGS +export LDFLAGS + +BCRESULT := $(addsuffix $(BCSUFFIX), $(RESULT)) +NCRESULT := $(addsuffix $(NCSUFFIX), $(RESULT)) +TOPRESULT := $(addsuffix $(TOPSUFFIX), $(RESULT)) + +ifndef OCAMLC + OCAMLC := ocamlc +endif + +export OCAMLC + +ifndef OCAMLOPT + OCAMLOPT := ocamlopt +endif + +export OCAMLOPT + +ifndef OCAMLMKTOP + OCAMLMKTOP := ocamlmktop +endif + +export OCAMLMKTOP + +ifndef OCAMLCP + OCAMLCP := ocamlcp +endif + +export OCAMLCP + +ifndef OCAMLDEP + OCAMLDEP := ocamldep +endif + +export OCAMLDEP + +ifndef OCAMLLEX + OCAMLLEX := ocamllex +endif + +export OCAMLLEX + +ifndef OCAMLYACC + OCAMLYACC := ocamlyacc +endif + +export OCAMLYACC + +ifndef CAMLIDL + CAMLIDL := camlidl +endif + +export CAMLIDL + +ifndef CAMLIDLDLL + CAMLIDLDLL := camlidldll +endif + +export CAMLIDLDLL + +ifndef NOIDLHEADER + MAYBE_IDL_HEADER := -header +endif + +export NOIDLHEADER + +ifndef CAMLP4 + CAMLP4 := camlp4 +endif + +export CAMLP4 + +ifndef OCAMLDOC + OCAMLDOC := ocamldoc +endif + +export OCAMLDOC + +ifndef LATEX + LATEX := latex +endif + +export LATEX + +ifndef DVIPS + DVIPS := dvips +endif + +export DVIPS + +ifndef PS2PDF + PS2PDF := ps2pdf +endif + +export PS2PDF + +ifndef OCAMLMAKEFILE + OCAMLMAKEFILE := OCamlMakefile +endif + +export OCAMLMAKEFILE + +ifndef OCAMLLIBPATH + OCAMLLIBPATH := \ + $(shell $(OCAMLC) 2>/dev/null -where || echo /usr/local/lib/ocaml) +endif + +export OCAMLLIBPATH + +ifndef OCAML_LIB_INSTALL + OCAML_LIB_INSTALL := $(OCAMLLIBPATH)/contrib +endif + +export OCAML_LIB_INSTALL + +########################################################################### + +#################### change following sections only if +#################### you know what you are doing! + +# for pedants using "--warn-undefined-variables" +export MAYBE_IDL +export REAL_RESULT +export CAMLIDLFLAGS +export THREAD_FLAG +export RES_CLIB +export MAKEDLL + +SHELL := /bin/sh + +MLDEPDIR := ._d +BCDIDIR := ._bcdi +NCDIDIR := ._ncdi + +FILTERED := $(filter %.mli %.ml %.mll %.mly %.idl %.c %.$(EXT_CXX), \ + $(SOURCES)) +SOURCE_DIRS := $(filter-out ./, $(sort $(dir $(FILTERED)))) + +FILTERED_ML := $(filter %.ml, $(FILTERED)) +DEP_ML := $(FILTERED_ML:%.ml=$(MLDEPDIR)/%.d) + +FILTERED_MLI := $(filter %.mli, $(FILTERED)) +DEP_MLI := $(FILTERED_MLI:.mli=.di) + +FILTERED_MLL := $(filter %.mll, $(FILTERED)) +DEP_MLL := $(FILTERED_MLL:%.mll=$(MLDEPDIR)/%.d) +AUTO_MLL := $(FILTERED_MLL:.mll=.ml) + +FILTERED_MLY := $(filter %.mly, $(FILTERED)) +DEP_MLY := $(FILTERED_MLY:%.mly=$(MLDEPDIR)/%.d) $(FILTERED_MLY:.mly=.di) +AUTO_MLY := $(FILTERED_MLY:.mly=.mli) $(FILTERED_MLY:.mly=.ml) + +FILTERED_IDL := $(filter %.idl, $(FILTERED)) +DEP_IDL := $(FILTERED_IDL:%.idl=$(MLDEPDIR)/%.d) $(FILTERED_IDL:.idl=.di) +C_IDL := $(FILTERED_IDL:%.idl=%_stubs.c) $(FILTERED_IDL:.idl=.h) +OBJ_C_IDL := $(FILTERED_IDL:%.idl=%_stubs.$(EXT_OBJ)) +AUTO_IDL := $(FILTERED_IDL:.idl=.mli) $(FILTERED_IDL:.idl=.ml) $(C_IDL) + +FILTERED_C_CXX := $(filter %.c %.$(EXT_CXX), $(FILTERED)) +OBJ_C_CXX := $(FILTERED_C_CXX:.c=.$(EXT_OBJ)) +OBJ_C_CXX := $(OBJ_C_CXX:.$(EXT_CXX)=.$(EXT_OBJ)) + +PRE_TARGETS += $(AUTO_MLL) $(AUTO_MLY) $(AUTO_IDL) + +ALL_DEPS := $(DEP_ML) $(DEP_MLI) $(DEP_MLL) $(DEP_MLY) $(DEP_IDL) +MLDEPS := $(filter %.d, $(ALL_DEPS)) +MLIDEPS := $(filter %.di, $(ALL_DEPS)) +BCDEPIS := $(MLIDEPS:%.di=$(BCDIDIR)/%.di) +NCDEPIS := $(MLIDEPS:%.di=$(NCDIDIR)/%.di) + +ALLML := $(filter %.mli %.ml %.mll %.mly %.idl, $(FILTERED)) + +IMPLO_INTF := $(ALLML:%.mli=%.mli.__) +IMPLO_INTF := $(foreach file, $(IMPLO_INTF), \ + $(basename $(file)).cmi $(basename $(file)).cmo) +IMPLO_INTF := $(filter-out %.mli.cmo, $(IMPLO_INTF)) +IMPLO_INTF := $(IMPLO_INTF:%.mli.cmi=%.cmi) + +IMPLX_INTF := $(IMPLO_INTF:.cmo=.cmx) + +INTF := $(filter %.cmi, $(IMPLO_INTF)) +IMPL_CMO := $(filter %.cmo, $(IMPLO_INTF)) +IMPL_CMX := $(IMPL_CMO:.cmo=.cmx) + +OBJ_LINK := $(OBJ_C_IDL) $(OBJ_C_CXX) +OBJ_FILES := $(IMPL_CMO:.cmo=.$(EXT_OBJ)) $(OBJ_LINK) + +EXECS := $(addsuffix $(EXE), \ + $(sort $(TOPRESULT) $(BCRESULT) $(NCRESULT))) +ifdef WIN32 + EXECS += $(BCRESULT).dll $(NCRESULT).dll +endif + +CLIB_BASE := $(RESULT)$(RES_CLIB_SUF) +ifneq ($(strip $(OBJ_LINK)),) + RES_CLIB := lib$(CLIB_BASE).$(EXT_LIB) +endif +DLLSONAME := dll$(CLIB_BASE).so +NONEXECS := $(INTF) $(IMPL_CMO) $(IMPL_CMX) $(OBJ_FILES) $(PRE_TARGETS) \ + $(BCRESULT).cma $(NCRESULT).cmxa $(NCRESULT).$(EXT_LIB) \ + $(RES_CLIB) $(DLLSONAME) + +ifndef LIBINSTALL_FILES + LIBINSTALL_FILES := $(RESULT).mli $(RESULT).cmi $(RESULT).cma \ + $(RESULT).cmxa $(RESULT).a $(RES_CLIB) $(DLLSONAME) +endif +export LIBINSTALL_FILES + +ifdef WIN32 + # some extra stuff is created while linking DLLs + NONEXECS += $(BCRESULT).$(EXT_LIB) $(BCRESULT).exp $(NCRESULT).exp +endif + +TARGETS := $(EXECS) $(NONEXECS) + +# If there are IDL-files +ifneq ($(strip $(FILTERED_IDL)),) + MAYBE_IDL := -cclib -lcamlidl +endif + +ifdef USE_CAMLP4 + CAMLP4PATH := \ + $(shell $(CAMLP4) -where 2>/dev/null || echo /usr/local/lib/camlp4) + INCFLAGS := -I $(CAMLP4PATH) + CINCFLAGS := -I$(CAMLP4PATH) +endif + +INCFLAGS += $(SOURCE_DIRS:%=-I %) $(INCDIRS:%=-I %) $(OCAML_DEFAULT_DIRS:%=-I %) +CINCFLAGS += $(SOURCE_DIRS:%=-I%) $(INCDIRS:%=-I%) $(OCAML_DEFAULT_DIRS:%=-I%) +CLIBFLAGS += $(SOURCE_DIRS:%=-L%) $(LIBDIRS:%=-L%) $(OCAML_DEFAULT_DIRS:%=-L%) + +ifndef PROFILING + INTF_OCAMLC := $(OCAMLC) +else + ifndef THREADS + INTF_OCAMLC := $(OCAMLCP) -p $(OCAMLCPFLAGS) + else + # OCaml does not support profiling byte code + # with threads (yet), therefore we force an error. + ifndef REAL_OCAMLC + $(error Profiling of multithreaded byte code not yet supported by OCaml) + endif + endif +endif + +ifndef MSVC + COMMON_LDFLAGS := $(LDFLAGS:%=-ccopt %) $(SOURCE_DIRS:%=-ccopt -L%) \ + $(LIBDIRS:%=-ccopt -L%) $(OCAML_DEFAULT_DIRS:%=-ccopt -L%) +else + # currenly MSVC-build ocamlc/ocamlopt cannot pass any option to C linker :-( + COMMON_LDFLAGS := +endif + +ifndef MSVC + CLIBS_OPTS := $(CLIBS:%=-cclib -l%) +else + # MSVC libraries do not have 'lib' prefix + CLIBS_OPTS := $(CLIBS:%=-ccopt %) +endif +ifneq ($(strip $(OBJ_LINK)),) + ifdef CREATE_LIB + OBJS_LIBS := -cclib -l$(CLIB_BASE) $(CLIBS_OPTS) $(MAYBE_IDL) + else + OBJS_LIBS := $(OBJ_LINK) $(CLIBS_OPTS) $(MAYBE_IDL) + endif +else + OBJS_LIBS := $(CLIBS_OPTS) $(MAYBE_IDL) +endif + +# If we have to make byte-code +ifndef REAL_OCAMLC + SPECIAL_OCAMLFLAGS := $(OCAMLBCFLAGS) + + REAL_OCAMLC := $(INTF_OCAMLC) + + REAL_IMPL := $(IMPL_CMO) + REAL_IMPL_INTF := $(IMPLO_INTF) + IMPL_SUF := .cmo + + DEPFLAGS := + MAKE_DEPS := $(MLDEPS) $(BCDEPIS) + + ifdef CREATE_LIB + ifndef STATIC + ifneq ($(strip $(OBJ_LINK)),) + MAKEDLL := $(DLLSONAME) + ALL_LDFLAGS := -dllib $(DLLSONAME) + endif + endif + endif + + ifneq "$(strip $(OBJ_LINK) $(THREADS) $(MAYBE_IDL) $(CLIBS))" "" + ALL_LDFLAGS += -custom + endif + + ALL_LDFLAGS += $(INCFLAGS) $(OCAMLLDFLAGS) $(OCAMLBLDFLAGS) \ + $(COMMON_LDFLAGS) $(LIBS:%=%.cma) + CAMLIDLDLLFLAGS := + + ifdef THREADS + ALL_LDFLAGS += -thread unix.cma threads.cma + THREAD_FLAG := -thread + endif + +# we have to make native-code +else + ifndef PROFILING + SPECIAL_OCAMLFLAGS := $(OCAMLNCFLAGS) + PLDFLAGS := + else + SPECIAL_OCAMLFLAGS := -p $(OCAMLNCFLAGS) + PLDFLAGS := -p + endif + + REAL_IMPL := $(IMPL_CMX) + REAL_IMPL_INTF := $(IMPLX_INTF) + IMPL_SUF := .cmx + + CFLAGS := -DNATIVE_CODE $(CFLAGS) + + DEPFLAGS := -native + MAKE_DEPS := $(MLDEPS) $(NCDEPIS) + + ALL_LDFLAGS := $(PLDFLAGS) $(INCFLAGS) $(OCAMLLDFLAGS) \ + $(OCAMLNLDFLAGS) $(COMMON_LDFLAGS) + CAMLIDLDLLFLAGS := -opt + + ifndef CREATE_LIB + ALL_LDFLAGS += $(LIBS:%=%.cmxa) + endif + + ifdef THREADS + ALL_LDFLAGS := -thread $(ALL_LDFLAGS) + ifndef CREATE_LIB + ALL_LDFLAGS += unix.cmxa threads.cmxa + endif + THREAD_FLAG := -thread + endif +endif + +ALL_OCAMLCFLAGS := $(THREAD_FLAG) $(OCAMLFLAGS) \ + $(INCFLAGS) $(SPECIAL_OCAMLFLAGS) + +ifdef make_deps + -include $(MAKE_DEPS) + PRE_TARGETS := +endif + +########################################################################### +# USER RULES + +# generates byte-code (default) +byte-code: $(PRE_TARGETS) + @$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ + REAL_RESULT="$(BCRESULT)" make_deps=yes +bc: byte-code + +byte-code-nolink: $(PRE_TARGETS) + @$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ + REAL_RESULT="$(BCRESULT)" make_deps=yes +bcnl: byte-code-nolink + +top: $(PRE_TARGETS) + @$(MAKE) -r -f $(OCAMLMAKEFILE) $(TOPRESULT) \ + REAL_RESULT="$(BCRESULT)" make_deps=yes + +# generates native-code + +native-code: $(PRE_TARGETS) + @$(MAKE) -r -f $(OCAMLMAKEFILE) $(NCRESULT) \ + REAL_RESULT="$(NCRESULT)" \ + REAL_OCAMLC="$(OCAMLOPT)" \ + make_deps=yes +nc: native-code + +native-code-nolink: $(PRE_TARGETS) + @$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ + REAL_RESULT="$(NCRESULT)" \ + REAL_OCAMLC="$(OCAMLOPT)" \ + make_deps=yes +ncnl: native-code-nolink + +# generates byte-code libraries +byte-code-library: $(PRE_TARGETS) + @$(MAKE) -r -f $(OCAMLMAKEFILE) \ + $(RES_CLIB) $(BCRESULT).cma \ + REAL_RESULT="$(BCRESULT)" \ + CREATE_LIB=yes \ + make_deps=yes +bcl: byte-code-library + +# generates native-code libraries +native-code-library: $(PRE_TARGETS) + @$(MAKE) -r -f $(OCAMLMAKEFILE) \ + $(RES_CLIB) $(NCRESULT).cmxa \ + REAL_RESULT="$(NCRESULT)" \ + REAL_OCAMLC="$(OCAMLOPT)" \ + CREATE_LIB=yes \ + make_deps=yes +ncl: native-code-library + +ifdef WIN32 +# generates byte-code dll +byte-code-dll: $(PRE_TARGETS) + @$(MAKE) -r -f $(OCAMLMAKEFILE) \ + $(RES_CLIB) $(BCRESULT).dll \ + REAL_RESULT="$(BCRESULT)" \ + make_deps=yes +bcd: byte-code-dll + +# generates native-code dll +native-code-dll: $(PRE_TARGETS) + @$(MAKE) -r -f $(OCAMLMAKEFILE) \ + $(RES_CLIB) $(NCRESULT).dll \ + REAL_RESULT="$(NCRESULT)" \ + REAL_OCAMLC="$(OCAMLOPT)" \ + make_deps=yes +ncd: native-code-dll +endif + +# generates byte-code with debugging information +debug-code: $(PRE_TARGETS) + @$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ + REAL_RESULT="$(BCRESULT)" make_deps=yes \ + OCAMLFLAGS="-g $(OCAMLFLAGS)" \ + OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" +dc: debug-code + +# generates byte-code libraries with debugging information +debug-code-library: $(PRE_TARGETS) + @$(MAKE) -r -f $(OCAMLMAKEFILE) \ + $(RES_CLIB) $(BCRESULT).cma \ + REAL_RESULT="$(BCRESULT)" make_deps=yes \ + CREATE_LIB=yes \ + OCAMLFLAGS="-g $(OCAMLFLAGS)" \ + OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" +dcl: debug-code-library + +# generates byte-code for profiling +profiling-byte-code: $(PRE_TARGETS) + @$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ + REAL_RESULT="$(BCRESULT)" PROFILING="y" \ + make_deps=yes +pbc: profiling-byte-code + +# generates native-code + +profiling-native-code: $(PRE_TARGETS) + @$(MAKE) -r -f $(OCAMLMAKEFILE) $(NCRESULT) \ + REAL_RESULT="$(NCRESULT)" \ + REAL_OCAMLC="$(OCAMLOPT)" \ + PROFILING="y" \ + make_deps=yes +pnc: profiling-native-code + +# generates byte-code libraries +profiling-byte-code-library: $(PRE_TARGETS) + @$(MAKE) -r -f $(OCAMLMAKEFILE) \ + $(RES_CLIB) $(BCRESULT).cma \ + REAL_RESULT="$(BCRESULT)" PROFILING="y" \ + CREATE_LIB=yes \ + make_deps=yes +pbcl: profiling-byte-code-library + +# generates native-code libraries +profiling-native-code-library: $(PRE_TARGETS) + @$(MAKE) -r -f $(OCAMLMAKEFILE) \ + $(RES_CLIB) $(NCRESULT).cmxa \ + REAL_RESULT="$(NCRESULT)" PROFILING="y" \ + REAL_OCAMLC="$(OCAMLOPT)" \ + CREATE_LIB=yes \ + make_deps=yes +pncl: profiling-native-code-library + +# generates HTML-documentation +htdoc: doc/html + +# generates Latex-documentation +ladoc: doc/latex + +# generates PostScript-documentation +psdoc: doc/latex/doc.ps + +# generates PDF-documentation +pdfdoc: doc/latex/doc.pdf + +# generates all supported forms of documentation +doc: htdoc ladoc psdoc pdfdoc + +########################################################################### +# LOW LEVEL RULES + +$(REAL_RESULT): $(REAL_IMPL_INTF) $(OBJ_LINK) + $(REAL_OCAMLC) $(ALL_LDFLAGS) $(OBJS_LIBS) -o $@$(EXE) \ + $(REAL_IMPL) +ifdef MSVC +# work around the bug in ocamlc -- it should delete this file itself + rm -f camlprim?.$(EXT_OBJ) +endif + +nolink: $(REAL_IMPL_INTF) $(OBJ_LINK) + +ifdef WIN32 +$(REAL_RESULT).dll: $(REAL_IMPL_INTF) $(OBJ_LINK) + $(CAMLIDLDLL) $(CAMLIDLDLLFLAGS) $(OBJ_LINK) $(CLIBS) \ + -o $@ $(REAL_IMPL) +endif + +%$(TOPSUFFIX): $(REAL_IMPL_INTF) $(OBJ_LINK) + $(OCAMLMKTOP) $(ALL_LDFLAGS) $(OBJS_LIBS) -o $@$(EXE) \ + $(REAL_IMPL) +ifdef MSVC +# work around the bug in ocamltop -- it should delete this file itself + rm -f camlprim?.$(EXT_OBJ) +endif + +.SUFFIXES: .mli .ml .cmi .cmo .cmx .cma .cmxa .$(EXT_OBJ) \ + .mly .di .d .$(EXT_LIB) .idl .c .$(EXT_CXX) .h .so + +$(DLLSONAME): $(OBJ_LINK) + $(CC) -shared $(CINCFLAGS) $(CLIBFLAGS) \ + -o $@ $(OBJ_LINK) $(CLIBS:%=-l%) + +$(RESULT).cma: $(REAL_IMPL_INTF) $(MAKEDLL) + $(REAL_OCAMLC) -a $(ALL_LDFLAGS) \ + $(OBJS_LIBS) -o $@ $(OCAMLBLDFLAGS) $(REAL_IMPL) + +$(RESULT).cmxa $(RESULT).$(EXT_LIB): $(REAL_IMPL_INTF) + $(OCAMLOPT) -a $(ALL_LDFLAGS) $(OBJS_LIBS) \ + $(OCAMLNLDFLAGS) -o $@ $(REAL_IMPL) + +$(RES_CLIB): $(OBJ_LINK) +ifndef MSVC + ifneq ($(strip $(OBJ_LINK)),) + ar rc $@ $(OBJ_LINK) + ranlib $@ + endif +else + ifneq ($(strip $(OBJ_LINK)),) + lib /nologo /debugtype:cv /out:$(RES_CLIB) $(OBJ_LINK) + endif +endif + +.mli.cmi: + @pp=`sed -n -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ + if [ -z "$$pp" ]; then \ + echo $(INTF_OCAMLC) -c $(THREAD_FLAG) \ + $(OCAMLFLAGS) $(INCFLAGS) $<; \ + $(INTF_OCAMLC) -c $(THREAD_FLAG) $(OCAMLFLAGS) \ + $(INCFLAGS) $<; \ + else \ + echo $(INTF_OCAMLC) -c -pp \"$$pp\" $(THREAD_FLAG) \ + $(OCAMLFLAGS) $(INCFLAGS) $<; \ + $(INTF_OCAMLC) -c -pp "$$pp" $(THREAD_FLAG) \ + $(OCAMLFLAGS) $(INCFLAGS) $<; \ + fi + +.ml.cmi .ml.$(EXT_OBJ) .ml.cmx .ml.cmo: + @pp=`sed -n -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ + if [ -z "$$pp" ]; then \ + echo $(REAL_OCAMLC) -c $(ALL_OCAMLCFLAGS) $<; \ + $(REAL_OCAMLC) -c $(ALL_OCAMLCFLAGS) $<; \ + else \ + echo $(REAL_OCAMLC) -c -pp \"$$pp\" \ + $(ALL_OCAMLCFLAGS) $<; \ + $(REAL_OCAMLC) -c -pp "$$pp" $(ALL_OCAMLCFLAGS) $<; \ + fi + +.PRECIOUS: %.ml +%.ml: %.mll + $(OCAMLLEX) $< + +.PRECIOUS: %.ml %.mli +%.ml %.mli: %.mly + $(OCAMLYACC) $(YFLAGS) $< + +.PRECIOUS: %.ml %.mli %_stubs.c %.h +%.ml %.mli %_stubs.c %.h: %.idl + $(CAMLIDL) $(MAYBE_IDL_HEADER) $(IDLFLAGS) \ + $(CAMLIDLFLAGS) $< + @if [ $(NOIDLHEADER) ]; then touch $*.h; fi + +.c.$(EXT_OBJ): + $(CC) -c $(CFLAGS) $(CINCFLAGS) -I$(OCAMLLIBPATH) \ + $< $(CFLAG_O)$@ + +.$(EXT_CXX).$(EXT_OBJ): + $(CXX) -c $(CXXFLAGS) $(CINCFLAGS) -I$(OCAMLLIBPATH) \ + $< $(CFLAG_O)$@ + +$(MLDEPDIR)/%.d: %.ml + @echo making $@ from $< + @if [ ! -d $(@D) ]; then mkdir -p $(@D); fi + @pp=`sed -n -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ + if [ -z "$$pp" ]; then \ + $(OCAMLDEP) $(INCFLAGS) $< > $@; \ + else \ + $(OCAMLDEP) -pp "$$pp" $(INCFLAGS) $< > $@; \ + fi + +$(BCDIDIR)/%.di $(NCDIDIR)/%.di: %.mli + @echo making $@ from $< + @if [ ! -d $(@D) ]; then mkdir -p $(@D); fi + @pp=`sed -n -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ + if [ -z "$$pp" ]; then \ + $(OCAMLDEP) $(DEPFLAGS) $(INCFLAGS) $< > $@; \ + else \ + $(OCAMLDEP) $(DEPFLAGS) \ + -pp "$$pp" $(INCFLAGS) $< > $@; \ + fi + +doc/html: $(DOC_FILES) + rm -rf $@ + mkdir -p $@ + $(OCAMLDOC) -html -d $@ $(OCAMLDOCFLAGS) $(DOC_FILES) + +doc/latex: $(DOC_FILES) + rm -rf $@ + mkdir -p $@ + $(OCAMLDOC) -latex -d $@ $(OCAMLDOCFLAGS) $(DOC_FILES) -o doc.tex + +doc/latex/doc.ps: doc/latex + cd doc/latex && \ + $(LATEX) doc.tex && \ + $(LATEX) doc.tex && \ + $(DVIPS) $(DVIPSFLAGS) doc.dvi -o $(@F) + +doc/latex/doc.pdf: doc/latex/doc.ps + cd doc/latex && $(PS2PDF) $(= 0 && (!y land (1 lsl !i)) == 0 do + i := !i - 1; + done; + 1 lsl !i; +;; + +let pow2ceil x = + let p2f = pow2floor x in + if p2f = x then x else (pow2floor x) lsl 1;; + +let i2f i = float_of_int i;; +let f2i f = int_of_float f;; + +let raw_of_camlimg cimg = + let w = cimg#width and h = cimg#height in + let image = GlPix.create `ubyte ~format:`rgb ~width:w ~height:h in + for i = 0 to w - 1 do + for j = 0 to h - 1 do + let pixel = cimg#get i j in (* pixel is a Color.rgb *) + Raw.sets (GlPix.to_raw image) ~pos:(3*(i*h+j)) + [| pixel.r; pixel.g; pixel.b |]; + done + done; + image +;; + +(* scale the image up so it's a power of two along each axis. + (IMPROVEME: this takes too long) *) +let rescale img = + let newimg = img#resize None (pow2ceil img#width) (pow2ceil img#height) in + img#destroy; + newimg;; + +let initialize ci_img = + printf "initializing..."; endl(); + GlClear.color (0.0, 0.0, 0.0); + (* save the original width and height *) + let w = ci_img#width and h = ci_img#height in + width := w; + height := h; + let ci_img = if pow2floor w <> w || pow2floor h <> h + then rescale ci_img else ci_img in + let gl_image = raw_of_camlimg ci_img in + GlPix.store (`unpack_alignment 1); + GlTex.image2d gl_image; + List.iter (GlTex.parameter ~target:`texture_2d) + [ `wrap_s `clamp; + `wrap_t `clamp; + `mag_filter `linear; + `min_filter `linear ]; + GlTex.env (`mode `decal); + Gl.enable `texture_2d; + GlDraw.shade_model `flat; + printf "done"; endl(); +;; + +(* -- ui callbacks -- *) + + +let disp_called = ref false + +let display () = + if not(!disp_called) then begin + Glut.reshapeWindow !width !height; + GluMat.ortho2d ~x:(0.0, i2f !width) ~y:(0.0, i2f !height); + disp_called := true + end; + + GlClear.clear [`color]; + GlDraw.begins `quads; + let w = i2f !width and h = i2f !height in + GlTex.coord2(1.0, 0.0); GlDraw.vertex3(0.0, 0.0, 0.0); + GlTex.coord2(1.0, 1.0); GlDraw.vertex3(w, 0.0, 0.0); + GlTex.coord2(0.0, 1.0); GlDraw.vertex3(w, h, 0.0); + GlTex.coord2(0.0, 0.0); GlDraw.vertex3(0.0, h, 0.0); + GlDraw.ends(); + + GlDraw.begins `lines; + GlDraw.color(1.0, 0.0, 0.0); + GlDraw.vertex2(0.0, 0.0); + GlDraw.vertex2(1.0, 0.0); + + GlDraw.color(0.0, 1.0, 0.0); + GlDraw.vertex2(0.0, 0.0); + GlDraw.vertex2(0.0, 1.0); + GlDraw.ends(); + + Gl.flush (); + +;; + +let on_keyboard ~key ~x ~y = + match key with + | 27 -> exit 0; + | _ -> (); +;; + +let view_with_glut img = + (* open a couple of Glut windows and display the file directly + and via texture on a square *) + ignore(Glut.init Sys.argv); + Glut.initDisplayMode ~double_buffer:false ~depth:false (); + Glut.initWindowSize 256 256; + ignore(Glut.createWindow "ocimgview"); + GlDraw.shade_model `flat; + GlClear.color(0.0,0.0,0.0); + (* GluMat.ortho2d ~x:(0.0,1.0) ~y:(0.0,1.0); *) + initialize img; + Glut.displayFunc (fun () -> display()); + Glut.keyboardFunc (fun ~key ~x ~y -> on_keyboard ~key ~x ~y); + Glut.postRedisplay(); + Glut.mainLoop(); +;; + +let _ = + Bitmap.maximum_live := 15000000; (* 60MB *) + Bitmap.maximum_block_size := !Bitmap.maximum_live / 16; + let r = Gc.get () in + r.Gc.max_overhead <- 30; + Gc.set r +;; + +let _ = + let filename = ref None in + let argfmt = [ + (* "-scale", Arg.Float (fun sc -> scale := sc), "scale"; *) + ] in + Arg.parse argfmt (fun s -> filename := Some s) + "ocimgview file"; + let filename = match !filename with + | None -> Arg.usage argfmt "ocimgview file"; exit(-1); + | Some s -> s + in + printf "Reading in %s" filename; endl(); + let img = OImage.load filename [] in + let img = OImage.rgb24 img in + + view_with_glut img; +;; + diff --git a/LablGlut/examples/caml-images/ppm.ppm b/LablGlut/examples/caml-images/ppm.ppm new file mode 100644 index 0000000..23451d6 --- /dev/null +++ b/LablGlut/examples/caml-images/ppm.ppm @@ -0,0 +1,112 @@ +P6 +# CREATOR: XV Version 3.10a+FLmask+jp5.3.3+PNG patch 1.2d+misc Rev: 12/29/94 +# CREATOR: XV Version 3.10a+FLmask+jp5.3.3+PNG patch 1.2d+misc Rev: 12/29/94 +250 167 +255 +蛣艂撖銕葖銕鈰銕搟琩撖琩艂琩艂琩琱葖銕甯銢閫銕銕撖銕銕葖銕銕銕銕撖撖敿撖擃撖撖銕銕銕銕銕銕銕閫撖銕銕撖銕銕隢銕撖擃艂銕銕撖銕銕艂銕撖銕銕銕銕銕撖銕艂蒗銕葖銕銕艂琩艂嶆艂鈰撖銕銕銕葖銕鈰銕銕酮銕葖葖蝳銕葖銕葖琩艂艂琱琩銕琱菾屣銢銕艂獢蛣葖葖銕銕葖葖銕銕銕艂琩艂琩琩銕銕銕菗銕銕銕銕葖艂銕銕銕銕銕琱銕銕銕銕葖艂艂琩琱琱艂葖琩葖葖艂銕琱琱琱獢葖葖銕琱銕艂銕銕銕琱琩艂琱琱琱琱銕艂銕艂銕銕琱銕琱艂銕銕艂銕艂琱琩琱艂琱艂銕銕艂銕銕艂艂琱艂琱琩琩銕艂銕銕艂琱琩銕艂菗葖琩葖琱艂銕菗琱琩葖琱艂琩琩琩艂琱琱菗銕葖葖琩銕葖鉽銕銕嶉嵷嵷葖艂搣嵷琲嵷嵷銕銕琱艂艂艂鉈銕銕銕鉽鉽瑹撖鉽銕鉽銕撖潃憡漇嵷嵷鉽鉽銕嵷銕銕銕潃銕鉽撖漵瑹銕蝭銕銕鉽潃銕撖憡銕鉽銕鉽鉽銕鉽銕鉽鉽嵷銕銕嶉嵷銕銕嵷銕銕蓱葖葖嵷銕銕嶉銕葖嶉銕嶉鉽銕銕嵷嵷嵷蓱銕艂嶉嶉雈搣雈雈搣嶉菇摁鄐晻雱滽璈蓱嵷鉽銕雱潃銕嶉銕滽葖嶉艂雱蓱銕嶉銕銕銕銕葖銕銕銕銕銕嵷艂琱銕銕嶉銕嶉雱琣雈雱琱搦琱雈葖銕雱銕雈雈琱葖琱嵷艂琣艂銕銕銕銕艂琱琣艂葖琱琣雈雈銕嶉銕嵷艂嶉嵷銕璈銕銕銕嵷雈琱雈雈嵷艂琣蓱雈雱琱琱銕艂琱琱雈銕銕銕艂雈琱雈艂艂嶉琩琱蓱艂銕琱搣艂琱雱琱雱雈搣琱琲雈琱蓱搦葖搣銕葖蓱銕搦銕艂艂嶉銕嵷艂蓱銕嵷銕搣嵷銕嵷鉽銕銕鉽甇銕銕鉽瑹銕銕銕鉽撖鉽嶉鉽銕鉽銕銕銕銕銕銕銕銕鉽銕銕銕銕銕銕銕銕銕嶉鉽銕鉽銕銕銕銕銕嵷銕瑹銕撖舕隢鉽銕銕銕銕鉽甇銕嶉銕鉽銕銕銕銕銕銕鉽鉽銕銕銕銕銕憡瑹銕銕銕銕嶉嶉潀嵷銕嵷搣撖嶉鉽鉽銕嵷嶉璈銕嶉嵷撖嶉葖艂鉽搦嶉蓱雱銕銕嶉銕銕銕嵷蓱菇銕銕銕嶉嵷雈銕銕銕銕銕銕銕銕嵷銕銕銕嵷銕艂葖搣蓱嶉葖蓱嵷艂雈嶉雈琣嵷艂艂銕銕銕銕銕銕銕銕銕銕艂琱艂銕嶉銕銕銕銕滮搣銕銕銕銕晼琱雈艂雈琱嵷琱嵷嵷嵷琱琱嵷銕蓱雱葖銕銕銕銕銕銕銕銕銕銕銕銕銕雈琣雱雈琣艂雈銕嶉艂琱琲蓱嵷嵷嵷雱雈琲撖撖銕葖銕嶉嵷銕銕嵷蓱嵷嶉銕嶉鉽嵷嵷銕瑹瑹銕鉽甇鉽鉽撖銊葖銕鉽撖銕撖蝭鉽鉽鉽銕銕銕銕鉽銕銕銕銕瑹銕嶉銕銕銕鉽銕銕瑹撖銕銕鉽鉽銕鉽瑹鉽銕銕瑹甇鉽舕銕銕銕銕銕銕銕銕銕鉽膌銕甇鉽銕銕銕銕銕鉽撖銕銕銕鉽憡撠銕嵷銕嵷鉽銎鄔搣搣蓱琱銕銕銕銕潃銕銕蓱蓱漼鉽嵷銕銕鉽葖蓱琲嵷葖嶉銕銕銕銕銕銕嵷銕銕銕葖銕艂嵷銕銕銕銕銕銕銕銕鉽銕銕銕嵷嶉銕蓱艂雱蓱銕嶉銕憒雱蓱嶉葖嵷蓱銕嶉銕琱嵷銕銕銕銕銕銕銕銕銕銕銕銕銕銕艂銕嵷銕銕銕銕嵷銕蓱嵷艂嵷嵷琱雈銕艂琱嵷艂銕銕蓱銕嵷嶉嵷銕銕銕銕銕銕銕銕銕銕艂艂艂艂嵷嵷艂搣雱銕嶉銕銕銕嵷瑹銕銕鉽撖嵷搣雱銕銕鉽銕嵷艂嶉嶉蓱鉽銕艂撖鉽銕銕銕銕敿銕銕鉽鉽蝳蓱鉽銕嶉鉽甇滽鉽瑹銕鉽銕銕銕銕銕銕銕鉽銕鉽銕甇銕銕銕鉽鉽銕甇銕銕銕銕銕銕銕銕鉽瑹鉽撖鉽瑹鉽鉽銕銕銕嵷銕鉽鉽銕甇嶉銕銕銕銕銕鉽銕銕銕鉽銕銕甇漇瑹銕銕銕艂銕蓱鄔嵷銕蓱艂銕銕銕嶉銕銕銕嶉銕撖漇銕嶉鉽銕嶉酯蓱葖艂嶉嶉嵷銕銕銕銕銕銕銕嶉銕嶉嵷嵷銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕嶉嶉銕銕銕銕鉽嵷雱銕銕銕銕銕銕銕嵷嵷銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕嶉嶉銕銕銕銕銕銕銕銕琱琱雈雈雈琱艂琱銕嵷嵷嵷銕銕銕嶉銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕鉽鉽鉽瑹銕銕撖瑹隢甇瑹鉽蝭撅葖銕鉽嶉搦晱雱嵷蓱雱嶉嶉嵷銕銕嶉鉽鉽瑹鉽鉽鉽鉽撖甇撅鉽嵾蝑銕銕漇鉽鉽撖鉽鉽鉽撖銕撖撖鉽鉽撖瘣鉽鉽撖瑹銕銕銕銕銕撖銕銕銕銕銕瑹嵷鉽銕撖撖撖撖鉽撖鉽鉽銕蝭瑹瑹甇鉽銕銕嵷嶉漇鉽蓱銕嶉銕銕銕嶉銕銕銕葖銕嵾滽銕銕嵷蓱膌鉽膌蓱銕銕銕嶉葖嶉蓱嶉嵷嵷銕嶉嶉嶉撅鉽鉽鉽銕蓱搣琣琣銕銕銕銕鉽鉽鉽銕銕嶉銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕鉽銕銕銕銕銕銕璈嵷銕銕銕嵷銕銕銕銕銕銕雈艂銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕嵷銕銕銕嵷銕銕雈銕艂艂艂雈艂銕銕嵷嶉嵷嶉嵷銕嶉銕銕銕鉽銕銕銕銕銕鉽瑹銕鉽銕銕銕鉽撖鉽瑹隢銕銕銕銕鉽銕銕銕撖銕葖琱晲搣搢萿摃犑艂潃嵺鄐嶀犍漇潃銕銕擳鉽鉽鉽銕瑼撖蝑鈺甇撖漇嶉蓱鉽銎嶉犑漇甇銕鉽瑹甇憡滽撖鉽嵷嶉甇瑹銕鉽鉽銕銕銕蝭鉽鉽憡嵷嶉艂嶉鄎鉽潃潃撅閫嶉銕銕銕銕銕銕鉽嵷鉽鉽潃嶊蓱蓱鉽嵷葖銕鉽葖嶉銕璈嶉銎蒡嶉嶉銕銕潃銕艂漇漇艂嶉潃漇摁銕犑蓱犑艂潀銕銕銕銕撖摮葹銕銊嶉琩嶉銕銕銕銕銕鉽撖銕潃銕銕銕銕嶉銕銕嵷銕銕銕銕銕銕鉽銕銕銕銕嵷銕銕銕銕銕銕銕銕璈蓱艂鉽銕鉽璈銕銕銕嵷憒嶉銕銕銕銕銕銕銕銕銕銕鉽銕銕嵷憒嶉銕艂嵷嵷嵷嵷銕銕雈銕艂嵷雱蓱艂雈嶉銕銕嵷艂銕銕銕銕銕銕銕鉽嶉漇銕銕瑹瑹銕銕銕銕銕銕銕鉽鉽銕鉽銕銕鉽銕銕嵷銕銕酮蓱菪嵷蓱葖銎滽靰葹蓱鉽滽鉽鉽銕撖漇鉽葖憡嶉漇銕漇鉽鉽嵷滽銕銕滽鉽嶉嵾潃撖嵷嶉鉽銕潃銕潃蝭鉽鉽撖甇鉽鉽銕撖銕銕葖銕漼銎鉽銕銕蓱漇銕銕鉽甇鉽甇鉽蝑鉽鉽銕鉽鉽銕嶉嶉銕鉽嶉潃滽隢嶉鉽鉽潃撖瑹葥嶉嶉鉽鉽鄑銎嶉鉽銕嶉葖酮犑搰嵷葖嶉蓱蓱搰搣葖琲葖潃鉽鉽嶉撖銕甇瘞撅蓱搦葖雱嶉銕嶉銕銕銕撖鉽銕銕銕嶉銕銕嵷銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕嵷嵷銕銕銕銕鉽銕銕銕銕嶉銕銕銕銕銕銕嶉銕銕銕鉽銕銕銕嵷銕銕銕銕銕銕銕銕雈艂琣艂琱艂嵷銕銕銕銕琩銕銕銕銕嶉銕銕銕銕銕銕銕銕銕銕銕銕嵷銕銕銕銕銕銕銕銕銕艂銕鉽銕銕銕銕銕銕銕搣銕銕銕嶉琱搢漇琲搣嵷葖葹搣嶉艂潃鉽嵾銕銕銕銕銕銕蓱銕銕銕鉽銕鉽潃鉽撖嶉瑹嶉鉽擳葖嶉銕蓱鉽銕銎蓱鉽銕撖銕銕銕鉽潃鉽銕鉽銕銕銕鉽銕銕葖蓱銕嵷嶉鉽銕鉽鉽銕鉽鉽撖銕銕鉽嵷嵷葖銕銕撖嶉鉽嶉搣鉽銕嶉蓱潃鉽憒鉽葖搣雱嶉蓱鉽銕嶉漇艂葖搌艂嶉葖嶉搣葥憭葖葖蓱蓱嵷銕酯嶉銕銕潃鉽滽葖菗雱搦嵷蓱琩葖葖銕銕銕嶉銕銕嶉嶉銕銕銕銕銕銕銕嶉銕銕銕銕銕嶉銕銕銕銕銕銕銕銕嶉嵷銕銕蓱銕銕銕銕銕銕嶉銕銕銕銕銕銕銕銕銕銕銕銕雱嵷銕銕銕鉽銕蓱琣琣琱雈雱艂嵷艂銕銕銕璈銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕銕嶉銕銕銕銕銕銕嵷銕嵷蓱銕銕搣艂菗嶉搣嶉蓱葖銕銕酯雈雱嶉葖銕嵷銕銕瘥豱嶊鉽銊憍霈貒豱霈黕貕豱豱豱赯赯篝嚜貒豱嚝薾貒穘諨豱豱豱豱豱敼豱銕甇賵蝎甇霈銊靚貒蝪謓豱貒貒憳膍瑹瑹賵甇潃蝎嶈隢銕潃撖鉽搦撗撖嶈甇鉈葖銕諯滽潃滽撖潃潃嵿潃酮蝎銕銕膍膋嶊嶈甇蝪銕甇鈰潃鉽憳撠鉽撖鉈鉽諯撗滽霈撖潃鉽鉈蒗鉈漇蓱艂艂葖銕膍憍甇鉽瘣撖隢甇銕嵷漇隢鉽甇鉽潃膌銕瑹鉽撖甇銕銕銕銕銕銕銕嵷銕銕艂銕銕銕銕嶉銕銕銕銕嵷嵷鉽銕銕銕銕銕銕銕銕銕嵷銕銕銕銕銕銕銕銕銕銕嶉艂琱琱嵷艂蓱銕銕銕銕鉽銕銕銕銕銕銕銕銕嵷嵷蓱銕銕銕銕銕嵷銕銕銕銕銕銕嶉銕銕銕嶉嶉銕銕銕銕銕雈雱銕銕蓱琣銕葖潃銕鉽銕銕撖鉽鉽鉽潃鉽銕銕撅潃篞噹m棷yox}wwn司]肚erf`PfT~ZFzb}YCfUxZE~ZFmYGt^iYurppp囮v囮玊s囮癡uphzgwbㄏjkzzv洬膠艇閒}儐膝妗妠妠ご繚噤Ш膳趕戚迭釣砠z~z~yvz{vp囮q迢f囮szys儔膜~舅|楚汃汃~zv{洠{洠棷埻{堔怗rttvrg]_uwwk﹄y癟u縣~yy{||wp膘縞楷z膘漸楨蕊賒楨隍z鼓蔗膘蔗蔑Е刓佴彖彖刓繪羶捚恉刐鬚佹匢匢匢岋捚媜媜痭Ｓ苤錧恃葶癪卸犐嵺鸇卷鄖鉽鄎銕鉽漅瘞醲唔膋獾村鄏鄔鷾阿漅潃銕銕銕蝎蝭鉽銕嶉蓱嶉舕膍膌膌鉽甇甇甇敼敼豱搦琲雱琱雈搣嶉蓱銕銕雈雱銕銕銕銕銕銕葖菗漇艂艂酯銕銕嶉蓱潃銕銕撖鉽銕潃儦mXE櫋<踒.璻3璾0璻3轈5饎?鄺7旝5饌A饎?櫧7曣:鐻H饋@饎?櫳<鐶H櫳<饎?饌A饎?櫧7櫧7鄺7璻3轈5璻3璾0璾0璾0璻3璾0璾0璾0璾0踓0轈5璾0璾0轈5璾0璾0璾0璻3轈5璾0璻3踒.匰2榎4劁0觡.觡.觡.踒.觡.9)9)劁02$>+>+>-匰2觡.劁0觡.觡.劁0劁0劁0觡.匰2劁0蕱8劁0踓0踓0熿5璾0璻3旝5璾0璾0踒.>+觡.觡.>+>+觡.愅/噞3觡.觡.璾0璻3踒.踒.轈5踒.璾0噞3踒.踓0劁0璾0燅3誫6誫6誫6誫6燅3燅3閵8閵8誫6誫6誫6誫6誫6榬0>+誫6墱8>+惲-聐2聐2誫6毧.浺1毧.毧.毧.毧.毧.毧.毧.毧.毧.毧.惲-毧.毧.毧.毧.毧.惲-惲-毧.惲-9(毧.毧.9(9(9(毧.>+>+9(9(乇39(9(劇-劇-9(9(澶2蚊.湟3膂8膂8膂8膂8膂8靦=膂8蚊.蚊.蚊.膂8湟3蚊.膂8膂8湟3膂8膂8靦=膂8枇8㎜9㎜9O8昤=㎜9枇8G4枇8C1G4袈:訪C吐箠J\B赯雈琱嶉搦銕銕嶉銕銕蓱艂嶉嶉葖銕銕葖蓱銕葖嶉嶉嵷嶉銕銕龢潃嵷鉽嶉潃鉽潃蠁ドF酄B饌A曣:櫳<饎?饎?櫳<櫳<曣:櫳<櫳<曣:曣:櫳<櫳<曣:曣:曣:曣:曣:曣:饎?曣:櫳<曣:璻3曣:曣:曣:曣:櫳<曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:櫳<曣:曣:櫳<曣:曣:曣:櫳<曣:曣:曣:櫳<曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:櫳<曣:曣:曣:曣:曣:櫳<櫳<曣:曣:曣:曣:閵8曣:櫳<曣:旝5閵8誫6燅3拯,窨4箊:涎0毧.誫6曣:曣:櫳<曣:曣:曣:饌A櫳<曣:饎?曣:櫳<櫳<曣:曣:曣:曣:曣:曣:曣:曣:曣:閵8曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:櫳<曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:櫳<曣:饎?曣:曣:曣:曣:曣:櫳<曣:曣:櫳<曣:饎?饎?曣:曣:櫳<曣:曣:曣:櫳<酆D酆D饌A饌A曣:饎?饎?饌A饎?櫳<曣:櫳<饌A饌A饌A饎?饎?饌A醹E酆D醹E瘟2曀搣艂搣琩嶉嵷蓱銕銕嵷嵷銕銕嵷嶉銕嶉嵷葖蓱琲琲嶉憒舕舕鉦鉽舕嶉蓱蓱撗搰鐙)饎?櫳<饎?騴C櫳<饙>櫳<饙>饎?櫳<櫳<饌A櫳<饋@酆D櫳<饌A曣:櫳<曣:曣:曣:饎?櫳<曣:櫳<曣:櫳<饎?曣:櫳<曣:曣:曣:櫳<醹E饌A饎?騴C曣:曣:曣:曣:櫳<曣:櫳<櫳<蕦<饎?櫳<櫳<饎?饎?饎?櫳<櫳<櫳<櫳<蕦<曣:饌A櫳<閵8曣:饎?曣:櫳<饎?櫳<饎?饎?饎?櫳<櫳<饎?饎?饎?曣:櫳<閵8誫6曣:曣:曣:曣:曣:櫳<蹭:P;佈2雔:瞋;櫳<櫧7櫳<櫳<櫳<曣:櫳<曣:曣:濣=饌A饌A酆D酆D饎?酆D櫳<曣:曣:曣:曣:櫳<櫳<曣:曣:曣:曣:櫳<饎?櫳<櫳<櫳<曣:饎?饎?曣:櫳<曣:曣:曣:櫳<曣:曣:曣:曣:曣:曣:曣:曣:曣:櫳<曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:櫳<饎?櫳<曣:曣:櫳<曣:櫳<饎?曣:曣:曣:曣:櫳<曣:櫳<曣:櫳<饎?櫳<曣:曣:曣:饎?饎?櫳<櫳<饌A饌A饎?饎?饎?酆D饌A饎?饎?饌A櫳<饎?櫳<酆D醹E酆D饌A醹E醹E酆D埕7紫菇蓱銕銕嶉嶉銕銕銕搣嵷蓱銕銕銕嶉葖銕琩靰犍雈搣雱嵷鉽瑹葖琩蓱搣琩摁銊z菀H饎?酆C饋@酆C饎?醹E酆D饌A櫳<饎?饌A饎?饎?饌A饌A醹E饌A酆D饎?饌A酆D饎?饎?饎?饎?櫳<饎?櫳<饎?饎?饎?饎?櫳<櫳<櫳<饙>饋@饌A櫳<酄B饌A饎?櫳<櫳<饎?饌A醹E醹E櫳<酆D饎?饌A櫳<饎?饎?饎?櫳<饎?酆C醹E酆D饎?饌A醹E醹E酆D酆D酆D酆D饎?櫳<曣:饌A饎?饌A櫳<櫳<曣:櫳<曣:櫳<饎?饌A曣:曣:饎?櫳<櫳<燡F涼/饎?象0窨4曣:曣:櫳<饙>饎?曣:櫳<饌A饎?饌A饎?饌A饌A饎?饎?酆C饌A饌A饎?饎?枳6|E)酆C饌A饎?饎?酆D酆D酆D饌A櫳<櫳<曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:櫳<櫳<曣:曣:曣:曣:櫳<曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:曣:櫳<曣:曣:櫳<饎?酆D饎?饎?饎?饌A饎?櫳<曣:饎?饎?饎?饌A酆D饎?饎?曣:櫳<饎?櫳<饎?櫳<酆D酆D酆D躒G酆D酆D醹E酆D饌A饎?饎?酆D饎?饌A酆D酆D饌A酆D酆D酆D酆D饌A酆D醹E躒G鷸K奸P瘜雈蓱搣銕嵷嶉銕銕銕銕銕銕銕鉽嶉銕銕艂艂蓱雱蓱嵷鉽葖雈嵷搣雱潀艂琭槧=.鑇O躒G躒G躒G酆C酄B饎?酆D酆C躒G醹E酆C醹E躒G躒G躒G躒G饋@醹F饋@酆C酆C醹E酆D鐻H醹E酆C醹E饌A酆D酆D酆C醹E饌A饌A饌A酆C饌A酆C酆D酆D醹E饌A饎?酆D酆D酆D躒G醹E酆D醹E饌A饌A酆D饌A饎?酆D饌A酆D饌A酆D醹E躒G躒G酆C醹E躗I鷸K躒G醹E躒G酆C醹E醹E酆D酆D酆D酆D饎?饎?饌A櫳<饎?饌A饌A酆D饎?饌A騴Cn(既3酇L9(醹E饎?饎?醹E饎?饌A饌A饓A躒G躒G躒G躒G醹E醹E躒G躗I酆D酆D躒G醹E酆C鄅DH3躒G躒G醹E躒G醹E醹E躗I酆D饋@饎?饌A饎?酆D饎?饌A饌A饌A櫳<櫳<櫳<曣:櫳<饌A饌A饎?曣:曣:櫳<饎?饎?曣:饎?饎?曣:櫳<櫳<櫳<饎?饌A櫳<饎?櫳<櫳<櫳<饎?櫳<饌A曣:櫳<櫳<饎?酆D饌A饎?饎?酆D饌A酆D酆D酆D饎?酆D酆D酆D酆D櫳<饌A饌A醹E酆D饌A酆D酆D醹E醹E躒G酆D醹E酆D躒G醹E酆D酆D酆D醹E躒G躒G躗I躗I鷸K躗I躗I躒G鷸K躒G鷸K鷶N蠼S罡D虡受雱搣銕銕嶉銕銕銕銕銕銕嵷銕銕銕銕嵷艂搣艂嶉艂艂嶉艂蓱搦銕嵷蓱豱轡PG4鱴Y鷸K鷶N轢L躗I躗I躒G躗I躒G鷸K鷶N鷸K鷶N鷸K鷸K鷶N鷸K鷦Q鷦Q鷸K躒G鷸K鷦Q鷦Q鷦Q鷢T躗I鷶N躗I鷸K鷸K躒G躗I躗I酆D酆D醹E酆D酆D酆D饌A酆D醹E躒G醹E酆D醹E醹E酆C酆D醹E躒G酆C醹E酆D醹E醹E躒G躒G醹E躗I躒G躗I鷸K醹E躗I躒G鷸K躗I鷸K躗I醹E鷸K躒G躒G躗I躒G躒G躒G躒G醹E躒G鐻H躒G醹E酆D躖J躒G醹E轢Lf泳Hz`<+鷶N躒G醹E躗I躒G醹E躒G轢L鷸K躗I鷶N躗I躗I鷶N轢L轢M躗I鷸K鷸K鷸K鷶N鷦Q，+鷶N鷸K鷸K鷸K鷸K躗I躗I鷸K鷸K躗I鷸K躗I鷸K鷸K鷸K躗I躒G躒G躒G躒G醹E躒G躒G躒G醹E醹E醹E酆D酆C酆D饌A饎?酆D酆D酆D饎?酆D饌A酆D酆D饌A酆D醹E躒G躒G酆D酆D躒G躒G酆D醹E酆D饌A饌A酆D饌A醹E醹E酆D饌A酆D酆D酆D躒G酆D酆D酆D酆D酆D躒G躒G醹E鷸K鷸K鷸K鷶N鷸K鷸K鷸K鷸K鷸K躗I躒G躗I鷸K躗I鷸K鷸K鷸K鷸K鷦Q鷶N鷸K鷸K鷶N鷸K鷢T釃W鷢TF5箹渝搯蓱銕銕嶉銕銕銕銕銕銕銕嶉銕銕嵷銕嶉艂雱銕銕嵷嶉蓱葖斢暺窙tP;i鷢T鷢T鑸Y鷦Q鷦Q鷢T鷸K鷦Q鷸K鷶N鷦Q鷦Q鷦Q鷢T蠼S鷶N鷦Q鷦Q鷶N鷦Q鷸K鷢T鷸K鷢T鷶N鷶N鷦Q鷸K鷸K鷢T鷸K鷦Q鷸K鷶N鷸K鷦Q轢L鷶N躗I鷶N轢L躗I鷸K鷦Q鷦Q鷦Q鷶N鷸K鷶N鷸K鷸K鷸K鷶N鷢T鷦Q鷢T鷶N鷶N鷸K鷶N鷸K鷶N鷦Q鷸K躗I鷶N鷦Q鷸K鷸K鷸K鷦Q鷸K鷸K鷶N鷶N鷦Q鷶N鷸K鷢T鷸K鷦Q鷶N鷶N躗I躗I鷸K躗I鷶N鷸K躗I鷶N㏄?滜E窮J鷸K躗I釃W]E鷶N鷦Q鷶O釃V鷶N鷶N鷦Q鷦Q鷦Q蠼S鷦Q鷦Q蠼S鷦Q鷦Q鷶N鷢T鱴]擾C鷢T鷢T釃W鷦Q鷢T鷦Q釃W釃W鷦Q鷢T鷶N鷸K鷦Q鷶N鷶N鷦Q鷶N鷦Q鷦Q鷦Q鷸K鷸K鷸K鷸K鷶N鷸K鷸K躒G鷸K躒G躒G躗I躗I鷸K鷸K鷸K躒G躗I鷸K鷸K鷸K鷸K鷸K鷸K鷸K鷸K鷶N鷶N鷸K鷸K鷸K鷸K鷸K躗I躒G躗I躗I躒G躒G躒G躒G躒G躒G躗I醹E躒G躒G鷸K躗I躗I鷸K躗I躗I鷸K鷸K鷶N鷦Q鷸K鷸K鷸K鷶N鷶N鷶N鷸K鷸K鷸K鷶N鷸K鷦Q鷶N鷶N鷦Q鷶N釃Vy]鑸Y鑸Y釃W鑸Y鑸XJ8暋篣雈蓱嵷銕銕銕銕銕銕銕銕艂蓱嵷葖嵷雱葖嶉葖銕嵾甇fe爹=煲Uc鸓^|`黲Zy]鑸Yy]釃V鷢T鷦Q鑸Y釃W鑸Y鑸Y鑸Yv[釃W鑸Yv[y]v[v[釃Vv[v[v[v[vZ鑸Y鑸Yv[釃V鷢T釃W釃Wv[釃W釃W鷢T鑸Y釃W釃V鷦Q鷢T釃W鑸Y鷢T鷢Tv[鼜\釃Vv[v[釃W鑸Y黲Zv[釃V蠼S釃W鷦Q釃V釃W釃W顩W黲Z饖Y顩X黲Z饖Y顩X黲Z霿U鑸Y釃V鑸Y顩W鷢T釃W鷦Q鷢T釃W鷦Q鷦Q鷢T釃W鷢T鷦Q釃V鷦Q釃V顩W鷦QS<洚^喏U鷦Q顩X蠼SvA*a鑈R鱴]~C0后D黲Z黲Z鑸Y鑸Y釃W黲Z釃W鶘\饖Y霨[饖Y鶘\瞢_YF釃W鼜\釃W釃W釃W釃W鷢T釃W釃W鑸X釃V釃V鷢T鷦Q鷢T釃W釃W釃W釃W釃W鷶N鷢T鷦Q鷢T鷦Q鷸K鷸K鷸K鷸K鷸K鷸K鷶N鷸K鷶N鷦Q鷸K鷶N鷶N鷶N鷸K鷸K鷸K鷶N鷸K鷦Q鷢T釃W釃W釃W鷢T鷦Q鷦Q釃W釃W釃W鷢T鷢T鷦Q鷶N鷦Q鷶N鷦Q鷶N鷦Q鷦Q鷸K釃W鷦Q鷢T鷢T鷢T鷶N釃W鷦Q鷢T釃V鑸Y釃W鷢T鷢T鷢T釃W鑸Y釃W鷦Q鷢T釃W鷦Q釃W釃V鑸Y鑸Yv[y]鑸Yv[v[y]|`|`d腛]洪X賑鍪昏嚜貕嶉嵷嵷嵷銕銕銕銕嵷銕銕撖嵷銕葖鉽撅銕黺kUw|`驏]鼶^baaaav[y]by]驏]鼜\y]|`|`v[y]y]|`d|`|`g|`|`dbb鼶^|`y]黲Zy]y]y]y]y]v[釃W黲Z顩W鱱]v[黲Y黲Z饖Y驏]驏]鼜\驏]_g鸓^|`a鸓^c|`驏]鸓^驏]|`|`|`鸓^c|`b|`ad驏]騽[驏]驏]鸓^礣Zav[饖Y饖Y黲Z鼜\y]饖Y騽[騽[饖Y驏]黲Z鼜\鑸Y騽[顩WT?z<,聵_齃a騽[|`柔Ae驏]eyOA緩_d|`bca驂]bcb^a驏]緬TS@b鸓^b|`bv[鼜\bad|`|`驏]y]|`鸓^v[v[v[黲Z|`v[v[v[鑸Y釃W釃W釃W鷢T釃W鷦Q釃W釃W釃W釃W釃W鷢T釃W鷦Q鷦Q鑸Yv[y]v[v[v[v[|`y]|`v[y]v[v[v[v[鑸Y鑸Y鑸Y鷢Tv[顩W釃W釃W鑸Y釃W鑸Yv[鑸Yy]y]v[y]v[|`|`y]鑸Y鑸Yv[鑸Y顩X黲Z鼜\|`y]y]y]v[y]|`|`|`bbfiloimrl忥a沱IㄆVxS攳嶉嵷艂銕銕銕鉽銕嶉銕嶉潃葖撅甇鉽鉽賵nVhijlljdhicfhfihdofdgfdjiigdddbjajbdadhiee鸓^baeaeba鼶^bbciiiffifh鶘\aee_cci__bcbfb^f_驂]鶘\驏]鸓^__霨[f鶘\a鶘\^鸓^^bdb瀋S掤Vfbb鼜\雹VsoslG6ㄏieeeefpfbif霦`愜M癥Tiiffdifdiccafii鸓^鸓^|`biadb|`|`y]b|`|`v[驏]y]|`鸓^|`鸓^鼜\y]|`鸓^by]|`bb|`b|`ay]y]bb|`bbbbdd驏]a驏]v[v[v[diddbbbbfb驏]a鸓^|`bb|`f鸓^dfbfddflojlrrvpvvqytu泡]窷琩葖嶉銕嵷銕鉽鉽嶉琩嶉鉽潃滽銕嶉蓱赯z`Q才pmoxvvwvussmpoquppvlswlmmpoliilooiolicimimooihllkiholoilrllskislolplolhkilloohkollblbbefliiekifhm`Oshgi_bkxWB沾Vgqfpooiiiieoy^uiiuilloloilroiifiiliifffbibdcffiilifbdddiiililidiidfiliiiiloiiiiliiiiiiiiioofddliififiiorpotqsssvmtwyxㄍ叻xy要S滽葖雱銕銕鉽鉽銕銕銕琩滽鄏搣搰葖蓱嶉豱|qQvwx{u』wuxqvx|x{wtwzywwstxyuqtxtutxvwx|tttxvvpmspqwpqsspwqxwㄍzxwtxptwuwxwtvwuprisxsmlhlorwpmsorsmsoE4nlprkcsvi{swqtpsqwvvst咳Wsjtjnwsmsvtspsvssvsrllomillileilllkooioiliilorllllloilvllooroporlmuilrrrlolrpuspxmxtorvrvsvvx并yx』x{y并▇N撅蓱艂銕銕銕銕鉽銕銕葖雱搦琲搣嶉搦嵷赯n^Hx﹚{|并并x』yㄍx并』ㄍ并yyㄍ|yㄍ』』』』』{y叻yy{vyx{xx』』ㄍyztvwㄍyxw﹚并』w{wxyㄍy并xxwuxyuwqvpnvxpsxtwsnvwztwtfI4}ptsjM;)j嵽vwsyxyxx`含Rwk{vxxwwxxxxx叻wywxxyxy』xyxwwxwxutppswssvwtswwsswwtvwtvwwxxvststvsqtwwxwxwwvqqwxxtqvsxtvpwxxy{﹚{叻』并并并并Y@撗嵷嶉嶉鉽鉽撖撅鉽銕葖雱琩琲琣雈雱雱篕{_I并ㄍㄍ良叻并并并并并并ㄍ并ㄍ并叻并并』▕y并』y』叻良z并』良ㄍ』叻并x﹚ㄍㄍ并并叻ㄍ』s{ㄍ{并yyzw\F年膃cW~qwfXy』ㄍw{slhz』』yyyy叻叻并叻并叻叻』ㄍ叻{q』』』xwyㄍyyywuwyyxxwxxwxx并』y{xxxwxxwxwyy』yywx』并叻叻ywqyx』并并叻叻叻并』并]F蒺銕搣蓱嵷銕撖撅撅鉽琩痐晼晼琱琲琩曊vcI并并良并四叻并并并并外并并讞鬤g顜齒痐~uwp{wXx擳h并并并并﹚并y』叻叻yv并叻叻叻并』y叻』叻并并并并叻叻x叻并并并叻叻』叻并并叻并毒^滽嶉艂琣銕鉽銕銕鉽銕藭堧琣琣琱雈晻篣gM8纂顳良馫C:5d鄎_Lyq鰣飌驦痋騋c貜蠿|ㄍ鞥|貜并叻并叻叻并xV鉈嶉雱嵷銕銕銕銕銕鉽琩琱琩雈雱賵oX鸝r]Cx^_@馫驦鬤馫顳ゝ鷅u躨t峆驦搷蒆l鉬菪z鸕鸕鸕鬤j諰yc驧顳顳q|e鱁籇}躩~lM撅銕嶉銕銕嶉銕銕嶉銕琩琩琱琱雈雱艂搣蝪~c欞鸕氻zYx讟fM恁鰡繻鰨鶶鸕驤驤驧驧鬤猀=4)萴nhcbN鰽秅|懘kqS钂鷞驦nY6悈}銢驦鬤鬤眱蚳~驤鬤飌顳飌驤|V瘣銕銕銕銕銕銕銕銕銕琩琱搣蓱艂嶉漇葥薶{[虌虌沬_yZ{_悁tZH~p[瓾爧馫虌齈鬤欞躨鬤鸕搧hwj鶡z鰣異~鰷鰶芊y鰤吽xnwp`驨齈钁欞欞荎|t鶼堜驦鷛m驧驦鰴鬤鸕{W瘣搣嵷銕銕銕銕搣銕銕葖銕滽撖鉽銕嶉撖貕z邿y`ZUK贗戇嵾瑍hXAy欞鬤鸗爧戇晜}撟鸕戇鬤q~f顴钀鼣_驩p颩ju嵹欞荇鷋鰶蒏t蝎驤鰲鸗}`]F狴怚鬤s撖琱琣琱嶉嶉銕銕嶉嶉葖蓱葹艂銕潃琣葖豱|^虌鰲虌晥e6)熒挬蛝嶉KH;Х虌欞鬤ui]r欞鸗鸗欞y欞虌艦|`XC躨{Z埱傍uz欞|s鷒鷒銝tP眽鸕虌r諯灪仍g鬤t瘣艂嶉銕葖銕嶉銕嶉搣琱雱潃嵾潃艂鉽搦豱|]欞鄔o齾耀o輕6)鸕躨鸗HH<懫鷜戇p珒r畦~搧鸕薑h瓴vS猺騇sq鷜鰽黧t曊齈漟菬黧驦鰷鸗r瘛銕蓱琱晱琩銕銕嶉葖琩漇漼嵷銕鉽葖潃貕xeO蚽虌晹壎|躨vr啈|{欞鷞鰶鸗帢`G4鶳棶_W@钀{霽鯇{g睎驨鄐虌鸗餺k龠w撋鰶搦驩鸗m瘣銕雱琱晼蓱銕鉽銕艂搣琲艂撖葖鉽蓱貒wgR蓐戇b堛僄~u^mLe\H虌鱹熂x爧欞u齞畯鷖sq拑u蚢鸗鶹陪鬩jx痑{戇鰶眹蝺欞洉c嵼鸗鸗n撖葖嵷艂嶉葖嶉銕嶉銕琱晱搰搣葖鉽嵾蒏敿nT廗鷜驩醲閎audU煚鞃o鵋钀驩pSr屪陝}躨芄n觓钁鸗欞vdD~蘛鷝ΠVM謰污囚ヾ}{v躨虌亄ils篚鷛騑謓漇鷒nO畯鸗l鈰銕蓱蓱銕鉽鉽銕銕銕堥晻犍搰腡甯犍痐隢tq\眭虌鬤钀褑jsov钀洁糽v虌抩}|k钀譨朴居{郺齈虌欞鷋虌蔆仵驨鷊儒瑱~Z爚隆mg荎虌钀牶rhP鶻漜臙啎ry爧臙艩鈺搨鰲戇i潃銕銕銕銕銕鉽銕蓱鉽艂晻琱琱搟琩艂蓱敿{n\靰鸗虌虌鷋欞钀驩堜|zj搛fWD埽cU=荂洘椌虌虌m芼j钂欞袗钁躨瑀欞欞虌yx驞lg堸顑}牉d飾鬮欞銴{譨﹁^藶戇l鷜餼x蘀k虌齈p潃嵷嶉銕銕銕銕銕嵷蓱醽晼琱琲搣琣琱蓱j眲鉠JD6塈劗悈夆鷖r襆lH}靰|^tae嶺u戇鸗鸗齈頧u齈齉茂J1芴橧zeN侚qiV钂蒧怳~钁諯si揭~眳窸戇葧茞钀a蝺銕銕銕銕銕銕嶉嶉銕魙堙琱晻雱蓱雱摰~a獉暀驩唌cuY岩興}eI甯u~byS鮶鸕か炟爧孺{k棶VRBooV怉ヲvwY=鷋钀椰}鈭堈vj晲vlS钁暀ve儽祂妢t蛅羲埣媔ぅ劙扑w榃菢搌}c豱嵷銕鉽銕銕銕鉽嵾鉽痐琣琣琩蓱琩滽^眹虌虌悢v揧憫幮傮ub簉B0#]I7~qa洃堭dXO眴洁s_Ioza驨戇禱縝虌鷐鶬鸝兡T=繩熆pヮ蓬╮h|鶱釩摀噢貼;1銧w鬅q鷐s戇睇{5+ loW?蔔~pVxXvTSF4KE.C@2DC/=;)<9+F>/D=*JE1z^{c壕y蚸}_儭銕鉽銕鉽銕銕銕嶉嶉晻晼晼琱琱雱琩潃n猻虋菢{nr[D--&鵗荷珥BB?朁瘝橭vmQw]FpmX穩蘄駘悼童w_Шu洌捄墨~戙n`EnQsrfr欞挬銡m搋q峇~b驩搵艨鷋v聹鷋抶laF0.PN?*+" +#BB6`ZFc_HJG2HJ8ocOgbJf`IgbJb\GCB*B?2b[E:9'=<,TT=-[P>}\膜f赯銕鉽銕葖嶉銕銕銕嶉菗葖葖嶉銕鉽嶉銕貒h悒誘f矇}jTtjUa唹黎q芛蒧pcU蓒mr篹`晥mcK晱瑄蛁|_颩蝏皉晱yrbwf橞qft楢mV櫸洫va葳怊AJ<撗踳雿峇{戇欞朁jybxaowxv}}]woUvsV{u]|^hfeigggegg}bx^{w\zt[}s\y`{w\{w\tkWqlQgbJidIf`I]U@VQ<<=.D@.媥z豱銕銕銕銕銕銕銕嶉搣琩撖撖撖銕潃鉽嶉憳t孍又J;犎怜蟟撟蒍劑稊涿G2邧~獂瓣~眹pT餑~n蛓咯c{j捁ㄤh芞JH;鼒膳芼嬼lwd趥w悛蝮睎x茖s棓e~Z]牶u鰶欞欞鷋驩~|nT +~dhh72!w_pzxuh{_kwwqmqqoojkjmjkj{`{`~u]x^vq[tkWtnTmhMmiPf`Ie]I('w蛁讔p豱銕葖葖嶉嶉嶉搣銕葖酮嵾嶉嶉銕鉽撖銕撖t驩啎鷩戔耨z\eeKl齉枉C3{ehf鬮萛~kS童m耨簾瑳v蠵椪vbk篨揖僉鵏拔m颭▏hWx硐}慱v^楊钂棸早w怮钂qi篔爧欞欞欞虌驩攁κX?  q}q><2yZkpД穢}郭zt{zyvvvvtslsrmij}az_w_vpXvpXojMfcIb]JXT.s]萓q賵嶉銕銕銕銕嶉銕銕嵷晻雱琩琩搣犑琱憍翰欞虌钀嚙歔tJ{钂僄钁唲p`M堮鶼麂tYk炩瓞蛈堙RD;aM;鯆葹閒鼛iV塈疆疏暆bP袺o鈺擢穩be鴢o蚰嗃尤艩躨欞欞篿u  +>:'xbK甝怓虌钀讟舅|RM:嚃tZ7:.`VD褑jdK7-'FB4懰熗ukU'!}pXt鈶埸z婼VO>zyД簾礙礙ДДД嶼鳩嶼嶼憬鳩艇|yytqmlg}e~u]umWumWqiTjdMgbJgbJf`I`\Af`Ih_KFA2;5(鉬苠a斢琣琩嶉銕葖銕銕銕撖琩琲琩琩搣琩琣艂鉈派r茤gGEA砥壖欞~驫虌}犗∥棓mF磎e牳銗興塈tO<棼昏漍iS蕩驨觖■m棪鬤陲觸i慡蓁y`s廾[h醐u峞{jQ7噱╞n戇戇欞鱺龢僋 HC984%-,$5-#頇捸痌篸m楚~酃|znfJQN@ytZ欒銨C?5揚篱牄釔蚨壏伉穢儒珗梣{埏拑拑讀|^ri閎Д伈ДДД鳩誧楠|zwyqomlg{`}s\soUtkWnhPleKkgPe[Ge]H^YFfXCVP=:7+vX猻`儦嶉艂艂銕鉽鉽鉽鉽鉽琱琩蓱雈雱琩搣搣蒗j椌躨撜wrg鬮Y?)Ё钀堌qT啎z鍑角ilx僄鸙之l鳦{lT郱钃o咧牉蟘hJ縌﹛n麂dD}醢u~茪{n漡j{e恁鬮欞钃rTQE8OG9YK;m_J\Q=l?7,95'PF3_XBZN7ZK7UL7A8(ZR@F@.QK>SL>'k皉z豱銕銕鉽撖甇鉽撅撖撖琱琩晱晻琲甈rv`塈z磎懦s蟼酒eK痐ZXP簷痡mu椑d鷘雈iaN縑痋蟈g]Qr搧鸙nzby`甡p`Y飾of藶k曊?*no}棫{扆鷒n[D    +     + +  -) 44)77,47(11#') +0 76'<<214$%((()-"  -)藦血輶埭x斒傺煻斒z媥睄珚舅~埏珗牁禱hs憧誘艇楠滯xwythee}vZ{w\uqUrlPpjPqiTjgJjhMe`Ee[G`[CFH7[O:橪犬r貒銕銕銕銕銕撅瘣蝭銕琱晼晼琱晻晼琩琱慦ur[靰劓TTM荅暙じ驨睊夾洃h挹憬z}y鄋ve靇爧鰼妖褗蠯秀iUo钂ヮ{{]甗津{a嶸r茠~hc珓惇癟噙u誘r繹}g鬮RM; +  + +  + +    !!+-;B0KK;KKAKSBHK= # +    + r攩tX篰駍煻祤煻駜鳩虒駜暵旓慾}仵珝睇珗贗儐伈簾ン簾憧漲z{zwrkhge{w\vpXliJleKjgJheKf`Ie]H_Z@^XC43%釦茪w豱銕銕銕銕鉽鉽撅甇潃琣琩琱琱琣琣雱銊u{f甯爧洘奲髂囃椪h]H@竣r钀瑀aTE晼|b瑑抭^w槤捲帆n蚰y葴ХweQ熐p壓|u巑董菢k鼓倇筍c恌陣bQ鵱眶cvusS觷爧cR>    +   +       +     +i憀駜鵊﹉ya輮駜駜駜駜煻駜駜萷萷袘珗牁拑Д牁牁拑Д簾憬艇楠|間~|wqe}dxbzqYqiRpfQjdMf`Ic_H^XCVU=ZWC8:(}c覹r豱銕銕銕鉽鉽嶉銕艂嶉琩晻琱晻琣琣琲琲擃t|b摁d3'醺8"羃琣sOWRC敊紜狟o帣琠^\O漜楅^飺撟fJ鈶~k蓎w鉈熀|c剸m麤hN儠g|q_虷笢 豱s釓zaL頨礿p  +      +  +          + +    +   q蝥;;.赫鵛亥駎駜簁駜駜駜駜暵暵暵萷斒敯袘埏袘珗牁伈Д礙鳩艇|yyvofedu\xpXumWkfNgbJe[GZWCWWCZWCSS?I=3媥j豱嶉銕銕銕銕嶉搦搦琱琱琣堧琩琣搢琲雱蝪u{f漜酮/"趥柦@焠F寘6綦`暀媯wpY漎mbI亹{npX婻犬鉒sR欞銝|is活u蝏wb|獉嶼ぃz蚨埴埸噾｜IB葬轕貶TOV`UwaM苀{`橭w晥欞悝p +                   +  +    +       snXu\u暆j?7%略phT灉仰荎傺駜駜暵煻煻暵暵熆萷敯袘珗拑ДД艇|間~{zyvrjfg}bsoUmhMe[Ge[GheK^YFaZFYS=`[CGC1t盓s豱銕銕嶉銕銕嶉菗搦琲琱琣琣琱琩琲琣琩斢wye靰躨狺@-狑Lw粁5萉[=+蒟ぁ|~g倢份蓇A/捸钀峎|{g凗{苠u皒alS秺嬤恲fv漞x茈阰驫犬酯bK:蛬挬n漱薊埢犕dm_霾F?4^[L敶鷑齠欞齠穸yc +  +       +    +     +  +   +            QO<馽棄鄳dj:0#擿匣M=妏蟴鯙卓唌糒駜駜駜暵駜暵煻袟珚ДД嶼嶼簾嶼部{ytmljey`tnSpfQkfNheKheKecFc[CZV@d^DJ@0wtV菢y豱銕嶉銕銕嶉雱銕葖葖堧堧雱靰搌葖葖蓱韏e嵼雱湨/飥;鰝瘼Z@-=+唌虌啈hfYPSBC;.洁麷z蝡v趧q慁旍st惘~{pf挩oX斲|Y陝z誑婸:5)棐衪离襲袓鈭knxo`憎qgZ鉊今p鬮躨欞鷋鷋鷋鷋戇鷖v              + + +              +    (( 豝峰dL階駓巘佐蛌oT衖蠁∮蠁嚁駜駜駜駜煻鉧萷萷睄牁拑ДД簾礙ン鳩楠{tqiiecvpWmiPmhMheKjgJgbJ[XFb\G_\JQO;b\B萓w豱嶉銕銕銕嵷銕銕銕銕琱蓱琩搣搰酯葖蓱敿}b銩躨钀堜4&舋>)jt8(蚺怍洏蝜虌鶹v}蛁g貒楛趙瑋礙l{e{g懰{Y眭戔麚懪d{dyv黭←轡u縉黰|畽.(!:5-櫅齟mP晹钀欞戇欞鷋鷋蘌r    +  +   +  +     +  +    +      +          + + +  蟒攃旺唌葋灄ｎ捸菢J>(漹藸蟣蠁鯄篰駜駜暵暵斒袘睇埏珗珗Д嶼嶼憧艇|ywtmfez`~u]wt\rmWf`IhfMf`I^XC]ZCXXFTS>gYC縪妤y賵銕銕銕艂菗雱菗琩菗甯搰葖嶉葖嶉潃漇敼^漜猼0"f焟He趏J=,驩讟飫t鬅xfjW<撗滲e蒯kW僕爩郈祫叔k慒p憍~jeO睆v]埴耨uX嶸鷞nN攦縪砥z橧钀虌爧欞麶t   +     +    +        +     +  +  +   + +             嵹eXBt鱧ｃ恁壧ｌ唌譧↑唌譧↑唌鎡篰嚁駜駜熏煻煻睄桯珔拑拑嶼簾憧~yyqqc}de{cvpXnhQkfNkgPhgPe]HaZF^XCd^DUQf`Ir鉈銕銕銕嶉銕雱葖搦搦琱雱雈嶉嶉潃嶉葖鉈q葖搌咮0=,瞨{~偁B:)藽钀钀遶鶹钃g晜狳}dH晜z聾yn堿竄褗良b塈鄋僊楅  褎虒n篽s漞x磌央sZq銧躨鷋欞钀钃q           +    +     +     + +             +     + :=,醏梅捸琣晼犍譧↓蛂鯜藸懭鯜懭暵暵暵駜煻煻暵搡睆埏拑ДД縝誧}zwsskj{`|qZskSmhMe[Gb\G^ZBaZFt敼銕銕銕銕葖銕嶉嵷琩琩靰雈蓱銕酯葖搣撖s堨鬮搌<+諨妵7炂D猘K=+齝蚺b掅漈n黦X鯞埡vX钀唌}_暰菇zl捃ΤQ@}xb臗}v_w`rn晲wx\J傺钁虌~           + + + +          +   +   &#痽茗鄔蛂琱晼蛂鱧ｌ唌藸藸藸嚁篰輶駜暵暵暵暵駜斒斒袘珗伈伈Д憬間~{vqllc{bxvZpjPkfIkgPe]Hf`It鉈搦葖銕撖銕鉽搦銕葖琩蓱琣蓱琣搦雈蓱鈰y黰驩摁鹽16(r顝<,=+醢cuubHu壓|蘆hK戫wTm蠙洈~笴拒屹t蚸~[氿%蚽d骳A:0熉F;.ft迉黰說    +                  +      さ滽琱琱鱣鱣譧↑唌龒↙堧齎譧♂駜駜駜駜輮煻煻煻萷珗珗珚伈羲艇楠{yrofcy`unZskSkhSkgPf`Io酮艂銕銕銕銕葖雈葖雱琩晻晱堧搣琲搣琩葖舅|幮鬮菪阢9姤Qu滐N汫=7&蟫钀驨M:$隆都芠洠穸敯|蚚^l鶬艩曀蟢葙t觷蒺搵--&虭１rpU<1馴鼫蟤o都}瘞v^J漹爩馱             +  + +      + + 揭鷾似堙蛂堧蛂晼堨驞譧♁譧㏑駜駜暵駜駜暵駜萷斒睄珗拑伈鳩艇|}rqmcy`}tZvpXojMlfLv鉈鉽撖嶉銕銕銕鉽銕搣琱晱搣琩琩琱琩蓱韁蒧爩钀欞讟h洖Ik趒Q荁])蠸~f鍤埃C,穖n[餈贏nge\葙rZ豱鰽豱砷U灪ｑqV嚽鱺lSzaヮkbUmv#&!ン~鬋廙鸝c猀钀鷑鷵嬪$# !         +     }鄎琣蛂琱鱧ｔ琱鱣韥譧↑唌鯜鎡鎡譧㏒駜駜暵暵暵萷暆袘炩伈簾憬楠|zysm}dx^vpXwsYrlTm鈰嶉鉽撖銕鉽鉽鉽銕銕晻晻晻琣搰搣琩潃憀餑躨躨悀偑I=.--}朁vW艙m魌va靮x\砦嬪{v轕收loa藢rU痑u灩袹-#槾:0!q抩"均9鍜造rafra囮}薯鸕鷐钂屨 #%   !#     ]]I罃唉琣琣雈雱琣琣堧堧龒↑唌譧☉懰篰蹁糒駜駜駜駜暵煻斒珚袘拑簧誧滯zxqmg{a~u]xrWx鉈銕銕鉽銕鉽鉽銕鉽銕晼晹琲菪搌蓱搣矬祤钀驩蚽嶍幓爩伝yvp棷蠗覺nP翮孇hUB挶鶭鯠{驨穸}掑伒煚蔑峇縤痀兇芚! fZDr戙鶳Ｌs鷘虌齞劗簫! $"'%))""!#! # &"$"$"!   ""$#$#$"$"#"   # &#$#=8-鵩瑩琣搦琲雈靇譧↑唌譧↑唌譪譧↑懭輶駜駜駜駜煻煻斒睄斒袘伈Д嶼}{wqmg{b~u]w滽銕銕銕銕鉽銕鉽撅嵷晻琩琩嵾琩琣雱捔媢虌钁掑?4靾葷y鶺灩袸}_廕y|瘐痐篹驨齈n縢臣嶉qUTO>RP<{瑄kpbO{qRs儤龠蚋汕泖虌鷐齫癡 +&#$&#%(')))* ,*!)),*))))))'%'%%&('$"))('&#'%!('%$&"&#  '%(')))0")*"))('..&'%('&#$## ('$#$#$&$#('))$#""%%! #!94*玁緒琣搦琣琱琱琱漅蒤蓱鸁份煚攩仲掑藟ｊ藸藑ｊ掅藑ｊ苠懭篟旓埏伈伈憬鳩楠wxtlhjx鉈嶉葖鉽銕銕鉽瘣撖撖晼琲琱琱琣琩琩艂繒瓴躨搹XE7坁|}撅s轀kT藪p鞀q郭t漞钁騞龒uY暷k楷|t +m礙堈j89+ukW嵼爩t鷜騞劗t '%'%,)++,*!/*)),+/*,+63"))&#(''%))%(('(''%,,))(''%'%$#'%$#(' &('('%&/*('('+',))))))))))))),)))'%$#))))'%)))) #!))))'%,)'%('('%% " ! !(),?:-箹荷犌琱菗琣搌fJJ854&URHUSAWPA[T?ebKtjTpfPYS@f^M_ZEojRtpUkfO旓睄拑ДД嶼間~yyqni童z撖銕銕撖銕撖鉽撅撖撖堧琩雈琲琩雈菪琩嵷漁蒢ssc埬hG顫~^k儱踳l妐おok抾齫尖V:輵舨珧E=3睟漍嚜嬤鄶98.u]Iv繩冀硐鷘钀钂怜,*,*)*",),*00!-3$3.!0/,,,)/*,)('0- ))('/+))--",*00!),('$#))))('('('(')))))-"))00!30",,35#0- ),,*!0/0-!))))0-#,*,*,))))),)()%% 0- 36#,- 40")-"))(',,)*")* ,,)*",+,,)/ %%,.(+*'梤兆嶊琣琱撗JC9(% 12#98)?>0JGOM5?I5,+"韍睄埏伈Д簾誧間~ytno滽銕銕鉽銕蝭撅撅蝭鉽琩搰搣雈葖撅潃舕漇贗朣驨讟钀钀菢t﹛琅al瓞陔6- 褗呏hT亹莠奱邪ly屩陸q搚 駋倍鷎46*4(蒠z怌暾鷑钁颭23$3.!00!-0!,/02!33"74$63"63"87'3-!33"3+ 0-#0/0- ))0- 33#71#3-!87'30"--"00"))+(0+",*/*00 ,*,+)* -.$58*87'63"74$27(98)02!87'74$/-33#57'27(40"44%54(6- 0/33#87' 43#98)98)68*98,10#30"22(52'74$57'22(98)16%:=174&87':9,33#%"熊滽堧蝟VN;43+68,10(83(52)76*64';;,88)FF6ZSCVR@RR=SO=_\GPI3螫篘斒埏牁Д簾憬}zyt竣甇葖璈潃撖撖瘣鉽蝭撖琱晻漇撖撖蓱銕嶉潃憐|藱钀驨醐7,茈蚥_^U~b袚荌嵿P\Q鹺鷎筆~搦摀眥~hM鯬翅墨L4#佌捖b^I熉p芶奰僭踰v葧霅uo\*)68,76%74$74$%$00!44%3.!98)98)87'98)76%76#76#3-:6&84&40"74$54&6+63"60!0+"/*0-!),3+ 30"3-60!6- 71#3-!30 63":9,:9,54(84&?<+98)98)57'76%:9,98)87'87'98)87'D@->;)98)<:+>=-,.:9.98)98):9.<;.?=-?=-;:)?8+;9'<:+;9'><+;:+?>2<:+57'98):9,98) 劓鸀j770CC6HG8JI:FE6EG8KK>JI:LL9LLb[Eb]JIE5煻睄埏牁ДДワ艇{z竅甇銕鉽銕瘣瘣鉽撖銕甇撖蓱嵷鉽鉽鉽銕鉽撖躑讟蚺lrcR銌欑婦晲g祤ルMJ>嬼鸙坅v恣钀晛搥dX?鉥zi[>蛣蝶{jP隞虡牒MI2縼蟟|n晙洃欉鴨gN&'&(79'87';:+?=-;:+:9,54%<>/<:+DB1<:+;9'?<+?=-A?-?>0A?-FD1AC1>;)87':9,63"98);:)87'76%76#87'98)87'98)98)?=-A@2<;.?>0>;)A>+?>0<:+DC4A?/DB1HG8<;.CB176*DB1A@2FC/A?-A@2HG5DC4FE6JG:JG:87(?A/CB1CB4DC4FD3FE6FE6HG8JG7OOD1EE8JI:HG8JG:LIXUCUUC]^J_\GhfMgdO670袓暵斒埏埏埏伈嶼誧}憫甇鉽鉽銕瘣瘣瘣銕鉽撖菗嵷鉽撖銕撖撖嶉鉽{麜縔唇6#靚摁E;+蝐sU嶼鷝虒{x[m傱蓮k敯譝∥餔GKD疻梡晥z\痽昌蒗篕CE6餑QMC畟voZ灪{賵u灪考qdN+.%d`L2/!VR:A>+FH3JG7HE8D@-AB.CB1=:+@<.=;'==-?>+LG6FE3HE8FC3JG7JI7HE3FB1CB/A>+A?-?<+?=-?=-?=0AB.D@-FC3FB1A?-A?-AC3HE5FB1HE3JI5FC3FD1JG7HG8JI7OO>NN;LK9LI7:8'EA/NN;QP9LK7MI7JG:NN9NL;QQ>QP;OM?72'LIUUCVQE[XFWWCWWC`^HaZFYX@\XGWV@[XFTQCQN@SXJ-2&8;+GJ9JG;GJ8CE4FE6EG8NRAPM=TQCUUCZWCXXF[YDYXDUUCXXF_]J_\GQQ>21(埼暵萷埏袘拑拑簾嬤丳諯銕撖撅撅撖鉽銕鉽鉽銕鉽葖鉽銕撖鉽鉽撖y钀qn牶`M:蹁眲r\K撌噙aTHv鶬窱縉癡wPZQA恣踾埴FE4鉦褋搧#"鷿榭g\惇|m`痧}煻挩wa1/"NF5wo\fbN8+!UPBWV@C@+LK9JI:LI7JI:HF1JG5QI6JI7JH5OL6OK7SP:JG:JI7LK9QQLLUUCNN9QQQN8NK;WWCUUCVU=UQ=WTE92+瓴熆睄袘埏伈拑ン芚甇撖撅銕銕銕銕銕蓱嶉葖蓱銕嶉鉽潃銕葖潃y鶬玃>9(摀^e萛間幙 +縻窖i睇峇蟘吋K?yOL@鵏&(棼△踶鮽魊scOeWG飧_PAi馳I?,TE1DG8dX:a^Gb_G/, b\I=;)WWCOO>SR=]WAY[ITT@HC5UUCKE6JH3SR;ON:RPAWV@FD2JJ;TS>TS>WWCUUCQP;NN9QP;QP;VU=SR;QP;VR@VR@VU=WWCSR;TT@VT;TT@^XCWWC^XCWV@TT@VU=WV@XXFWWC]^JHD3\[I\XGCB2HE8\YJaZF[XF[XF\[IXXFWWC[ZDb\GgbJUP:gdO_^H_\Jc`Kf`IkiVkhSkhSniSqjVqjVqjVhiVnjVc`NNJ8]V>olWhgPjeOfaKjfRgeRTVD21!EE6IILLTQ=[ZDWV@TT@XXFWWCTT@WTEZWCGF3祫煻旓袟斒伈坒迮撖鉽撖撖銕鉽銕銕嶉嶉銕銕蓱嶉鉽鉽鉽銕滽v讟驩爩驨~f囿{QK8馦伅 徽g縼銌鸙齝堋v 痑鼖s媟繪v晛ua?瑵寫dTrr`+%zpVBD&嬤ZZCroRnfQH@)hdIf`IiaKe]Hb[ESO8f`I_WBgbJaZFRM=ZWBJE2jdOON:SQ?ddQLK:_\GVU=JF2gbJ`_K_Z@XXF^XCWV@]WA^XC[XFXXFWWCWV@[XF^XC[XFZWC^XC^YFf`Ie[Ge]HjdOb]Je]HhfMf`IkgPNN;c_HieL/.!WS@lfLidIkfNhgPhgPhfMgbJSP;njVhiV]ZDa[FniSniSkhSnjVqjVtkWniStkWvpXwt\xvZsoUxw\HM>GD5cfPtkWvq[xw\wt\vpXrmWqjVmiS;;.VXGJI7GE:HF5DC4KN;RRALLXXFXXFXXF``NnjU椊輶駜睄珗袘抾撖銕嶉銕嶉銕葖搦銕琲琱晻雈艂搣搦葖漇鉈ぎ讟钀钁遶#橁昏攽BB?芞}sbK蹓銩え鱹掑{\銝暙滲xgR褅蟜y`Ёes2=1sdW&)mfLrfUIC/f`U;5-_VCt`HE;~w__[FrlTFB0ijSjdMg_JspXrmWniS^[FjlTmgSQQ>miPgeR\ZHjeOabNYUCdbLedMgcLgdOedSb^FheKf`Id_Lc_HgcLgbRNJ:ON<_]EfbNkiVhhShfMkgPhgPhfMgbJniSpgTkfNniSjiPtoW''cZGojQYWE1)qpYrmWqmTtnTskSqnWZXJgbNrpUqjVc`Jg`GvpXvq[zt[umWspXumWzr`~zay`zcx^}z^|yab`JOP=khR}dzby`}c|e~{cxybwsY|fHF4NN;OO@=/QUCKN;LL9TT@XXFQS>PM?VS=b\GlkTZO<葒紛葺斒睄阭甇蓱葖菗蓱搣蓱琲嶉艂晻雱蓱嶉嶉蓱琣蝝t鬮悢vgo堿7:8鈲kzwdue擿轡蒆爩蠗|敯cVHgB}瓴矩o^懰nj[zxdOO4?C4)ba\D<-HG8JJ@?-?<,GJ8NK;PM=QP9WTEQS>UUC\[Ib\GiaM_\GFH8螳萷斒睍滽葖嶉嶉雱琲搣搣葖嶉鼱晻琣雈琣搦雱雱嶊v葹虌蝜%)(鸅儉痦XXCf鶻{tJ8穔摮媢洷茩駎_XI{{n[言adLG>:$$dYI^\HOI7DG8BB?wmXmcMt\_[KiaFvu^G=-~kxs[~}fe|by>=/jslXjfMqnTzb~fxybwt\xvZvpXxybwt\rnZvpXxw\wt\wsYxw\{x^unZvpXxvZ{zaxx_mfRxybumWunZ_]Eyt`y`xvZxvZ{za}s\~u]{cxx_}by`y`gy`|ewp]a`MjybPM;li{bii\YKGE1jYVE[Q>zaxbnlljlpjgjnkSfdKllldOdaR~crpplrqlmmjrVUBML:XXFGD8JI7HG898,ED4OL>QO@JH5b]JWWCXXFXXF\[GddQ_^HWT@RPURAON:LK9KJ:Z\K_XC蠁煻矇撖嶉嶉葖鉽漇龘琩琩琩雱琩艂艂銕蓱貒}\廗钀漡$縪杉zLH=s 遻祉峊lm釂揤晸秀VAbV7~y`#JH7RI3C@(:@2_SHUM6[bQ g_HMH4kmgU_R,xoyrrtsyopxtmkUnfR}|eB<.^XEneQxruxvqsppwyxmcQ33&?;*LI>A>1HG8EE8LJ<20!87(PRCRRAWWCSR;MN===-=;+?>-[XFBE4cZG縓希隢銕銕銕銕銕琣搣琩琩雱搣琲琣艂雱琩諯yb衚芋bbW虌痧*&" 慴仇iC暯u[L?[VBecXh^Gj<9*#BD;A;3襯#!IC1pZSCo.&y^rpeTkcIr}eq~k}e}lYN1u|u`ZEuoml|eoojRh{donUljniSoolp|fhpv|s]oyerottzrruwqwulvxwtwkx;7(}|\[A]YJqlUgqRQ>njUoyw]GE4zlVQ;s|wmrrZND3nurON;vYw{cRQEur`{uutuzsqvw{agnuxc,)KJ8CB154%CC6ED6HE8HG8JI:WWCSR;LK9UUCB>.CB4NM=OOAQP;B:*k蠔瑹潃銕銕銕銕搣菗琲雱艂菇搣蓱菇雱葖嵷豱|^篹嵿$鵗蛣苺堭鸗繳wd握wn]-'|n^xoV:5#{WQA[ZCs# 87,heJw[,-! ZTCriTmb]G}sa^\FWUAc[EqpgRmpmmgQpkQi|xdjeOkppnm~{cmt{xclgjmoktpprrqWw}itr]vytbkun\vnnntoqptpqrnyb`Pzg_^HXXJ~uaRN:dbJnhRwkfOqnQskVswHH8d|ldR|az`yySQ?{ugmuxNP=~fxvq\7;0VSAwwXR>zu_vzq{vZvoZ{D?+wq[xt`r|jOP@JI:@?/QUCGG:II888'NKB?<-ML:QN;RRAMN=>;-A?/JG:JI7XUCOL8z艂琲嵷嶉嶉琩琲琲琲菗琩潃撖蓱鉽嵷漇鉽穘l銋躨蚼qphP麷珓椊俞OA87,UPD秸約祂荎蚺痼豕73)roY^T-}y]rmeMru_jihi}d}eo}y]oljipnvplnnislsoWkpieIenxfdQrpniqgeR~hhyu_|wclllrnnlijprk|i\YFxub41$46%my|ybxv_qmQnjNZUAu^xq{[\F}zf_\ILJ5nx`ZG@C6ifQjoURB=<)洽96)^\GptjhQrkRzrS|cwtahdPUQ?~u_H@,xvuxvuh<<1,- HG8DG8EE7EE88;+1/CB6BB4LL<=<+54(=<0HE:98)TOCXUAu蓱琱雱雱雈搣搣蓱琩琣堧搦潃嵷銕葖嶉潃蝎m銈钀鬮钂猺囋^H6息猻麶戇鷟晸+鍭梡瑂籀f`M=>0VWCYWC\YE?>/xoXo|bKG5wiPynT qiOolSYU>NL7谷g\B悍:7'xrYh^JZTQecWMK=SN> KK:艘FK@lfRq~}dh_E~eqn{e{pxlXoox{enne^Jtb}holWk{derljkijtqvkv\sulaIwjpsss}e~xdprqsnllpr~~jCC-tpZrmV;8.D?/"$xydCB2sm]}f|BA4|fypY|oXikkV|v]je~akkkVt|eprYwkU_cR\[IstrZ`aKKN7edQk{hTTDqiXh_R3/$b[EwoZYQ<揮xrtuwtuuu|99.KJ:?>.<<.,//.!GG:?>/BD4GG;9,z蓱雱琩琲嵷菪搹銕葖雈琩雱銕鉽銕葖蓱艂憳r搷葥搊si^**$JE5\WE7A0/0$~f暊啥荎皉^("靚斲hB:89=3a[ETZDOH8AB4YS@WO0xg??,yd`PitTWCKM0CC6PNE:7(@?/SQ?v酮琣琱琱菗葖蓱銕蓱蓱銕嵷嶉鉽銕銕鉽葖敼ㄑw畯虌虌棓鵱坏{-,$FG9OF:XUDII=-77.<;.:9.,+ -.&87';:+>=066'RRA_\Jv蓱蓱蓱雈琩蓱嵷銕嵷銕琩蓱鉽銕銕嶉銕搦漅f銇鬮葥嵿蚘ㄆhPx_遘岏橪鉈嵿銈葖譧孍∥苠蒴轕效YK?*+67'LI9HD1LI;-LIML:KJ8LG6JG9ND8JI;wbO& NL=[YD74$GD3kiUebPxq[xu`qnQxu]MF0nWh~\郊ifxoa()$s狊-+!洮pD=/~dzMF4芡KL=vukPtokOtsp[rwjz]ttjhbJzdvnW}e~hlnyw`qlyqhpttzbkpruoYvt_mjUcu{cqdynpmisrpux\lnroWkeMpkxxr}eIG1b_KXZInhUb`Qy87(B@/GF3=9,}i{b{awv`spX~hfeRa`K<9*|ydTU?vpUoNM>ZUDE=*RL;`[FSP=tq\erKI8toZneHcbKqjSvunryxxiuxv`n{wup}{_zp]rf>:/;;.00!NM=@?/BD199)::.76)22(10#63$SNBUQ<滽嶉銕嵷嵷葖銕銕撖撖琩嵷撖銕撖嶉銕銕甇fh^刓輲搢銡搣蒱鉣SJ;92$##==2@@2//'(( #/+96,9:*+"&3,"kWI蜳渝犗雰捸茛艅皛袽vYHD4&%/6+MPBJI:MK@KI;EE3?B3MG7CB6A@2LK9LI7PP?DD4oaC蛚~auhzfJ9:+;5'A@4LE0EF5f\GZO;qqUybybkkmrgU>ry[WA |[R9hdQ馳ZXP韁zc劓飪zzdoxiXVE}egozfIK<}n~sy{rj|wu^wgzrytlptrm}dlrpsrpt}hn|v_{bnmkpjus}yapuurreppj[U>WO0zx`*0[YGWVFnp]e`NfdMjwxcc`KD@,21$sp_^XCTR>~eVVI~xguoYuleQlkT{wa~|d41$PP>g\Hi##skWokToqyy`mcJqqlyuY|c~|iiieQrlX|rpxqorKK563";:+;:.55'@>4>>465%MM=87*GF7NN;KJ:{撖鉽銕銕嶉銕鉽瘣鉽鉽琩搣葖蓱蓱艂雈蓱mzthlpa|nS|mSv瑲幙瑑瑀嬲wzcOH9 /.&690HM8JI7JG:NI>JG:ED8C@1GE8A>4BA/EE8<:+@=-?>0<<4$$/-wjSx]xwXp{lW2-!,+EC:RRAPPGJH7HG8PI@LK9MJ:II>HH4PH8-<6eaL50!FE;ROA=?2颩}峏j峎q|`QgXN=oua}w_x\n}^]U?~tYwiTj}b~eq悵~l{_vkS褸rmXUG屆fv~d}d`NKK?DJ:じ}`zx^zdx~twxxsmJK9tlwu`}zatieO{yoXljQlxfzw^nopom]~yb}f|jp{elosmtk{{waspjtxz_p|cn{v`jyVPAh{ritpw~ya@C1?>0UVB%$!v.-pTQ@^ZG``LgfSOG8tp[tr]e_HPO?AA2yw`VT@{xcDE6OS@lkW{|g><)KI6miVo1/!jfTwslU~euqurWkyu]m}crv}zb{qc`K~cfxrY~a}zc~u_vr^zwdEC4==2:9.1/$87'AB.HG8@?/<:+;;.UMAOOAu甇鉽銕銕銕鉽撖瘣瘣撖魙琩艂雱蓱搣搌艂鉈i{qp{xq{efNYXIRM;5E5EG6HQ>NL>HD3GH:A>0EF4HE8EE6FE6NTBIG9IH9EE8GH:FE6DC4E?1EB6CD4JK:E=3AC3>=-=<0@C7;:+OG9TQ>RP?PO@LOFB3HE8GH;FG;IL9NJ;&+蒗g諴}SF<.0&OP>fD釂{韇G83xak^M:rikktyvxxttg賑JF8見陎`me[M僚hv閎|41"~a`VEy}x{aign|waysYyqYxbipiwf`I~jslV|g}rmybrqWwx`t`]Fxu^yfpkU|s]tmRtoXecP|fvrtvtp~u\vsroS]ZA~zaLG2}zaovrVpkWzfeyze}y^j{ekeOhcMewymroW86*X\HBC/LI;aeR{ybKF9VO;fcLcdP[YHKJ8gcLUTA]XD{yd<<.cbNus\OM9hfRhhPb^DqMG5UR]ZD^[Lha^Lxu`XT@LD4xkojTmdRov_zu^eaKf`KnjUllWZTByt_xgw`^FyjzwaqkZheW('.-":9.$ LP?;=+=9*JI:96%QN>;;,r嶊銕銕銕銕撅撅瘣撅撖琩雱嵷鄐蓱艄靰鄑f}kspuulu|v除ifjW)#,-%@>65B5DF4FD5@C4NH>QSCHE8NM>HM>IIIC9EE6DC3IG>NK;CF8JG:BF8JM=0IJ=ILC@6TT@IG9LIB=+(,!:8+zgdz〈Vy]]?tA1*~V閉|_nYkQcMJ-}bi]E糧e惆縝翰間~楊麩部u匢釭 pd=8-zc~_fbU牁}eX_N[SH撚uhxvd}lzyuixvrYpxis}|d^VprkqsoWumr}h|s{ytullvry|is|dyu~gxpdppxrZ{ewoW}z`nh}zfyw]ZVDGD2\YEKE4tur^:9*IH5TQBvq\vtcnkX'"YZEURBIH:JM9F@/g97%niSpiSOM:PO>]XClm^daLvo]ktq\nd]Jrya^_RXZEYXF<70kiR|ucgdUEG/|TP=c`O77&65%(+88,A>/DH6MRC55%E@3EF554%JK<|撖銕蝭蝭蝭蝭蝎瘣撅蝭犍雱蓱葖蓱蓱琩鉈j~smmyumsryury敞失xs]GJ=42%IC7JH8GH:GG:LIRQ>KJ1"reUIXR6MU8>="#"oV>{^tV外jnnfL|peJ}}pUeo|]^urZ飽~f~|瓟(+! +94*鉎佰JQF窏郎^\Qgz]?<2稂腫qVdxp[PG3}rW~dzuZf|hyr[rtZDF>}usYxo\~{dzedl|y_qkvq[okTf~uaozw^{d}w`j`[Gxt\wt\hcMWQ;xt]vnY~z_~ewV}xag|_igP`Z/,/ [[IkjU\YGLJ5JH6olTtw]00 xb`Lsr_XVB87,}kzr^QP2A<,65%/)C=,MJ<89'00%?>/CC456'?>-<:,@=246'=?042&??4//$<;.99.JM<咯~撖撖撖鉽撅撅蝭撖瘣撅琱琲搣琣琣琱鉈huustuwo|vqursrss]XJ?>+B?4EE8FC6ED6EC6EC8JI:LLCE1MOCF5kkqt~va榭QpQ 0 8BA6Zc=4 :CB08,$*0n\Dr_uUtW漲}郭{|襤Ё窖艇w簾佼竣漲侄98/A<-饕惜|妢fQK;媃句ufu哈_`P揪j}ixv_ozfn}ejk}bpyvcyclu{xb~gpnWho}hlo}ezu]upj|a{{ah~ciybil~yb|\~y_i|f~ay`jgfrtyl{{dlh}zfvrZhigjSJ5VUDpr]\WE{zg}kII=DC2AC3ejZ79(MJA@2VUBomWLL62&LO=HF5egO央}eocSxo}eqwq[y~h{d{foo[YR?>=0:=/;;.88,87)--!68,44(>@087)==.v潃銕銕鉽撖銕銕銕銕撖晼琱琱蓱搣琣琣酮ezuwxoqxw}sxq{tqttz悵npW46'70)ED6II;IJ9FDFNU798(;6J;01D9:83n^CmTlRs膘竅翱t仴漲嶺え伈嶼簾羲牁价熗>>-ffWxcsc|! wwa岡l~hz梴野meQb]Lyt_d_Jqsazt`OP>d`JY]EbZJGA;|lddQicSwtbVVGkhUMO<{dzytZkhgRvs\{y_~{gldO\ZIrlTWWCkq_^`Oxuawt[pmWa^K{v_pmj~}frmW}Ywu^LL:tlXts[vt_umVkgOzbx_}i}fspXvqZrmT~ycgkiVhaPFE4@?/?C4@A-]cNON:b`RPO?GEGC3@<,EB1gcQ;9*]_MhhURP>KJ8|?>.TUCVX@QJ8EG5ML@4yk~vuvyx~|葬zxtneih$07K3,CUYO-/HJC<-SF=?>;xWgMtccUlv_捶陞k宒y憚牬膠~芛棽挹炡篱FC7><3哈cr躉揚vtb咱{}`伒拑}|u\*'$CC3@=(E@1GA5:<+76'FE6;:)1.';7(A;+HB0G?4JH5EE4SN;[SA\ZEED1CB2CB2>=295(;:)<:'<>+?>/44(DB1A?-CB4FC6FA1CB2m]E滽彏門圊橁xYIE7CB4HF3QM>JL7GE5HE5@=/MK5DD3ON=+DB1JH8>9*FC1GD4DB1CB48:+63$56)IH5?<,JM9ML7JG:CE5OO?|{g?>+CB/HE8@@4PO異嵷嶉琩雱嶉嶉撖銕鉽葹艂雱琣琣雱琲搦琩嶉zc{{rvopqsvwsqvwtssx|qqwzy神kjUQ[H]hSsrpiz^~HSE{k:E:jmZbeJ{pr|wzyyumq隍+89_g+/-%=E=?5D=:LJH55$htbO埮妠揮x恲nン`wtwZ劓|bGK= 侜懂pf帚瑲宵`N馬NH-庛薊У|xe炫}caPKG-/+44 A510,(8-"+$#>=1++%KD:AG<99.-0!36$D=/!'";8.@>5#(#(#(#.'79'76'7>,11&+/'蕉篣酮葖o_Y?>=0>:,880;:.EB6?@279,;>/CB4HH:8;0<<-7:,;=*DF5BB1EG3C@1?>2;:+88,00!66%/+ BA/ED3?>032!>2KH@/A@6;8*58*-,OL<74(ON@;:+71#JF7DC1<;.<<-@?/DB3HE6_\M^_La`LPOIK<:<-12%/*0.43(00&55*$#??3LJ7igO{dqlXusZ_^L~xcfrqy{wiiheR FA.@;,X[G--"47+#"0/!CC6AA1?=-?>2x艂嵷鉽銕銕蓱搣琱琣雱琩雱雱蓱雱琣搣琱犑t^}orougispppputmsyrm}pqnwptszu~k}{hllm[YjUwsxrxtm}rv^|rz`RY=s|blt^xEE;mi_kmWjV@iXGEG6EE7($7T]+GJTE@/6:r踰SS?Й}竣妠Дが蚍芘議芘妠郕窲杼QDED2v挐穠覂$ m董_ZKncNkl咱哈w}u\w咻q岈~el鉓ˊ蝠[NA伾JN3nmiU[ZH蘁z齙wpP臟qU\T1^ha_WaFA&CC6{jFqMi桴楣vn\韎`/#uvpusf^HygeI}eic恣qkVc<*JK9JG0?@/DB1EG756'@>2CB6@C4AC4;:+57'HG8A=/JD5FE696+;:+;;.87)55')- ><,rr^sn[|gx`xw_|`{r[k}w_zkq}wwqX32#:=-A?-+(?D/14%,/!-.$HJ:,,EB3>C0BC6}艂琩琩蓱嵷雱琣琣雱晻撖嵷嵾嶉酯搦琲琩葖n|uwxtotlpstjopmni~ertxormpmrxoqupwppxzzcimVjwbdt\o}ay|x}~w{mvfhQzyo`S1<.EC:>A/HL:+;B3QPM=2@;4dbL齉褋gitxMM<楊じwvcじ憮饕除祝痶 平TRF覂箹換kqgU|;4*PL=褶~`cW駃受衚麇鑑|`剸≒怗佶捶 tx\?+B.{/rFvN摒筋kbK醟畹qVI;&tsuvroecDz`~PXfXV7miSFC5NK;HG8HE879&>=0CB4FD3BE6==0CE1HE:RPA>@/GG8CC6DH8$%21#0-<<0?>298,:9.A@4;:+EF:RN>C@3MN>?>0BA/JC4)/::0?>-DC4<9*VJ7HF38:-/+/-@>+60%_^JwqZd\Ixyf`_MJG6w~hfcOujmVvw^RN=xq98)FE6+(CB1><-:9,A>4#"10#'&HH8,+BA4>=-76'{酮琱搣雱搦琩琣琱琱晼屣嶉嶉嵷嶉嵷嶉嵷鉈|uxrsutrtqoourpsizrwv|ppprqrrpsxnrpsxqr{tsbHT?PdQIXD]cPZdWkz_zs~rv|uzuyymUO@DD6FC8BB8\XG#);GH=C;399)GF4>:+03&87,=;+HD3DD1H@-E;,51#44'JI7JI7pjUyGD3UVIXUBWQ@kVSAvt][YCmyJM<_ZCxnlT;:+HE8FD3FE6CB146%<;.%((-?>-@?475'EA3AA1A@2u酮琩搣搣琩琱琣琱琱琱琩雈琣嶉銕嶉銕搣酮zqvsutytrsysv}mpnv]HF4K>+vg^Jnttupstsswswuxoruoorqyb\gR\o\LVCZlUY[SU^IUbK;E4zt`nWhvYukvuJG<||FJ;LH;DD:IL>+.0PSFE6DDDiuhfWySㄕ╡牧牧假酊尼m螃換葫葫輔譬帑 &$riV嶷千l[lmZ鉓﹞|qo\r\caP窳颳ZN玃懊式揹蓮觭己q\褽bYHぞu 瘐oEgZH藻r蛣z鷩tpDlYsfDhnczqOUbTO<l@.JI3;8*ED6AA/88,:9.9<052'11&22(84&>3&40">A1@:,85(A?1+%:=.65*76'16%0-43&98)%$1.%88,?;(QQ=FC4:=-?6)CA/CB1FH7LL9cZDLF1>@0:7(EE6FE3ZWEmqZ.3"b]J>=+op[;6'skgPONN]I?T>et]LTF{VT?mst20$JKB6<8\g0IPB?8\6*VX@rjb章╯貝牧酊牧炒ㄒ牧﹝尼蝨ryd.-&橆GD3蚘砲臘﹗Q@}v\E>4\YKxzh{d韍鼪sМw擎咱ず~戴vpYx鼚~kF鱠r\;洐鉥q籌T$f`xVji_zTRc[UD,-lB葵躄拔戙窲o~fAKOA((vtxrws\orXuqUeqG`^kMoqSmkJ0 QS;:/!mOzZ_b_kkgasP5撞z^sgbVd`EXE4UO<6<*<>/<9+/+99.;;.8:,3.!@<.KJ:ZH2MD2PM=14%CD/IG6A@18<1nWEZM6+*.-ED4TXID>/99'QN>LN?>=-58*@E/v{iYYG]]KUQDhgR_[Hup\GF4EE6FE6JI:@>-LI:33%^P>39(BB1C@4RJ8FA14/":7'JI5E?0}滽銕銕銕銕銕銕銕銕嶉琩蓱漇嵷漇嵷雈搣鉈jtxvqurkvpjjlms|rnZ!d^QA8(z|uwzvyr|oqup{vqvrtqlt|rquOYBR]Ihjdwbqh|cn^m~fqkKRAhvj`lYqi{ +,+0OW&;C1]i:fsUb[jt]MMEBI9r{g|疝x夾壯ㄕ﹝ㄕ衯 鏽ML9RU<挾yIG<悚DA2HQDlIKB籦邡w醡陲└鰾hx晰徽RTF挳}Qj禮njuiL籌^b`_矣mUvQURkaL+*wL筋徽JG3_XB眵n44)sxyuinhPtqVrrOb3搋TjRhmL|cD0TO=7,頛嶈舕隢藜杉葖橏太庰j鬩隅~蠆烊E0膨mR?3)QT<+\]MNPBNK9;8-;9'>:,GG8>=-II8HD3RQ:(gfSHI8VQ><;.=?0JI:CB4,,@?-44%B>,43#1.F<-ZRA74$65'HB3CA/?>-r敼銕銕銕銕鉽銕銕鉽銕琩琲鉽銕銕嵷搣搰鉽丐qrqqvrmwvrsvroofyZU@mr\** 迭ppqvmp{wnxruyssv|xwspv|t}FS>NeN/7+5G?UeRPRBomomvpponk}tWaTAB2:2$mC!'*W`Kytah[bl[SV@goX?G:;E4igYafU~pt~w眸岳|{l +50"_dMRW>崿丑_YBkkTmjWyilfN}sc|l噸魱祠噶x繡47/ぜWQEk慰wf縛hGq矺鞊mcdaz_衧p礿xNc\xOhbN,,F>.z擎olW眓妍SuDD5rwvtkgR\]IvoWs`LwrMnQ^FoMr}`O:WVCI>&蒫嶉嶉撗活~躈身c捘k豱銕撖鍉兆諨mf[F1(50 D2(/+85(54%76*-/"KF902!=9)bM:.."32#MM=DD2[R=cZF88,84&::+11%?>0SS?AA1<:+FE6:7,?>043%B?0FD4hf[30'@@0DC3@?/76'=<-02#13#SN?<;+DH8^VCSE2YK-DH8<:+x撖鉽撖撅鉽鉽撖鉽鉽撖葖嶈滽嶉嵷嵷嵾銕嵷器nxom{ttwxutrqotlvavUWK郊rknoosisxwqrtyyyopy~pspoimt{|{d[cSf{`nwcFUA^kX00"c{bow`Ysb??2ieK靮dX>79-mjsqxw|w狐UdQvvneo_ogGUE9@4|nrnrVu迂o暫b[Ma[K\YH晰帛zxc|yri}fvp\"&鼥躂爢避捖砲}雪ztehO妠牶qapL芋y蠐zde閎na縈gd豸jあvmCZjJ>:%32(0/!teK籧撬鼥羞jv>>.oqvtoVG1wuYTWDvKepoRlIdpYqE6IL9F8$蝺嶉嶉貕VM:檺誣rW哈瓴r貕銕銕瑹嚁縥肩陊cQCE?,D<-:9,@=/@<+EA354%33(?>0NI:((((51$QG9MC0??0#%II<87''%@087'ydLyiQ]SBNA/CB4>:,?D220:9,@>203&u敼銕鉽撅銕鉽撅鉽銕鉽撖鉽蝑撖鉽鉽嶉銕瑹蚙ox}totuxsvthsllt~QPDwA?5xprjqpk|uptsrout|wyuw}uiqlplqEUBaxdjsfmwwT]FGX@_dNsrxdQ>G?t\J[UA44+fmjnnlsxpjjiporqlistwvxu}x~x}zugn^zd||hn中wpvo`vzmiOekZ痵役洢郺rgSqi{|~a{期_]L霽mD靽kcV@]}oJf[*$gルil耵qwS67)>B4fWCveaR# 尪?>/umR陘~暋ix52!~xdrwwqsjSxwbIS:[|R`qRc{eql[PK?E5"滶蓱葖嵷刐wPB3髡炰m豱銕銕鉽膳w{澈`IE?,HG5B<,:3%B<,LL<.,87);:+11&JC574&GD2N@/xgK=@/55'21!98,JPAQQ@AA2?>/A@2?:/96+43%/.>400#@?/67,;;0ED4<>,87*LJ>IB2')dYDE=133%8:(77)?>-FE6EC8A@/|a敼銕鉽撖瘣甇撖鉽銕鉽銕撖甇銕鉽甇銕銕瑹瑧p|wtsnsmsipnvlpstww|tmsqugvsrntwowqlqvtypospqsuqturhQE6K6%蒫嶉葖瘛縎欠靮樝健州刐f豱鉽鉽漇鵘→艂}]鮿~^FJI7CC4?>0LG9OL9OC,oUBH?.EA/<=4>6(+*97'dP;<;)UUC3/ TSFSQCDI6,,::+00 G@1J@0,+:4'GE/C@182%'#8:,*-"EC/ED1GI7OL>FE6OM>A>+OF67<(A?/hXD8;-UO>>=-CD/URIA=-LL9<:+o滽銕撖銕撅撅鉽銕銕銕艂銕甇隢撅蝭瑹銕鉽畽j{nvrtmnuuovrrnqrhbVd`K}ybwstwupryolprpsxopqnulprlvqztsusrpmUsp[=@0AOJ騿{聜:*/4/:=,LZF{xmoe}ghi\nYK]M-:,EV?xrOcOc}b\mUZpZ3@,O]H6D3UfRc}em|`~sdz[voR[Lwlyj{}q_Hxu~c|芮{弁ps幼hmXqj盛!'AFB磃Z悛pq搵nf嵿ufd22*26'_^Knvsuuusc`PYYF儦琣棎握epy~KE3ljXxxvseZEuu]IyUx`7|UhYtce{hBF4;6&漜漇堙shaM赯銕撖芞|^豱銕敼蚇滿w霅巘∥騤eOGG:FE3JI5JG7?B5MG7v_CZG3*@<+@?/41$42%;6(]J8:9,HG5AA1FB0C?/HD340"74)EF4OI9]Q@87)LL.@?/C=,%+:8'JL:KG8DB1LI7JJ7=;)IH8PK66<,98%n[N88'JM;GI5OL>CB4EE6LLH4puliljikmocyghjljhi`w`xrPbLw{[oXro}t}q~{oiupl~dl}bnz\mvn~yb蚚w覤者岩z{|q^eP]dT "oeQS帢yY伔veqQzPYi>?1fururouwzsn\i蝪椌熁侉gvvKH5leUtuvvL<-_P@1FE6A@4@?/JD5JM:LA-V?.]F3/*9;+NQ@IH8A@-^I7:9)FC/EE6>9*>:+DD2BA176')(M>.hU@FI7A;,CB4;:078%B>043#47*>=-B@-IA6?>+=9*A?/?=-aWDA>/PH5PG4==,EE6JH3EB3FD3DC1QP9YRE~潃銕銕銕銕銕鉽鉽銕銕琱琣鉽蓱鉽潃嶉銕銕徾rzvs\qx^xgxy^w|^tz_hpWbjUdlWglWkt^goZdnQ19.[`J86/ fbUcdOcjSku^hiUagPbaKdbOdgSmv]]gTlvXuo~izrqyqzrowlqmoysrrprsrnpjpfv[Dg^cQEH; [u_K_L5E7LYDRgRGSIhxdFVHhjejbhoqfjimbz`XfSXdNObO`mWjxgojSfx`ytf~bp}j}yzw^sh鰻《^>豽惘_mQ\m[UdV'0/'\R@蝏|Qn|Ym悁pmgm<<0zy_rvwppvuxicQ觖衣唭p鵓肊yz[bfcNrnVMM@d^KqsvuveO|L@$rf\UpZy~NN>?+瘣q佴臻繌兆銕銕瑹剼}_儦鉽蘉~ay蝪銕謓tY?>2?=0>=-?>0FE6EE6fO,+C>.20A;)OC114'>=-ED3LK9IH9@?/;7(JH5OK0lYEYL9KJ6HB0kYCaK94"WF:LG4JJ:AA1=<+HG8<9+\\JB@-DB1;9)?>0$"F@,WV@A9-D<,:4'ZH67=.DD3HH8KJ:A;+LI7QO==9(WM:JF5OJ9lWKP9JI7DA/?>0HG8A?/A@-EG3BA/rY貒嵷嶉葖嶉銕銕葖嵷葖葖搌舕酯嵷蓱雱晻雈橠p}qxvwoxomimnprj};60XWHjigtrorlptwwurvrnpptswmrulr|utnuqnrsrpqnvgz真[g}pujq~酋ixu_v|gZmZ_gU()E\H=K:P`Ptyj{fYn],3"/>0Ys^b|govJ[Huw[YK馬293awdUiZVnYBJ5zekjV揚疏|QeTMTB]g[]fUXbSq}h.)NO;痡umAvg`P_XDZd蚸m眹uD?7^_Fcf誓]ctuknw鍪帷cG敞苃oKdI=$すdJNA品cevUzdP9irnTu[F滴ZrcS_p^jzfS[J6+鈭}屨敼鉽銕銕撖暔{\嚜捶鉐{萯兆蝪銕豱qV?=-=<+87'>=-HE5FD1`K8^T?LP:JH7BD/]SBkSxZGD<.>;-?:,DA/;8*?;(94&G?0BD1@B.EG6CD1CE1SSBPO<--$KD2^R?LI9GF1CB2DC296+ML:44#_^KjYHC@/<7&r\@69(>@0:+oVeO?@2MH8ROAED2DD3*&B<,>>/EB3OO>A@/FE6EB6NM==@/=<+ID0nT@)%PQ>DA266%GH1OL9m^HmWpUXL<:9+EB1@?/ML<;:.54(2+45,44%44%pfP敿雱嶉銕銕銕嶉嶉搣蓱屣堙屣琣堙搣琱琩琣戃x{rzwqzvsskuspnlvOI<zdbZDxvzptpnnskoqnrqrrtptilpnogovtrvlvpqpjx}crv^肛[_@}txwquszropphksvxw}|e{fW[Iu{jXaObv`Xp[[mVRdQJR@zML>E<5DQ@zy9H2yGD3迭xb\JJG:QfTavj4<035,62+h\Aui?鉭酯jlig箠QWp_vLB2paa鑿Z<`Q_t_tvr`貕椰sV轘倣jlSkg縊]吙]浂adj^K%3DRDR3Q[p^Lbi`fggJ`VIjS@QO@) 鍉hげ觓鉽鉽銕鉽桼rS珘儒酗銕銕銕銕諯nV;:);:+?>0CB/CA1NK9dP=bN;ZT@TQ=TT@OM7JM9jP# JL@WRCHG:<:)73$@?/;;0>=-;:)@<.TQC31!43#A>200!:5(gR@N;*;5*C?/HB26,0$w^fYBB>,96'DE6><+A;.AA241$40",-12(::0*, ][A斢嵷嵷嶉蓱琲菗搣琩艂晻暺鯕擿銆搌琣巘nspvsuypsqmnonipm|c>7-x}hx|ckx}ef}fs~e{gt|epu^qybqzatt^noZfpZ]nU`pWXfMWbIZaG\aI|e}h~~hjtu`vw]iz{erqt[izfwxvstonyhYK;z`OpmnQwctzlsywulvtusxptopts}muqt`nRTiOIZDut`咯sp\QWLfkwlUYLmyWVCMK==F2Xpc`pXQbU!=9-XSEX}`gVem_mJ:鋮dJcK9kfSmy{gbix[電Tdmiuvl鵔j楎謪ㄢ\~}h掌_`dgk8;;U]Xa\DR'IP?XZvVilrMh/ ^=-kS>EH7F'窴吹_A{sV慦銕嵷嵷潃蚚jJvvm隢銕銕銕謓dJ>C/98,;:)HF3MI5OK7dR<]J:WR?\[GWWC^YIQM;WN9eO;*'@<-NM@@?/:7(@>+,,EF697+?<+??0GF1?>+GJ9KH<.-"GD886'jPeMTG6e_CsXI?0CF7:9'65%=9*>=-CB1C@4>A1;:+DB151"21#76',, [RA敿嵷葖琣搦雈琲琩琣琣琱琲篲zT{雅YRB隒婦晻鍜rvmo{jssuootqkvput`xkUYcMXcLjqVhiVeiUrvbip\klYhoVfkVpr]w|cry`tv}etw}h||ml}~g~zev}ep}ee|epl}h|wbilysrpjtvxuo_Ft`LpdTvurvwpsv}xvpptpkvysyptvpyqltv{dpo\hQU8\cDQB"#wU5~eP~jbP廝VoWhM~u`tt|q撰mdL暻捋kvklu[xtY]lZL#PLD/zoyL@`oP?@/A?/=;)?@-QK:RK4lQ;\H5SUBTQ>OM9XZF[XFTL2r^J60)<7)93#GC2?<,<8&),;<,>=-5:)88'DC6A@2?<+?<-=<.83&47*D:)iQx[UK=4,65#>=0;<+>=-@=-;=*MI7JJ::=-65#43#64#42%A>2-0$VT<貒搦嶉搦琲琲琱琲琲蓱艂甇lqsQov丳頦儽qwovtuoswppyrowrnFH220#edSuwnromvrspujsrtsrju~okqrvyzuvrvrrpvptqksf~pq|ryg{upnrsv~wttstrq~unpqmrrwz{mzdbjVMF:MK9IF6^XJVSFlPS@vust-0$72$AF>@\\-?F}.NVvq]T逝Y︾VlTjWB大QlQj{}}N_KtX哈禛﹙ra只gc癟r瘜pz屩y195@=-gD2A?1M=$t[Aw`DtRlPiOlQwXbcFdQ?yhK|gJjPlR~hLkO`IfQ|YB9;+@@.G:+z\GhNiPcHYJ6QP;LL9HG8WQ=UWBWO;TO4fMA7'E;*;7'79'63"41$11%?=-IH9>;-98)=9(54%;:)?<,,)<8*yhTrZC?/:6(:9,,,>=-<>/A?/JF7AF2DA/<:+>>243#?=-TTCCE5:6&)0"^YC豱嶉搣雱琣琣琩葖搣琣琩諯ずmbU繒筋r輵駗owrvunsspvnuxlkq;=1?6,ompmuprsqvtsritmqilonmpsvpt{|svotnvrtswru|rwotuv{qsquvoolkomguyojkwgmv}釧kkltakiUkgYUXDBD4jfK#/!JcS`q]#&?D4GXU`rt帚(=B(BIctj2SWIXV~q^ozeteIP@]G}wcbly|x}r閰葖橍s蚺n零QUT蚾nf1?&CN]tkCL9VZGYY>LDVW~cCjU>u\DmI6[F3v^?gK2CA1*-$:;5<=4?A3?D2EE8BF9?A2EH7NK>FE6CC6@B1A@4A@2@?/;=.?=-?>287'3/ HK5KJ863"63"qgV敿琩葖蓱嶉琩葖銕銕搣膍w{伝矇^犐髫ispstslsxrmpoptq痔sp`36+ssavsupssuqnvqrstyslwptuxrtptnovursupmpppqlwtwu|ttuswspyomz^~ckm~i{^UB[U@q~bmxza{{duqYov`t`rpTlkRvsZ~v^{_}wacmuqZuo[XSA85(jmY}^zc摹pgQZVA<5)GM@Ld_!:G9VZ7Y^t~qBcgv|jzjrLQ?CC3/8'5-!friur|收葖馺丹y鵘咿xO蚯6惑DdHbML躞鷵xhgOg<)mub;=.*-$==-76'41$31#42#BG78=+>=-=:/A>1A?/?A1@<.::+?>-;:+11&CB4=9*63$;8(;8)76%AA/;7(dU?RD2HE3LL7WV@[ZGWUBRL8ZUEi[Ky^GuW@E8*0,"++FE6BB1?>2;:.A>.98),*!;:+54%H=,_I7ZF57&;>.54%::054%=;+FF4<<-FD1HG8<<-ZZF22(TQCCB4@>/MO;WWC85(STBH@.豱葖銕搦銕嶉銕銕銕搦蛂鵴揍r]郭髒袺}鄖藦lvowtmovsvnjxnsxsiUC?;,qqvslrlko|oqsssmxovjlutsppvunrmlqzoomtxqotsyx|lxu|}釭VM;so[v~dypqVzw|v]gwvqk|emur]ccK]Q6mxs_cgsxwt_w]\G=:)fswqmR|3(VVB;E)JV-EDJXPbY郁?Gk{~wb|bwM]NeO`ziUjQY{蓖甈m懘衩洪RrL]品Z嚎Y2JSKc_)JV'KURkjcpnAP9QPH_\jjV廎zr}jSm_]}kt?.?,<)?A-98)98,=<+<<000!31!IL>QRDDC4ED6UTDGG;DC4?>0PO+A@2JK5GI7MJ:EB/eS@\P;SV>WQ@[XF\[IVUDXSA_\GiXF\C1kSdO;P9'@<+FE699)43%.,35#,+IH9=<0(*_R?cNC@4DC144%76%;>/>?+03"LL<<:*MO>QQ>76)llV25&NN;JL:NM=HG6HG844%WUFOK<赯蓱嶉嶉鉽銕嶉銕嶉搣魙晼醑tv衖漞琱囋}iwolv{mu{ulsuvw`pVw`scaIr^hRxmnrprrnpllrtpslkmntprsmkolpjnlqskixutoypfgnV|ewx`ry]dlq\wwalmYwt^uv^p}ixxejrYgkQMN;)i~}f~hyrnF$DL<,5邯%BH(P\?GWhb{hPybx\nzovyfh~eoV\ra惟鑄派趮６dkY:t\@lX>r[AgZ9?:5<[a)JV)JV@QT5Y`0FKxSDz6+:'p+t4 jC-xSAm>,o?-Q:BDB2nZE^I7UQ-_[G32"JJ878*NPBNN;51!uxf54'NM>LO<\XEQO;KP70/??.ZYD赯銕嶉銕鉽鉽鉽嶉銕蓱晼琣銡甈雈琩藯r|uwusmuslilwB/]Hnmrt^xv@1xnvlrpnsnqtqrtwsltrnqsngomtmpnqstrwpwrozt~y|}{zvx}gnn{~h{{dvt`px^krYxeqq]svZjkWjzv^}}drinrrgkz{_ww_yhhs\foXSXEbhUbjS`gS8@.ugQ{v]utYzt擿WUHxp,Ta8=9-S^:\\-0{zzjdvgqU\nU{ameoem}f|洫嗒弱q^醵傭lfOdLpS=fR6{R堜paR`_]`VJc^W) ゲ7<'9&B.lE4a9*]9*T;*R?*SB-tS54(,-BF9<<0?>098);;.HG6NNFD3;:.kgPJH5ON7OQ?c`LHE8?<*43#HF3FC/IH9;9'hT?\H3QP;LL_nd>US#GT4BTcQju\xdJ誓]oyg}lcwrUL;{vV縭rT7RB2?5"\芃jヰm圇p埜s菻q虳|qt_bP9VMVVHc[Dh]nnbFwKmK25*(+CB1?>2>>240"77*JM=LL>?>0FD1jlWSUBHD3CB1LK7JH1JI7MK:cbLLL9A@2=9(;>0FD3BA179'eS@WH4NN9HG8LG9GJ\]P`]H赯銕葖嵷銕銕嶉葖葖嶉琣搣艂葖晻琚堙捸搰ryit{pkoxop~eY>hRvD/g~ex`pYgQZGdF0 knuprzvsjtnojjp}cmsigmhh|}dtwbvepw^rv[y{e}dd{|aijqumv}ft{dmrZfkVflWko\emVitasu\yzfu|d}{d|yc}~j}~h~hzw`uuZuzaps]v{ayydsv[bsw]c~iwx]~h}}cwjroqsswWS6lnRf]HIA5x_qxk{LyN' KOAA:%ni_06}tㄣ#&%*/,<-1!>7ZM8lr]vtc}m諆酌qW芶ｂ棓珧mP^EbEt\BrWBwY@wY@wY@s]IHMFtZvid|jTj_6NMYM=t_Gp[DhS=uZCp\DoV>hN>?/('BC6<>/EG531#02"HI9RP.@A/=?087'dV@\I8LJ7HD3OK4~rN[T9QP7IM5]T@C?+:<-[K9zP=yc;-+."-3$66)\SA{a{gSG?/<9)44%EG7NN=88)HE5JN;=<.BF/%(CC2@?/KK8NWD98(X[F46'HF3NM=yuZieRiiO[\GgfTvqZ赯銕嶉嶉銕銕銕銕潃葖琱艂琣琱晻琩琣琝hiXulos|\lnknhStpZ~^Et\eiqUvZ{V|mRyaMp~gkhggk~bjghpjhonokkmolhcs}~h~|donlhinrmrtnrvonhwsqulqu{~ovqsn~e|iw{d}iikfxufw~gut_ewv\z~ajx\prt畢ZXDJB8kloscz\o鯫}鸇^kd"@?;#BN8BH膾]權Z島[EA0ntXDw_m}鍭炎j艤wOvZEz[Cv[@|eOmL9u\GlR>s_JqS>xttd~k:NJ)GIu]>qZElW?lW;eP8jQ8[N3aH:<.-/#;>->=-RRA'$88)LM=-76#CB1A@4DG498)iWAeR=NK9EE3ehsLVT=EJ2]O:C?+CD4SM:v[inY1.'-4&&#ibMsXaK48:)03$$'+-98(,* 8;)KJ80CB4LL9|x^a^JnehOnlYtp]豱銕銕銕銕銕銕銕銕鉽琱琣晼搰雈琱琣菇捸xmrnprswmghi{^rJ6dKcK|M;up}}bku~f~sE2zqokjkkj{{d}jgictyw^oiyxalomhnj~~if|e~~iijulmqngotoplg|pnwlzlbnVScRdrYmu`kqZwlpwehpXhx]yw_svavt`zdswdls\lx]dqZct`goZZoUR`N\qU^gTSgP8K:8O>LeQGZDEG7AE6~frqU鬮釂{蘛r鷩t籌韇鬎yq(--6(9@hZ綞Ua矹^cgbWI2譬窷嚜捁蒗sDt[JgN{bBlTwY@dKiJ5lTumTtr|Ywgm3LIXE=qYEeKy]AkTnVCkSmS9hN11#,+CC4>D3]^M--$?>+PR?^_IOO:ON<]XIHG8HG5ML:OOHF3|hE儠篜FH6TV@ZR@A<,A@2@=-UG.icM@- EA3w]dWC! /,@D2((86%RUD<;+HG6SRDFD3][KCB1KO><>/DE7YaN17'os\DO5U\K\bLw{dho~~ile豱銕撖銕銕銕銕銕銕銕琱蓱葖嶉琩琣菇晼堙灈`iTcjnmfozion~}]iOnVXCM8jqfsioxhN:e}}deihgl}~ell|f~kkfjkq~}fo~~iljqqtqljkjlfmlilo}h~kh}k{{dvz^y{bmxbugwyazv`||iszc|~asy_{xdryby}i~mliskmqouvwaos[ow\ps\ljQouZgjRakW[aMhnY\fT\jS_iWBG8:=0`钀|zeSH?(();<！8焨JG:/^kc獵^旍s甯nb骱似撖滽鍉甩@>(jI}cLuYrWBdKwY@dKxWFdKnW?eH4:),+BD3A@4_eT00!AE3\bLZZI[[GTS;YTEQQ>QP;XUAYV@RR>NQ>SN?b`KLK7@?-A>+HF3CB1NL8<;._Q=YO6LH7IL7/EJ8MA(ioxmS{{dymVgQ52',);:)LP@#11$QRB65%65(Y^J:<+__KLO8#9A'KN#IF"DF(?ArYd1驤磩y告OkojO:URFYClnQmCNI蟥撖瘣瘥蚽},6"m[BqYEnW?u\DoW@vZCdQ<~cItt[x}}$*ED1DB1ED3;:+eZEMC2HE5NL=FE6JJ3_g|qVaS=DG2?A3AC3@9(QK8llmyiNK=,,,/.A@4KO@>B6IM>54%<>+fiU;=-\`IemXW]HVYHX_LipZW^Eow`uxcqyaoybiuYov^rv^mss貒雱橑縟晻撖銕銕銕嵷艂鉽甇銕銕銕銕銕蓱襑丈iX}k|flgsjfi~iz{cuvcy^zeM|/ p\CzcrvZkbJzpTWCJ6_@4qxfnrdzk{j~l}joj{kxi}mxixhx|fxfziyzer|akx^s~fx|f}gqos}c{~h~kxh}npxgyzi{~hzkx{ctxbr|azi{~hxh~~i}kzizizizk{jx|fn{j~lxh~mjjnnlpn{kzflq}~f{yeow`ps\v~dlo[w|ecjXkv]tv^EJ9GJ9G:$<5"~gJrThbgqSWㄆP\dT6ZWE6IN:5/lvfy|esYwwc_eU鵖嬥秶邍uG ZV@^VA\S?]S@YQ=dYBnVChU@noXttt}9UGgW;_R=dQ@-17&KJ:UWFijSIF4FE6dbL``Na`ONO@STDTV@TV@`aQNP;HG6ON,HK7>=-;;)TI8EB1HG8JI:CB/KG2o[BfbthRKL7JI77<,:5$88*mhyvdxdQ77(03"2:)AK7HP@*0"9B/>H5:?-RXF\hS[gOhw[u}deuYk{_x|fsgxhs~fq|cyzerb|kvjom|ntuZ敿雱芮膘掁琲琱琣葖搣琱琚搢銕銕銕漇犍搣擽McPu}dtbu|axhm}`~hlimunnVDpfTzkT|;*ytYk\HsmUrcPnmVx\BWDz{ejcOlv_ly_s{dm}`o`r{^vgt`uex|f{g}k{jwgq{fly`lx]rzcu{_s}ev|hr|axfqy`vy_ufly`p|bx{cp|bm~bv}czgqxhu|axfzlu~cqzbufu|au~crbs}eq{_jxdsgq~hm{^{grbzixh{jv}fjv}fxh|nu{cufzi{|gy|il{|dz~cjyzemin}gmjpt_JM:CG5iQY`O]_@pva]bJ`aP(/+99,fjXT[EGL?NJ=imYxh(JRDRIYD{|g}hxht笥Ｇ棨袸V%%wll{fr}ls{es{exiuf{{dwlttt}*?B5L@v~dlzaq|blx^vy_|gjy8>-23%EM;cfPchSZZHGNZ\HikYXXFON<`aQSO;__KkgPPR=HG6KJ8OP;KN;EH7[T?UF4QXBOO>JMD1KA3*'ns?D2fU<)/:?.;E4KU?MYENV@[eR`kXZhThubcu_cs[]pWasZfubjxa^nW]oUhwbjvclw_jx_nz`nzlugwiwi}`豱琲懩鞄琭葖蓱琲琲葖黮痑晹搣雱雈雱琣琣襑=UBp|bqfqz^lu\shp|crtaufbqSiqp^kTk`Ho_@rt]uz`v{fsK8m`Iv_HvN:kP;k{g{~fjw_p|cow`s}ev|gs~fpcjxdo}eryfmv`fv_gy`hu]fr\jt]gw\|hkt^kwbx{co`oydhwas{eeu]fwapz`xilzdhu`gy`kyhk}co}eozclyal|`n{flt`jybmv_ozcq~ht|ffy\shmwahwanzbq~gt}jm{^o{ds}csgmxdt~]v}exkt}jv~es{exgu{cv{ezf{{duet}dv|dxht|ft~g{~htJK7@L<︺NYiSg|nzcu,)"PR;ty~csczg}svo>L-DFpxft}jsh{|duy`mP醲隅qz懫lXZA0,'x}bo{dq{fr|hv|htlxixhnzbgyeqn}3LK*@HS=CD0]]H`kVKR>BG3[_NEM6T\H`_KJL:@@.BD4HL:GJ::<-XP▎PRaMs}cv|gu|hy2@->D1T\F]mU>F1HL7V^J@L3EN8PWCFH6?A2AH5LM;@I5EQ-CE28;(篹}鷩t籌tg]PK7=D5ug58)#[aFXeRQWDBJ8.0EP>[aSS^HRZGfv_fr\YhOtll{fpzhs~fo{dpdlzbpdm{em{hn|`gxdfwao`q~im{hgx]}f豱雱荎藗蓱鉽銕葖嶉嵷雱晼晼躈8NU>Q[DLO18:,4:&FRB[bLCE5CH5IW@C3MWCMR>:E0;D0ESJJ3蝵wョlc~OsRKiMNdPbt[at[^qXewb`nYgrbhxdcp^4Q=|gZsY`u^Y\HVdL`qXcu_gy`au[ooSY_Naw`^nW\oVt[K_G-3&;B6cu]\oXar[fv_eu]cu]cu]`rY]jT{Y^X[FiO3千JrZiz^n}fDM737%OXE憧s棱x恁q魋y籌籌籌籌z籌聾itRRF/13#A>-MQ>XbLXcLDO6XbLTXF>G4IW@CQ>6?,9B-GX>WePZjQUfOWYDEH5AD53>+K@.YFqmVar[\qY^s^au`_r[bt[cvbcvbznNNkR^pWfv_NgQ育PUp[15%>F3fvb\oX\rZZqXZpUSkSSjORbMVmSGaJC_FfbKeI\By^HZoYd4B0NcILW@LZA~Uゝi儱n籌癵虋}ヨcRYL;14'AD3?I8@I5JF0OTG4Q[GDM8?J86>,TcLaqYbrYUeRds]XkU[[ERE3|UC聘]灘[qM;;TA0@I5as^ZoXXmVSlVOdLLaLJ_HC_FF]GI\GJbIFZEklKp\7T鉒p鸞aSUY\z晢tk=`\=CF3AL:ESAAI9HF/GN@YiOUeQN_HZkVN`KM[DXkX^mZHP=IR?,AN5DS9NbJLaGHV?OYHIS>Q^JIT?OG7GK5]lUYjR^nUMZD^oYbo\Q\FchVS^HGR>P[GGUAV`LXiQUjTXkSNeJX_C,7&2>-BL7APN;EVBH\FM`ILYFVdLXjQLdO?T@FT?J]GIXG->*1=-;K6DWC;I5FVBK]Ffv_`s]SfNM`KXgQ".KYAJZGRdOSfOUhRYiVQbLQdLfwa\rZfwaplev\^sY^s^\r\ZpZ\r\^r[Zr\^r[ZpZat]`s[at]^qY]s`^t^^s^[p\\pZ^s^XoX\r\UjQQfTvoU豱嵷鎯Ｊ犍銕銕銕葖雱艂銕銕銕嶉鉽葖嵷雈巕'7-UnX]oW[qZZoUXlS[nUSjQ[mUZpWXlSWoXZmUSlS\qWSkSUkU[kTThSVmV\pWXmV\oXWoZYkUWqWXoX]u`XoV\nZ^pW]q[\r\ZoY\rZZmXUmXZmVXmXXlT_s^ZmUZpZ]oZXoXRgMVoXVlXUkXQjXOhQQjVTlTQhSSjXPgQSlXOfQOhSMgQYq\Zt^OfQWoZWl\WlZVjQZoVYp\Wq\ZpZ`r`^q\WkTZnSZmYXmU\pZUmXZpZZmWTjQ]t^\oWZpZZoW^q\_qZ\qX\nU\pZ\qY\oW\mXYmX^pW_oU_qY^r^\oV\r^cv]WnXeyb^nUes`ZpZ`tWawa\nZ_r\`s[_v^\qYiyd[r\ZoXZpZ\pZTlTZpZUjQukNUoU\qX`s[NhPnmLUkSXpVZqXZpZ^tZ\pU\r\^s^\sXQfN\r^?WCXoXSiTUlUWnWRZHNK>J[HM\J<&UQ:RT@NN6PJ8FD)MI1WUA`YG@3#F:a]Me\H]]E=?(JD,D?(PT;JG0YUBcaO`YGTZGHP;LR=HK:LG/?+B:#8)?0,)&#/+*+%,2!01 41 /-57"7:&>B-6?/'2$.;+1C3+80-80)5**;3/@33@43C52>19I?8D:0<2->2/<./@34@09>2FI8?D92C:0A20A267'=?.;?*AJ-GC(7@*37)*91FM9IR;KS=LP7UXHQ=IR=PYCGR;GR;OV>ISQ=8J8@N@@Q@EWBK\F>UCAT@DXC@W??Ph) then + GlMat.frustum ~x:(-. r,r) ~y:(-1.0,1.0) ~z:(5.0,60.0) + else + GlMat.frustum ~x:(-1.0,1.0) ~y:(-.r',r') ~z:(5.0,60.0); + + GlMat.mode `modelview; + GlMat.load_identity(); + GlMat.translate ~z:(-40.0) (); + GlClear.clear[`color;`depth] +end + +let init () = + let pos = 5.0, 5.0, 10.0, 0.0 + and red = 0.8, 0.1, 0.0, 1.0 + and green = 0.0, 0.8, 0.2, 1.0 + and blue = 0.2, 0.2, 1.0, 1.0 in + + GlLight.light ~num:0 (`position pos); + List.iter Gl.enable + [`cull_face;`lighting;`light0;`depth_test;`normalize]; + + (* make the gears *) + let make_gear ~inner ~outer ~width ~teeth ~color = + let list = GlList.create `compile in + GlLight.material ~face:`front (`ambient_and_diffuse color); + gear ~inner ~outer ~width ~teeth ~tooth_depth:0.7; + GlList.ends (); + list + in + let gear1 = make_gear ~inner:1.0 ~outer:4.0 ~width:1.0 ~teeth:20 ~color:red + and gear2 = make_gear ~inner:0.5 ~outer:2.0 ~width:2.0 ~teeth:10 ~color:green + and gear3 = make_gear ~inner:1.3 ~outer:2.0 ~width:0.5 ~teeth:10 ~color:blue in + + (gear1, gear2, gear3) + +let main () = + ignore(Glut.init Sys.argv); + Glut.initDisplayMode ~alpha:true ~double_buffer:true ~depth:true () ; + Glut.initWindowSize ~w:300 ~h:300; + ignore (Glut.createWindow ~title:"gears demo"); + let gear1, gear2, gear3 = init() in + let view = new view ~gear1 ~gear2 ~gear3 ~limit:0 in + let _reshape ~w ~h = + view#reshape w h + in + let _keyboard_callback ~key ~x ~y = + match (char_of_int key) with 'q' -> exit 0; | _ -> () + in + let _special_key_callback ~key ~x ~y = + (* let dummy = x+y in *) + let delta = 5.0 in + let redisp = ref true in + match key with + | Glut.KEY_LEFT -> view#roty (-. delta) ; + | Glut.KEY_RIGHT -> view#roty delta ; + | Glut.KEY_DOWN -> view#rotx (-. delta) ; + | Glut.KEY_UP -> view#rotx delta ; + | _ -> begin + redisp := false; + (); + end; + if !redisp then Glut.postRedisplay (); + in + + Glut.keyboardFunc ~cb:_keyboard_callback ; + Glut.reshapeFunc ~cb:_reshape ; + Glut.displayFunc ~cb:(fun () -> view#draw) ; + Glut.idleFunc(Some (fun () -> view#idle)); + Glut.specialFunc ~cb:_special_key_callback ; + Glut.mainLoop(); + ;; + +let _ = main () + diff --git a/LablGlut/examples/lablGL/morph3d.ml b/LablGlut/examples/lablGL/morph3d.ml new file mode 100644 index 0000000..c8dedfe --- /dev/null +++ b/LablGlut/examples/lablGL/morph3d.ml @@ -0,0 +1,602 @@ +(* $Id: morph3d.ml,v 1.2 2005-10-17 11:27:04 garrigue Exp $ *) + +open StdLabels +open Printf + +(*- + * morph3d.c - Shows 3D morphing objects (TK Version) + * + * This program was inspired on a WindowsNT(R)'s screen saver. It was written + * from scratch and it was not based on any other source code. + * + * Porting it to xlock (the final objective of this code since the moment I + * decided to create it) was possible by comparing the original Mesa's gear + * demo with it's ported version, so thanks for Danny Sung for his indirect + * help (look at gear.c in xlock source tree). NOTE: At the moment this code + * was sent to Brian Paul for package inclusion, the XLock Version was not + * available. In fact, I'll wait it to appear on the next Mesa release (If you + * are reading this, it means THIS release) to send it for xlock package + * inclusion). It will probably there be a GLUT version too. + * + * Thanks goes also to Brian Paul for making it possible and inexpensive + * to use OpenGL at home. + * + * Since I'm not a native english speaker, my apologies for any gramatical + * mistake. + * + * My e-mail addresses are + * + * vianna@cat.cbpf.br + * and + * marcelo@venus.rdc.puc-rio.br + * + * Marcelo F. Vianna (Feb-13-1997) + *) + +(* +This document is VERY incomplete, but tries to describe the mathematics used +in the program. At this moment it just describes how the polyhedra are +generated. On futhurer versions, this document will be probabbly improved. + +Since I'm not a native english speaker, my apologies for any gramatical +mistake. + +Marcelo Fernandes Vianna +- Undergraduate in Computer Engeneering at Catholic Pontifical University +- of Rio de Janeiro (PUC-Rio) Brasil. +- e-mail: vianna@cat.cbpf.br or marcelo@venus.rdc.puc-rio.br +- Feb-13-1997 + +POLYHEDRA GENERATION + +For the purpose of this program it's not sufficient to know the polyhedra +vertexes coordinates. Since the morphing algorithm applies a nonlinear +transformation over the surfaces (faces) of the polyhedron, each face has +to be divided into smaller ones. The morphing algorithm needs to transform +each vertex of these smaller faces individually. It's a very time consoming +task. + +In order to reduce calculation overload, and since all the macro faces of +the polyhedron are transformed by the same way, the generation is made by +creating only one face of the polyhedron, morphing it and then rotating it +around the polyhedron center. + +What we need to know is the face radius of the polyhedron (the radius of +the inscribed sphere) and the angle between the center of two adjacent +faces using the center of the sphere as the angle's vertex. + +The face radius of the regular polyhedra are known values which I decided +to not waste my time calculating. Following is a table of face radius for +the regular polyhedra with edge length = 1: + + TETRAHEDRON : 1/(2*sqrt(2))/sqrt(3) + CUBE : 1/2 + OCTAHEDRON : 1/sqrt(6) + DODECAHEDRON : T^2 * sqrt((T+2)/5) / 2 -> where T=(sqrt(5)+1)/2 + ICOSAHEDRON : (3*sqrt(3)+sqrt(15))/12 + +I've not found any reference about the mentioned angles, so I needed to +calculate them, not a trivial task until I figured out how :) +Curiously these angles are the same for the tetrahedron and octahedron. +A way to obtain this value is inscribing the tetrahedron inside the cube +by matching their vertexes. So you'll notice that the remaining unmatched +vertexes are in the same straight line starting in the cube/tetrahedron +center and crossing the center of each tetrahedron's face. At this point +it's easy to obtain the bigger angle of the isosceles triangle formed by +the center of the cube and two opposite vertexes on the same cube face. +The edges of this triangle have the following lenghts: sqrt(2) for the base +and sqrt(3)/2 for the other two other edges. So the angle we want is: + +-----------------------------------------------------------+ + | 2*ARCSIN(sqrt(2)/sqrt(3)) = 109.47122063449069174 degrees | + +-----------------------------------------------------------+ +For the cube this angle is obvious, but just for formality it can be +easily obtained because we also know it's isosceles edge lenghts: +sqrt(2)/2 for the base and 1/2 for the other two edges. So the angle we +want is: + +-----------------------------------------------------------+ + | 2*ARCSIN((sqrt(2)/2)/1) = 90.000000000000000000 degrees | + +-----------------------------------------------------------+ +For the octahedron we use the same idea used for the tetrahedron, but now +we inscribe the cube inside the octahedron so that all cubes's vertexes +matches excatly the center of each octahedron's face. It's now clear that +this angle is the same of the thetrahedron one: + +-----------------------------------------------------------+ + | 2*ARCSIN(sqrt(2)/sqrt(3)) = 109.47122063449069174 degrees | + +-----------------------------------------------------------+ +For the dodecahedron it's a little bit harder because it's only relationship +with the cube is useless to us. So we need to solve the problem by another +way. The concept of Face radius also exists on 2D polygons with the name +Edge radius: + Edge Radius For Pentagon (ERp) + ERp = (1/2)/TAN(36 degrees) * VRp = 0.6881909602355867905 + (VRp is the pentagon's vertex radio). + Face Radius For Dodecahedron + FRd = T^2 * sqrt((T+2)/5) / 2 = 1.1135163644116068404 +Why we need ERp? Well, ERp and FRd segments forms a 90 degrees angle, +completing this triangle, the lesser angle is a half of the angle we are +looking for, so this angle is: + +-----------------------------------------------------------+ + | 2*ARCTAN(ERp/FRd) = 63.434948822922009981 degrees | + +-----------------------------------------------------------+ +For the icosahedron we can use the same method used for dodecahedron (well +the method used for dodecahedron may be used for all regular polyhedra) + Edge Radius For Triangle (this one is well known: 1/3 of the triangle height) + ERt = sin(60)/3 = sqrt(3)/6 = 0.2886751345948128655 + Face Radius For Icosahedron + FRi= (3*sqrt(3)+sqrt(15))/12 = 0.7557613140761707538 +So the angle is: + +-----------------------------------------------------------+ + | 2*ARCTAN(ERt/FRi) = 41.810314895778596167 degrees | + +-----------------------------------------------------------+ + +*) + + +let scale = 0.3 + +let vect_mul (x1,y1,z1) (x2,y2,z2) = + (y1 *. z2 -. z1 *. y2, z1 *. x2 -. x1 *. z2, x1 *. y2 -. y1 *. x2) + +let sqr a = a *. a + +(* Increasing this values produces better image quality, the price is speed. *) +(* Very low values produces erroneous/incorrect plotting *) +let tetradivisions = 23 +let cubedivisions = 20 +let octadivisions = 21 +let dodecadivisions = 10 +let icodivisions = 15 + +let tetraangle = 109.47122063449069174 +let cubeangle = 90.000000000000000000 +let octaangle = 109.47122063449069174 +let dodecaangle = 63.434948822922009981 +let icoangle = 41.810314895778596167 + +let pi = acos (-1.) +let sqrt2 = sqrt 2. +let sqrt3 = sqrt 3. +let sqrt5 = sqrt 5. +let sqrt6 = sqrt 6. +let sqrt15 = sqrt 15. +let cossec36_2 = 0.8506508083520399322 +let cosd x = cos (float x /. 180. *. pi) +let sind x = sin (float x /. 180. *. pi) +let cos72 = cosd 72 +let sin72 = sind 72 +let cos36 = cosd 36 +let sin36 = sind 36 + +(*************************************************************************) + +let front_shininess = 60.0 +let front_specular = 0.7, 0.7, 0.7, 1.0 +let ambient = 0.0, 0.0, 0.0, 1.0 +let diffuse = 1.0, 1.0, 1.0, 1.0 +let position0 = 1.0, 1.0, 1.0, 0.0 +let position1 = -1.0,-1.0, 1.0, 0.0 +let lmodel_ambient = 0.5, 0.5, 0.5, 1.0 +let lmodel_twoside = true + +let materialRed = 0.7, 0.0, 0.0, 1.0 +let materialGreen = 0.1, 0.5, 0.2, 1.0 +let materialBlue = 0.0, 0.0, 0.7, 1.0 +let materialCyan = 0.2, 0.5, 0.7, 1.0 +let materialYellow = 0.7, 0.7, 0.0, 1.0 +let materialMagenta = 0.6, 0.2, 0.5, 1.0 +let materialWhite = 0.7, 0.7, 0.7, 1.0 +let materialGray = 0.2, 0.2, 0.2, 1.0 +let all_gray = Array.create 20 materialGray + +let vertex ~xf ~yf ~zf ~ampvr2 = + let xa = xf +. 0.01 and yb = yf +. 0.01 in + let xf2 = sqr xf and yf2 = sqr yf in + let factor = 1. -. (xf2 +. yf2) *. ampvr2 + and factor1 = 1. -. (sqr xa +. yf2) *. ampvr2 + and factor2 = 1. -. (xf2 +. sqr yb) *. ampvr2 in + let vertx = factor *. xf and verty = factor *. yf + and vertz = factor *. zf in + let neiax = factor1 *. xa -. vertx and neiay = factor1 *. yf -. verty + and neiaz = factor1 *. zf -. vertz and neibx = factor2 *. xf -. vertx + and neiby = factor2 *. yb -. verty and neibz = factor2 *. zf -. vertz in + GlDraw.normal3 (vect_mul (neiax, neiay, neiaz) (neibx, neiby, neibz)); + GlDraw.vertex3 (vertx, verty, vertz) + +let triangle ~edge ~amp ~divisions ~z = + let divi = float divisions in + let vr = edge *. sqrt3 /. 3. in + let ampvr2 = amp /. sqr vr + and zf = edge *. z in + let ax = edge *. (0.5 /. divi) + and ay = edge *. (-0.5 *. sqrt3 /. divi) + and bx = edge *. (-0.5 /. divi) in + for ri = 1 to divisions do + GlDraw.begins `triangle_strip; + for ti = 0 to ri - 1 do + vertex ~zf ~ampvr2 + ~xf:(float (ri-ti) *. ax +. float ti *. bx) + ~yf:(vr +. float (ri-ti) *. ay +. float ti *. ay); + vertex ~zf ~ampvr2 + ~xf:(float (ri-ti-1) *. ax +. float ti *. bx) + ~yf:(vr +. float (ri-ti-1) *. ay +. float ti *. ay) + done; + vertex ~xf:(float ri *. bx) ~yf:(vr +. float ri *. ay) ~zf ~ampvr2; + GlDraw.ends () + done + +let square ~edge ~amp ~divisions ~z = + let divi = float divisions in + let zf = edge *. z + and ampvr2 = amp /. sqr (edge *. sqrt2 /. 2.) in + for yi = 0 to divisions - 1 do + let yf = edge *. (-0.5 +. float yi /. divi) in + let yf2 = sqr yf in + let y = yf +. 1.0 /. divi *. edge in + let y2 = sqr y in + GlDraw.begins `quad_strip; + for xi = 0 to divisions do + let xf = edge *. (-0.5 +. float xi /. divi) in + vertex ~xf ~yf:y ~zf ~ampvr2; + vertex ~xf ~yf ~zf ~ampvr2 + done; + GlDraw.ends () + done + +let pentagon ~edge ~amp ~divisions ~z = + let divi = float divisions in + let zf = edge *. z + and ampvr2 = amp /. sqr(edge *. cossec36_2) in + let x = + Array.init 6 + ~f:(fun fi -> -. cos (float fi *. 2. *. pi /. 5. +. pi /. 10.) + /. divi *. cossec36_2 *. edge) + and y = + Array.init 6 + ~f:(fun fi -> sin (float fi *. 2. *. pi /. 5. +. pi /. 10.) + /. divi *. cossec36_2 *. edge) + in + for ri = 1 to divisions do + for fi = 0 to 4 do + GlDraw.begins `triangle_strip; + for ti = 0 to ri-1 do + vertex ~zf ~ampvr2 + ~xf:(float(ri-ti) *. x.(fi) +. float ti *. x.(fi+1)) + ~yf:(float(ri-ti) *. y.(fi) +. float ti *. y.(fi+1)); + vertex ~zf ~ampvr2 + ~xf:(float(ri-ti-1) *. x.(fi) +. float ti *. x.(fi+1)) + ~yf:(float(ri-ti-1) *. y.(fi) +. float ti *. y.(fi+1)) + done; + vertex ~xf:(float ri *. x.(fi+1)) ~yf:(float ri *. y.(fi+1)) ~zf ~ampvr2; + GlDraw.ends () + done + done + +let call_list list color = + GlLight.material ~face:`both (`diffuse color); + GlList.call list + +let draw_tetra ~amp ~divisions ~color = + let list = GlList.create `compile in + triangle ~edge:2.0 ~amp ~divisions ~z:(0.5 /. sqrt6); + GlList.ends(); + + call_list list color.(0); + GlMat.push(); + GlMat.rotate ~angle:180.0 ~z:1.0 (); + GlMat.rotate ~angle:(-.tetraangle) ~x:1.0 (); + call_list list color.(1); + GlMat.pop(); + GlMat.push(); + GlMat.rotate ~angle:180.0 ~y:1.0 (); + GlMat.rotate ~angle:(-180.0 +. tetraangle) ~x:0.5 ~y:(sqrt3 /. 2.) (); + call_list list color.(2); + GlMat.pop(); + GlMat.rotate ~angle:180.0 ~y:1.0 (); + GlMat.rotate ~angle:(-180.0 +. tetraangle) ~x:0.5 ~y:(-.sqrt3 /. 2.) (); + call_list list color.(3); + + GlList.delete list + +let draw_cube ~amp ~divisions ~color = + let list = GlList.create `compile in + square ~edge:2.0 ~amp ~divisions ~z:0.5; + GlList.ends (); + + call_list list color.(0); + for i = 1 to 3 do + GlMat.rotate ~angle:cubeangle ~x:1.0 (); + call_list list color.(i) + done; + GlMat.rotate ~angle:cubeangle ~y:1.0 (); + call_list list color.(4); + GlMat.rotate ~angle:(2.0 *. cubeangle) ~y:1.0 (); + call_list list color.(5); + + GlList.delete list + +let draw_octa ~amp ~divisions ~color = + let list = GlList.create `compile in + triangle ~edge:2.0 ~amp ~divisions ~z:(1.0 /. sqrt6); + GlList.ends (); + + let do_list (i,y) = + GlMat.push(); + GlMat.rotate ~angle:180.0 ~y:1.0 (); + GlMat.rotate ~angle:(-.octaangle) ~x:0.5 ~y (); + call_list list color.(i); + GlMat.pop() + in + call_list list color.(0); + GlMat.push(); + GlMat.rotate ~angle:180.0 ~z:1.0 (); + GlMat.rotate ~angle:(-180.0 +. octaangle) ~x:1.0 (); + call_list list color.(1); + GlMat.pop(); + List.iter [2, sqrt3 /. 2.0; 3, -.sqrt3 /. 2.0] ~f:do_list; + GlMat.rotate ~angle:180.0 ~x:1.0 (); + GlLight.material ~face:`both (`diffuse color.(4)); + GlList.call list; + GlMat.push(); + GlMat.rotate ~angle:180.0 ~z:1.0 (); + GlMat.rotate ~angle:(-180.0 +. octaangle) ~x:1.0 (); + GlLight.material ~face:`both (`diffuse color.(5)); + GlList.call list; + GlMat.pop(); + List.iter [6, sqrt3 /. 2.0; 7, -.sqrt3 /. 2.0] ~f:do_list; + + GlList.delete list + +let draw_dodeca ~amp ~divisions ~color = + let tau = (sqrt5 +. 1.0) /. 2.0 in + let list = GlList.create `compile in + pentagon ~edge:2.0 ~amp ~divisions + ~z:(sqr(tau) *. sqrt ((tau+.2.0)/.5.0) /. 2.0); + GlList.ends (); + + let do_list (i,angle,x,y) = + GlMat.push(); + GlMat.rotate ~angle:angle ~x ~y (); + call_list list color.(i); + GlMat.pop(); + in + GlMat.push (); + call_list list color.(0); + GlMat.rotate ~angle:180.0 ~z:1.0 (); + List.iter ~f:do_list + [ 1, -.dodecaangle, 1.0, 0.0; + 2, -.dodecaangle, cos72, sin72; + 3, -.dodecaangle, cos72, -.sin72; + 4, dodecaangle, cos36, -.sin36; + 5, dodecaangle, cos36, sin36 ]; + GlMat.pop (); + GlMat.rotate ~angle:180.0 ~x:1.0 (); + call_list list color.(6); + GlMat.rotate ~angle:180.0 ~z:1.0 (); + List.iter ~f:do_list + [ 7, -.dodecaangle, 1.0, 0.0; + 8, -.dodecaangle, cos72, sin72; + 9, -.dodecaangle, cos72, -.sin72; + 10, dodecaangle, cos36, -.sin36 ]; + GlMat.rotate ~angle:dodecaangle ~x:cos36 ~y:sin36 (); + call_list list color.(11); + + GlList.delete list + +let draw_ico ~amp ~divisions ~color = + let list = GlList.create `compile in + triangle ~edge:1.5 ~amp ~divisions + ~z:((3.0 *. sqrt3 +. sqrt15) /. 12.0); + GlList.ends (); + + let do_list1 i = + GlMat.rotate ~angle:180.0 ~y:1.0 (); + GlMat.rotate ~angle:(-180.0 +. icoangle) ~x:0.5 ~y:(sqrt3/.2.0) (); + call_list list color.(i) + and do_list2 i = + GlMat.rotate ~angle:180.0 ~y:1.0 (); + GlMat.rotate ~angle:(-180.0 +. icoangle) ~x:0.5 ~y:(-.sqrt3/.2.0) (); + call_list list color.(i) + and do_list3 i = + GlMat.rotate ~angle:180.0 ~z:1.0 (); + GlMat.rotate ~angle:(-.icoangle) ~x:1.0 (); + call_list list color.(i) + in + GlMat.push (); + call_list list color.(0); + GlMat.push (); + do_list3 1; + GlMat.push (); + do_list1 2; + GlMat.pop (); + do_list2 3; + GlMat.pop (); + GlMat.push (); + do_list1 4; + GlMat.push (); + do_list1 5; + GlMat.pop(); + do_list3 6; + GlMat.pop (); + do_list2 7; + GlMat.push (); + do_list2 8; + GlMat.pop (); + do_list3 9; + GlMat.pop (); + GlMat.rotate ~angle:180.0 ~x:1.0 (); + call_list list color.(10); + GlMat.push (); + do_list3 11; + GlMat.push (); + do_list1 12; + GlMat.pop (); + do_list2 13; + GlMat.pop (); + GlMat.push (); + do_list1 14; + GlMat.push (); + do_list1 15; + GlMat.pop (); + do_list3 16; + GlMat.pop (); + do_list2 17; + GlMat.push (); + do_list2 18; + GlMat.pop (); + do_list3 19; + + GlList.delete list + +class view = object (self) + val mutable smooth = true + val mutable step = 0. + val mutable obj = 1 + val mutable draw_object = fun ~amp -> () + val mutable magnitude = 0. + val mutable my_width = 640 + val mutable my_height = 480 + + method width = my_width + method height = my_height + + method draw = + let ratio = float self#height /. float self#width in + GlClear.clear [`color;`depth]; + GlMat.push (); + GlMat.translate () ~z:(-10.0); + GlMat.scale () ~x:(scale *. ratio) ~y:scale ~z:scale; + GlMat.translate () + ~x:(2.5 *. ratio *. sin (step *. 1.11)) + ~y:(2.5 *. cos (step *. 1.25 *. 1.11)); + GlMat.rotate ~angle:(step *. 100.) ~x:1.0 (); + GlMat.rotate ~angle:(step *. 95.) ~y:1.0 (); + GlMat.rotate ~angle:(step *. 90.) ~z:1.0 (); + draw_object ~amp:((sin step +. 1.0/.3.0) *. (4.0/.5.0) *. magnitude); + GlMat.pop(); + Gl.flush(); + Glut.swapBuffers (); + step <- step +. 0.05 + + method reshape ~w ~h = + my_width <- w; + my_height <- h; + GlDraw.viewport ~x:0 ~y:0 ~w:self#width ~h:self#height; + GlMat.mode `projection; + GlMat.load_identity(); + GlMat.frustum ~x:(-1.0, 1.0) ~y:(-1.0, 1.0) ~z:(5.0, 15.0); + GlMat.mode `modelview + + method keyboard key = + begin + match (char_of_int key) with + | '1' -> obj <- 1 + | '2' -> obj <- 2 + | '3' -> obj <- 3 + | '4' -> obj <- 4 + | '5' -> obj <- 5 + | _ -> match key with + | 10(*return*) -> smooth <- not smooth + | 27(*escape*) -> exit 0 + | _ -> (); + end; + self#pinit + + method pinit = + begin match obj with + 1 -> + draw_object <- draw_tetra + ~divisions:tetradivisions + ~color:[|materialRed; materialGreen; + materialBlue; materialWhite|]; + magnitude <- 2.5 + | 2 -> + draw_object <- draw_cube + ~divisions:cubedivisions + ~color:[|materialRed; materialGreen; materialCyan; + materialMagenta; materialYellow; materialBlue|]; + magnitude <- 2.0 + | 3 -> + draw_object <- draw_octa + ~divisions:octadivisions + ~color:[|materialRed; materialGreen; materialBlue; + materialWhite; materialCyan; materialMagenta; + materialGray; materialYellow|]; + magnitude <- 2.5 + | 4 -> + draw_object <- draw_dodeca + ~divisions:dodecadivisions + ~color:[|materialRed; materialGreen; materialCyan; + materialBlue; materialMagenta; materialYellow; + materialGreen; materialCyan; materialRed; + materialMagenta; materialBlue; materialYellow|]; + magnitude <- 2.0 + | 5 -> + draw_object <- draw_ico + ~divisions:icodivisions + ~color:[|materialRed; materialGreen; materialBlue; + materialCyan; materialYellow; materialMagenta; + materialRed; materialGreen; materialBlue; + materialWhite; materialCyan; materialYellow; + materialMagenta; materialRed; materialGreen; + materialBlue; materialCyan; materialYellow; + materialMagenta; materialGray|]; + magnitude <- 3.5 + | _ -> () + end; + GlDraw.shade_model (if smooth then `smooth else `flat) +end + +let main () = + List.iter ~f:print_string + [ "Morph 3D - Shows morphing platonic polyhedra\n"; + "Author: Marcelo Fernandes Vianna (vianna@cat.cbpf.br)\n"; + "Ported to LablGL by Jacques Garrigue\n"; + "Ported to lablglut by Issac Trotts\n\n"; + " [1] - Tetrahedron\n"; + " [2] - Hexahedron (Cube)\n"; + " [3] - Octahedron\n"; + " [4] - Dodecahedron\n"; + " [5] - Icosahedron\n"; + (* "[RETURN] - Toggle smooth/flat shading\n"; *) (* not working ... ??? *) + " [ESC] - Quit\n" ]; + flush stdout; + + ignore(Glut.init Sys.argv); + Glut.initDisplayMode ~alpha:false ~double_buffer:true ~depth:true (); + Glut.initWindowSize ~w:640 ~h:480; + ignore(Glut.createWindow ~title:"Morph 3D - Shows morphing platonic polyhedra"); + GlClear.depth 1.0; + GlClear.color (0.0, 0.0, 0.0); + GlDraw.color (1.0, 1.0, 1.0); + + GlClear.clear [`color;`depth]; + Gl.flush(); + Glut.swapBuffers(); + + List.iter ~f:(GlLight.light ~num:0) + [`ambient ambient; `diffuse diffuse; `position position0]; + List.iter ~f:(GlLight.light ~num:1) + [`ambient ambient; `diffuse diffuse; `position position1]; + GlLight.light_model (`ambient lmodel_ambient); + GlLight.light_model (`two_side lmodel_twoside); + List.iter ~f:Gl.enable + [`lighting;`light0;`light1;`depth_test;`normalize]; + + GlLight.material ~face:`both (`shininess front_shininess); + GlLight.material ~face:`both (`specular front_specular); + + GlMisc.hint `fog `fastest; + GlMisc.hint `perspective_correction `fastest; + GlMisc.hint `polygon_smooth `fastest; + + let view = new view in + view#pinit; + + Glut.displayFunc ~cb:(fun () -> view#draw); + Glut.reshapeFunc ~cb:(fun ~w ~h -> view#reshape w h); + let rec idle ~value = view#draw; Glut.timerFunc ~ms:20 ~cb:idle ~value:0 in + Glut.timerFunc ~ms:20 ~cb:idle ~value:0; + Glut.keyboardFunc ~cb:(fun ~key ~x ~y -> view#keyboard key); + Glut.mainLoop () + +let _ = main () diff --git a/LablGlut/examples/lablGL/planet.ml b/LablGlut/examples/lablGL/planet.ml new file mode 100644 index 0000000..2aac5dc --- /dev/null +++ b/LablGlut/examples/lablGL/planet.ml @@ -0,0 +1,125 @@ +(* $Id: planet.ml,v 1.1 2003-09-25 13:54:10 raffalli Exp $ *) +(* converted to lablglut by Issac Trotts on July 25, 2002 *) + +#load"unix.cma";; + +class planet = object (self) + val mutable year = 0.0 + val mutable day = 0.0 + val mutable eye = 0.0 + val mutable time = 0.0 + + method tick new_time = + if time = 0. then time <- new_time else + let diff = new_time -. time in + time <- new_time; + day <- mod_float (day +. diff *. 200.) 360.0; + year <- mod_float (year +. diff *. 20.) 360.0; + + method day_add = + day <- mod_float (day +. 10.0) 360.0 + method day_subtract = + day <- mod_float (day -. 10.0) 360.0 + method year_add = + year <- mod_float (year +. 5.0) 360.0 + method year_subtract = + year <- mod_float (year -. 5.0) 360.0 + method eye x = + eye <- x; self#display + + method display = + GlClear.clear [`color;`depth]; + + GlDraw.color (1.0, 1.0, 1.0); + GlMat.push(); + GlMat.rotate ~angle:eye ~x:1. (); +(* draw sun *) + GlLight.material ~face:`front (`specular (1.0,1.0,0.0,1.0)); + GlLight.material ~face:`front (`shininess 5.0); + GluQuadric.sphere ~radius:1.0 ~slices:32 ~stacks:32 (); +(* draw smaller planet *) + GlMat.rotate ~angle:year ~y:1.0 (); + GlMat.translate () ~x:3.0; + GlMat.rotate ~angle:day ~y:1.0 (); + GlDraw.color (0.0, 1.0, 1.0); + GlDraw.shade_model `flat; + GlLight.material ~face:`front(`shininess 128.0); + GluQuadric.sphere ~radius:0.2 ~slices:10 ~stacks:10 (); + GlDraw.shade_model `smooth; + GlMat.pop (); + Gl.flush (); + Glut.swapBuffers (); +end + +let myinit () = + let light_ambient = 0.5, 0.5, 0.5, 1.0 + and light_diffuse = 1.0, 0.8, 0.2, 1.0 + and light_specular = 1.0, 1.0, 1.0, 1.0 + (* light_position is NOT default value *) + and light_position = 1.0, 1.0, 1.0, 0.0 + in + List.iter (GlLight.light ~num:0) + [ `ambient light_ambient; `diffuse light_diffuse; + `specular light_specular; `position light_position ]; + GlFunc.depth_func `less; + List.iter Gl.enable [`lighting; `light0; `depth_test]; + GlDraw.shade_model `smooth + + +let my_reshape ~w ~h = + GlDraw.viewport ~x:0 ~y:0 ~w ~h; + GlMat.mode `projection; + GlMat.load_identity(); + GluMat.perspective ~fovy:60.0 ~aspect:(float w /. float h) ~z:(1.0,20.0); + GlMat.mode `modelview; + GlMat.load_identity(); + GlMat.translate () ~z:(-5.0) + +(* Main Loop + * Open window with initial window size, title bar, + * RGBA display mode, and handle input events. + *) + +let main () = + ignore(Glut.init Sys.argv); + Glut.initDisplayMode ~alpha:true ~double_buffer:true ~depth:true (); + Glut.initWindowSize ~w:700 ~h:500; + ignore(Glut.createWindow "Planet"); + + myinit (); + + let planet = new planet in + (* + let scale = + Scale.create top ~min:(-45.) ~max:45. ~orient:`Vertical + ~command:(planet#eye) ~showvalue:false ~highlightbackground:`Black in + *) + (* + bind togl ~events:[`Enter] ~action:(fun _ -> Focus.set togl); + bind scale ~events:[`Enter] ~action:(fun _ -> Focus.set scale); + bind togl ~events:[`KeyPress] ~fields:[`KeySymString] + *) + Glut.specialFunc ~cb:(fun ~key ~x ~y -> match key with + | Glut.KEY_LEFT -> planet#year_subtract + | Glut.KEY_RIGHT -> planet#year_add + | Glut.KEY_UP -> planet#day_add + | Glut.KEY_DOWN -> planet#day_subtract + | _ -> (); + planet#display); + Glut.keyboardFunc ~cb:(fun ~key ~x ~y -> match key with + | 27(*esc*) -> exit 0 + | _ -> ()); + (*Glut.timerFunc ~ms:20 + ~cb:(fun ~value -> planet#tick (Unix.gettimeofday()); planet#display) ~value:0;*) + let rec _timedUpdate ~value = + planet#tick (Unix.gettimeofday()); + Glut.postRedisplay(); + Glut.timerFunc ~ms:20 ~cb:_timedUpdate ~value:0 + in + Glut.timerFunc ~ms:20 ~cb:_timedUpdate ~value:0; + Glut.displayFunc ~cb:(fun () -> planet#display); + Glut.reshapeFunc ~cb:my_reshape; + my_reshape ~w:700 ~h:500; + Glut.mainLoop () + +let _ = Printexc.print main () diff --git a/LablGlut/examples/lablGL/scene.ml b/LablGlut/examples/lablGL/scene.ml new file mode 100644 index 0000000..e11d078 --- /dev/null +++ b/LablGlut/examples/lablGL/scene.ml @@ -0,0 +1,108 @@ +(* $Id: scene.ml,v 1.1 2003-09-25 13:54:10 raffalli Exp $ *) +(* converted to lablglut by Issac Trotts on July 25, 2002 *) + +(* Initialize material property and light source. + *) +let myinit () = + let light_ambient = 0.0, 0.0, 0.0, 1.0 + and light_diffuse = 1.0, 1.0, 1.0, 1.0 + and light_specular = 1.0, 1.0, 1.0, 1.0 + (* light_position is NOT default value *) + and light_position = 1.0, 1.0, 1.0, 0.0 + in + GlLight.light ~num:0 (`ambient light_ambient); + GlLight.light ~num:0 (`diffuse light_diffuse); + GlLight.light ~num:0 (`specular light_specular); + GlLight.light ~num:0 (`position light_position); + + GlFunc.depth_func `less; + List.iter Gl.enable [`lighting; `light0; `depth_test] + +let pi = acos (-1.) + +let solid_torus ~inner ~outer = + let slices = 32 and faces = 16 in + let slice_angle = 2.0 *. pi /. float slices + and face_angle = 2.0 *. pi /. float faces in + let vertex ~i ~j = + let angle1 = slice_angle *. float i + and angle2 = face_angle *. float j in + GlDraw.normal3 (cos angle1 *. cos angle2, + -. sin angle1 *. cos angle2, + sin angle2); + GlDraw.vertex3 + ((outer +. inner *. cos angle2) *. cos angle1, + -. (outer +. inner *. cos angle2) *. sin angle1, + inner *. sin angle2) + in + GlDraw.begins `quads; + for i = 0 to slices - 1 do + for j = 0 to faces - 1 do + vertex ~i ~j; + vertex ~i:(i+1) ~j; + vertex ~i:(i+1) ~j:(j+1); + vertex ~i ~j:(j+1); + done + done; + GlDraw.ends () + +let solid_cone ~radius ~height = + GluQuadric.cylinder ~base:radius ~top:0. ~height ~slices:15 ~stacks:10 () + +let solid_sphere ~radius = + GluQuadric.sphere ~radius ~slices:32 ~stacks:32 () + +let display () = + GlClear.clear [`color; `depth]; + + GlMat.push (); + GlMat.rotate ~angle:20.0 ~x:1.0 (); + + GlMat.push (); + GlMat.translate ~x:(-0.75) ~y:0.5 (); + GlMat.rotate ~angle:90.0 ~x:1.0 (); + solid_torus ~inner:0.275 ~outer:0.85; + GlMat.pop (); + + GlMat.push (); + GlMat.translate ~x:(-0.75) ~y:(-0.5) (); + GlMat.rotate ~angle:270.0 ~x:1.0 (); + solid_cone ~radius:1.0 ~height:2.0; + GlMat.pop (); + + GlMat.push (); + GlMat.translate ~x:0.75 ~z:(-1.0) (); + solid_sphere ~radius:1.0; + GlMat.pop (); + + GlMat.pop (); + Gl.flush () + +let my_reshape ~w ~h = + GlDraw.viewport ~x:0 ~y:0 ~w ~h; + GlMat.mode `projection; + GlMat.load_identity (); + if w <= h then + GlMat.ortho ~x:(-2.5,2.5) ~z:(-10.0,10.0) + ~y:(-2.5 *. float h /. float w, 2.5 *. float h /. float w) + else + GlMat.ortho ~y:(-2.5,2.5) ~z:(-10.0,10.0) + ~x:(-2.5 *. float w /. float h, 2.5 *. float w /. float h); + GlMat.mode `modelview + +(* Main Loop + * Open window with initial window size, title bar, + * RGBA display mode, and handle input events. + *) + +let main () = + ignore(Glut.init Sys.argv); + Glut.initDisplayMode ~alpha:true ~depth:true () ; + Glut.initWindowSize ~w:500 ~h:500 ; + ignore(Glut.createWindow "Scene"); + myinit (); + Glut.reshapeFunc ~cb:my_reshape ; + Glut.displayFunc ~cb:display ; + Glut.mainLoop () + +let _ = Printexc.print main () diff --git a/LablGlut/examples/lablGL/simple.ml b/LablGlut/examples/lablGL/simple.ml new file mode 100644 index 0000000..92a89ab --- /dev/null +++ b/LablGlut/examples/lablGL/simple.ml @@ -0,0 +1,31 @@ +(* $Id: simple.ml,v 1.1 2003-09-25 13:54:10 raffalli Exp $ *) + +(* open Tk *) + +let main () = + ignore(Glut.init Sys.argv); + Glut.initDisplayMode ~alpha:true ~depth:true () ; + Glut.initWindowSize ~w:500 ~h:500 ; + ignore(Glut.createWindow ~title:"lablglut & LablGL"); + Glut.displayFunc ~cb: + begin fun () -> (* display callback *) + GlClear.color (0.0, 0.0, 0.0); + GlClear.clear [`color]; + GlDraw.color (1.0, 1.0, 1.0); + GlMat.mode `projection; + GlMat.load_identity (); + GlMat.ortho ~x:(-1.0,1.0) ~y:(-1.0,1.0) ~z:(-1.0,1.0); + GlDraw.begins `polygon; + GlDraw.vertex ~x:(-0.5) ~y:(-0.5) (); + GlDraw.vertex ~x:(-0.5) ~y:(0.5) (); + GlDraw.vertex ~x:(0.5) ~y:(0.5) (); + GlDraw.vertex ~x:(0.5) ~y:(-0.5) (); + GlDraw.ends (); + Gl.flush () + end; + (* ignore (Timer.add ~ms:10000 ~callback:(fun () -> exit 0)); *) + Glut.mainLoop(); + ;; + +let _ = main () + diff --git a/LablGlut/examples/lablGL/test_glsl.ml b/LablGlut/examples/lablGL/test_glsl.ml new file mode 100644 index 0000000..a25db5c --- /dev/null +++ b/LablGlut/examples/lablGL/test_glsl.ml @@ -0,0 +1,143 @@ +(* Simple Demo for GLSL *) +(* This demo comes from this tutorial: *) +(* http://www.lighthouse3d.com/opengl/glsl/ *) +(* The tutorial and this demo was made by Ant籀nio Ramires Fernandes. *) +(* No restrictions apply to the use of this program. *) +(* Converted from C to OCaml by Florent Monnier. *) + +let changeSize ~w ~h = + (* Prevent a divide by zero, when window is too short + (you cant make a window of zero width). *) + let h = + if h = 0 + then 1 + else h + in + + let ratio = 1.0 *. float w /. float h in + + (* Reset the coordinate system before modifying *) + GlMat.mode `projection; + GlMat.load_identity(); + + (* Set the viewport to be the entire window *) + GlDraw.viewport 0 0 w h; + + (* Set the correct perspective. *) + GluMat.perspective 45.0 ratio (1.0, 1000.0); + GlMat.mode `modelview; +;; + + +let renderScene() = + GlClear.clear [`color; `depth]; + + GlMat.load_identity(); + GluMat.look_at + (0.0, 0.0, 5.0) + (0.0, 0.0, -1.0) + (0.0, 1.0, 0.0); + + let lpos = (1.0, 0.5, 1.0, 0.0) in + GlLight.light 0 (`position lpos); + Glut.solidTeapot 1.0; + + Glut.swapBuffers(); +;; + + +let processNormalKeys ~key ~x ~y = + if key = 27 then exit 0; +;; + + +let toon_frag = " +// simple toon fragment shader +varying vec3 normal, lightDir; + +vec4 toonify(in float intensity) +{ + vec4 color; + + if (intensity > 0.98) + color = vec4(0.9,0.9,0.9,1.0); + else if (intensity > 0.5) + color = vec4(0.4,0.4,0.8,1.0); + else if (intensity > 0.25) + color = vec4(0.3,0.3,0.5,1.0); + else + color = vec4(0.1,0.1,0.1,1.0); + + return(color); +} + +void main() +{ + float intensity; + vec3 norm; + + norm = normalize(normal); + intensity = max(dot(lightDir,norm),0.0); + + gl_FragColor = toonify(intensity); + // or use this line to get a classic lighting: + //gl_FragColor = intensity * vec4(0.9,0.2,0.0,1.0); +} +" + +let toon_vert = " +// simple toon vertex shader +varying vec3 normal, lightDir; + +void main() +{ + lightDir = normalize(vec3(gl_LightSource[0].position)); + normal = normalize(gl_NormalMatrix * gl_Normal); + + gl_Position = ftransform(); +} +" + + +let setShaders() = + let v = GlShader.create `vertex_shader + and f = GlShader.create `fragment_shader in + + GlShader.source v toon_vert; + GlShader.source f toon_frag; + + GlShader.compile v; + GlShader.compile f; + + let p = GlShader.create_program() in + GlShader.attach p f; + GlShader.attach p v; + + GlShader.link_program p; + GlShader.use_program p; +;; + + +(* main *) +let () = + ignore(Glut.init Sys.argv); + Glut.initDisplayMode + ~double_buffer:true + ~depth:true (); + Glut.initWindowPosition 100 100; + Glut.initWindowSize 320 320; + ignore(Glut.createWindow "simple GLSL demo"); + + Glut.displayFunc renderScene; + Glut.reshapeFunc changeSize; + Glut.keyboardFunc processNormalKeys; + Glut.idleFunc (Some renderScene); + + Gl.enable `depth_test; + GlClear.color (1.0, 1.0, 1.0); + + setShaders(); + + Glut.mainLoop(); +;; + diff --git a/LablGlut/examples/lablGL/texturesurf.ml b/LablGlut/examples/lablGL/texturesurf.ml new file mode 100644 index 0000000..98f5a7c --- /dev/null +++ b/LablGlut/examples/lablGL/texturesurf.ml @@ -0,0 +1,99 @@ +(* $Id: texturesurf.ml,v 1.1 2003-09-25 13:54:10 raffalli Exp $ *) +(* Converted to lablglut by Issac Trotts on July 25, 2002 *) + +open StdLabels + +let texpts = + [|[|0.0; 0.0; 0.0; 1.0|]; + [|1.0; 0.0; 1.0; 1.0|]|] + +let ctrlpoints = + [|[|-1.5; -1.5; 4.9; -0.5; -1.5; 2.0; 0.5; -1.5; -1.0; 1.5; -1.5; 2.0|]; + [|-1.5; -0.5; 1.0; -0.5; -0.5; 3.0; 0.5; -0.5; 0.0; 1.5; -0.5; -1.0|]; + [|-1.5; 0.5; 4.0; -0.5; 0.5; 0.0; 0.5; 0.5; 3.0; 1.5; 0.5; 4.0|]; + [|-1.5; 1.5; -2.0; -0.5; 1.5; -2.0; 0.5; 1.5; 0.0; 1.5; 1.5; -1.0|]|] + +let image_width = 64 +and image_height = 64 + +let pi = acos (-1.0) + +let display () = + GlClear.clear [`color;`depth]; + GlDraw.color (1.0,1.0,1.0); + GlMap.eval_mesh2 ~mode:`fill ~range1:(0,20) ~range2:(0,20); + Gl.flush (); + Glut.swapBuffers () + +let make_image () = + let image = + GlPix.create `ubyte ~height:image_height ~width:image_width ~format:`rgb in + let raw = GlPix.to_raw image + and pos = GlPix.raw_pos image in + for i = 0 to image_width - 1 do + let ti = 2.0 *. pi *. float i /. float image_width in + for j = 0 to image_height - 1 do + let tj = 2.0 *. pi *. float j /. float image_height in + Raw.sets raw ~pos:(pos ~x:j ~y:i) + (Array.map ~f:(fun x -> truncate (127.0 *. (1.0 +. x))) + [|sin ti; cos (2.0 *. ti); cos (ti +. tj)|]); + done; + done; + image + +let myinit () = + let ctrlpoints = Raw.of_matrix ~kind:`double ctrlpoints + and texpts = Raw.of_matrix ~kind:`double texpts in + GlMap.map2 ~target:`vertex_3 + (0.0, 1.0) ~order:4 (0.0, 1.0) ~order:4 ctrlpoints; + GlMap.map2 ~target:`texture_coord_2 + (0.0,1.0) ~order:2 (0.0,1.0) ~order:2 texpts; + Gl.enable `map2_texture_coord_2; + Gl.enable `map2_vertex_3; + GlMap.grid2 ~n1:20 ~range1:(0.0,1.0) ~n2:20 ~range2:(0.0,1.0); + let image = make_image () in + GlTex.env (`mode `decal); + List.iter ~f:(GlTex.parameter ~target:`texture_2d) + [ `wrap_s `repeat; + `wrap_t `repeat; + `mag_filter `nearest; + `min_filter `nearest ]; + GlTex.image2d image; + List.iter ~f:Gl.enable [`texture_2d;`depth_test;`normalize]; + GlDraw.shade_model `flat + +let my_reshape ~w ~h = + GlDraw.viewport ~x:0 ~y:0 ~w ~h; + GlMat.mode `projection; + GlMat.load_identity (); + let r = float h /. float w in + if w <= h then + GlMat.ortho ~x:(-4.0, 4.0) ~y:(-4.0 *. r, 4.0 *. r) ~z:(-4.0, 4.0) + else + GlMat.ortho ~x:(-4.0 /. r, 4.0 /. r) ~y:(-4.0, 4.0) ~z:(-4.0, 4.0); + GlMat.mode `modelview; + GlMat.load_identity (); + GlMat.rotate ~angle:85. ~x:1. ~y:1. ~z:1. () + +let main () = + ignore(Glut.init Sys.argv); + Glut.initDisplayMode ~alpha:true ~depth:true ~double_buffer:true () ; + Glut.initWindowSize ~w:300 ~h:300 ; + ignore(Glut.createWindow ~title:"Texture Surf"); + myinit (); + Glut.reshapeFunc ~cb:my_reshape ; + Glut.displayFunc ~cb:display ; + Glut.specialFunc ~cb:(fun ~key ~x ~y -> + match key with + | Glut.KEY_UP -> GlMat.rotate ~angle:(-5.) ~z:1.0 (); display () + | Glut.KEY_DOWN -> GlMat.rotate ~angle:(5.) ~z:1.0 (); display () + | Glut.KEY_LEFT -> GlMat.rotate ~angle:(5.) ~x:1.0 (); display () + | Glut.KEY_RIGHT -> GlMat.rotate ~angle:(-5.) ~x:1.0 (); display () + | _ -> ()); + Glut.keyboardFunc ~cb:(fun ~key ~x ~y -> + match key with + | 27 (*esc*) -> exit 0 + | _ -> ()); + Glut.mainLoop () + +let _ = main () diff --git a/LablGlut/examples/nehe/lesson2.ml b/LablGlut/examples/nehe/lesson2.ml new file mode 100644 index 0000000..b8a91ed --- /dev/null +++ b/LablGlut/examples/nehe/lesson2.ml @@ -0,0 +1,75 @@ +(* + * This code was created by Jeff Molofee '99 + * If you've found this code useful, please let me know. + * + * Visit Jeff at http://nehe.gamedev.net/ + * + * Ported to O'Caml/lablglut by Jeffrey Palmer 8/02 + * For port-specific issues, comments, etc., please + * contact jeffrey.palmer@acm.org + *) + +let init_gl width height = + GlDraw.shade_model `smooth; + GlClear.color (0.0, 0.0, 0.0); + GlClear.depth 1.0; + GlClear.clear [`color; `depth]; + Gl.enable `depth_test; + GlFunc.depth_func `lequal; + GlMisc.hint `perspective_correction `nicest + +let draw_gl_scene () = + GlClear.clear [`color; `depth]; + GlMat.load_identity (); + (* Draw the triangle *) + GlMat.translate3 (-1.5, 0.0, -6.0); + GlDraw.color (1.0, 1.0, 1.0); + GlDraw.begins `triangles; + GlDraw.vertex3 ( 0.0, 1.0, 0.0); + GlDraw.vertex3 (-1.0, -1.0, 0.0); + GlDraw.vertex3 ( 1.0, -1.0, 0.0); + GlDraw.ends (); + (* Draw the square *) + GlMat.translate3 (3.0, 0.0, 0.0); + GlDraw.begins `quads; + GlDraw.vertex3 (-1.0, 1.0, 0.0); + GlDraw.vertex3 ( 1.0, 1.0, 0.0); + GlDraw.vertex3 ( 1.0, -1.0, 0.0); + GlDraw.vertex3 (-1.0, -1.0, 0.0); + GlDraw.ends (); + Glut.swapBuffers () + +(* Handle window reshape events *) +let reshape_cb ~w ~h = + let + ratio = (float_of_int w) /. (float_of_int h) + in + GlDraw.viewport 0 0 w h; + GlMat.mode `projection; + GlMat.load_identity (); + GluMat.perspective 45.0 ratio (0.1, 100.0); + GlMat.mode `modelview; + GlMat.load_identity () + +(* Handle keyboard events *) +let keyboard_cb ~key ~x ~y = + match key with + | 27 (* ESC *) -> exit 0 + | _ -> () + +let main () = + let + width = 640 and + height = 480 + in + ignore (Glut.init Sys.argv); + Glut.initDisplayMode ~alpha:true ~depth:true ~double_buffer:true (); + Glut.initWindowSize width height; + ignore (Glut.createWindow "O'Caml OpenGL Lesson 2"); + Glut.displayFunc draw_gl_scene; + Glut.keyboardFunc keyboard_cb; + Glut.reshapeFunc reshape_cb; + init_gl width height; + Glut.mainLoop () + +let _ = main () diff --git a/LablGlut/examples/nehe/lesson3.ml b/LablGlut/examples/nehe/lesson3.ml new file mode 100644 index 0000000..611ad5c --- /dev/null +++ b/LablGlut/examples/nehe/lesson3.ml @@ -0,0 +1,78 @@ +(* + * This code was created by Jeff Molofee '99 + * If you've found this code useful, please let me know. + * + * Visit Jeff at http://nehe.gamedev.net/ + * + * Ported to O'Caml/lablglut by Jeffrey Palmer 8/02 + * For port-specific issues, comments, etc., please + * contact jeffrey.palmer@acm.org + *) + +let init_gl width height = + GlDraw.shade_model `smooth; + GlClear.color (0.0, 0.0, 0.0); + GlClear.depth 1.0; + GlClear.clear [`color; `depth]; + Gl.enable `depth_test; + GlFunc.depth_func `lequal; + GlMisc.hint `perspective_correction `nicest + +let draw_gl_scene () = + GlClear.clear [`color; `depth]; + GlMat.load_identity (); + (* Draw the triangle *) + GlMat.translate3 (-1.5, 0.0, -6.0); + GlDraw.begins `triangles; + GlDraw.color ( 1.0, 0.0, 0.0); + GlDraw.vertex3 ( 0.0, 1.0, 0.0); + GlDraw.color ( 0.0, 1.0, 0.0); + GlDraw.vertex3 (-1.0, -1.0, 0.0); + GlDraw.color ( 0.0, 0.0, 1.0); + GlDraw.vertex3 ( 1.0, -1.0, 0.0); + GlDraw.ends (); + (* Draw the square *) + GlMat.translate3 (3.0, 0.0, 0.0); + GlDraw.begins `quads; + GlDraw.color ( 0.5, 0.5, 1.0); + GlDraw.vertex3 (-1.0, 1.0, 0.0); + GlDraw.vertex3 ( 1.0, 1.0, 0.0); + GlDraw.vertex3 ( 1.0, -1.0, 0.0); + GlDraw.vertex3 (-1.0, -1.0, 0.0); + GlDraw.ends (); + Glut.swapBuffers () + +(* Handle window reshape events *) +let reshape_cb ~w ~h = + let + ratio = (float_of_int w) /. (float_of_int h) + in + GlDraw.viewport 0 0 w h; + GlMat.mode `projection; + GlMat.load_identity (); + GluMat.perspective 45.0 ratio (0.1, 100.0); + GlMat.mode `modelview; + GlMat.load_identity () + +(* Handle keyboard events *) +let keyboard_cb ~key ~x ~y = + match key with + | 27 (* ESC *) -> exit 0 + | _ -> () + +let main () = + let + width = 640 and + height = 480 + in + ignore (Glut.init Sys.argv); + Glut.initDisplayMode ~alpha:true ~depth:true ~double_buffer:true (); + Glut.initWindowSize width height; + ignore (Glut.createWindow "O'Caml OpenGL Lesson 3"); + Glut.displayFunc draw_gl_scene; + Glut.keyboardFunc keyboard_cb; + Glut.reshapeFunc reshape_cb; + init_gl width height; + Glut.mainLoop () + +let _ = main () diff --git a/LablGlut/examples/nehe/lesson4.ml b/LablGlut/examples/nehe/lesson4.ml new file mode 100644 index 0000000..faaa5a8 --- /dev/null +++ b/LablGlut/examples/nehe/lesson4.ml @@ -0,0 +1,91 @@ +(* + * This code was created by Jeff Molofee '99 + * If you've found this code useful, please let me know. + * + * Visit Jeff at http://nehe.gamedev.net/ + * + * Ported to O'Caml/lablglut by Jeffrey Palmer 8/02 + * For port-specific issues, comments, etc., please + * contact jeffrey.palmer@acm.org + *) + +let rtri = ref 0.0 +let rquad = ref 0.0 + +let init_gl width height = + GlDraw.shade_model `smooth; + GlClear.color (0.0, 0.0, 0.0); + GlClear.depth 1.0; + GlClear.clear [`color; `depth]; + Gl.enable `depth_test; + GlFunc.depth_func `lequal; + GlMisc.hint `perspective_correction `nicest + +let draw_gl_scene () = + GlClear.clear [`color; `depth]; + GlMat.load_identity (); + (* Draw the triangle *) + GlMat.translate3 (-1.5, 0.0, -6.0); + GlMat.rotate3 !rtri (0.0, 1.0, 0.0); + GlDraw.begins `triangles; + GlDraw.color ( 1.0, 0.0, 0.0); + GlDraw.vertex3 ( 0.0, 1.0, 0.0); + GlDraw.color ( 0.0, 1.0, 0.0); + GlDraw.vertex3 (-1.0, -1.0, 0.0); + GlDraw.color ( 0.0, 0.0, 1.0); + GlDraw.vertex3 ( 1.0, -1.0, 0.0); + GlDraw.ends (); + (* Draw the square *) + GlMat.load_identity (); + GlMat.translate3 (1.5, 0.0, -6.0); + GlMat.rotate3 !rquad (1.0, 0.0, 0.0); + GlDraw.begins `quads; + GlDraw.color ( 0.5, 0.5, 1.0); + GlDraw.vertex3 (-1.0, 1.0, 0.0); + GlDraw.vertex3 ( 1.0, 1.0, 0.0); + GlDraw.vertex3 ( 1.0, -1.0, 0.0); + GlDraw.vertex3 (-1.0, -1.0, 0.0); + GlDraw.ends (); + Glut.swapBuffers (); + rtri := !rtri +. 0.2; + rquad := !rquad -. 0.15 + +(* Handle window reshape events *) +let reshape_cb ~w ~h = + let + ratio = (float_of_int w) /. (float_of_int h) + in + GlDraw.viewport 0 0 w h; + GlMat.mode `projection; + GlMat.load_identity (); + GluMat.perspective 45.0 ratio (0.1, 100.0); + GlMat.mode `modelview; + GlMat.load_identity () + +(* Handle keyboard events *) +let keyboard_cb ~key ~x ~y = + match key with + | 27 (* ESC *) -> exit 0 + | _ -> () + +(* Draw the scene whever idle *) +let idle_cb () = + draw_gl_scene () + +let main () = + let + width = 640 and + height = 480 + in + ignore (Glut.init Sys.argv); + Glut.initDisplayMode ~alpha:true ~depth:true ~double_buffer:true (); + Glut.initWindowSize width height; + ignore (Glut.createWindow "O'Caml OpenGL Lesson 4"); + Glut.displayFunc draw_gl_scene; + Glut.keyboardFunc keyboard_cb; + Glut.reshapeFunc reshape_cb; + Glut.idleFunc(Some idle_cb); + init_gl width height; + Glut.mainLoop () + +let _ = main () diff --git a/LablGlut/examples/nehe/lesson5.ml b/LablGlut/examples/nehe/lesson5.ml new file mode 100644 index 0000000..e6e0c81 --- /dev/null +++ b/LablGlut/examples/nehe/lesson5.ml @@ -0,0 +1,148 @@ +(* + * This code was created by Jeff Molofee '99 + * If you've found this code useful, please let me know. + * + * Visit Jeff at http://nehe.gamedev.net/ + * + * Ported to O'Caml/lablglut by Jeffrey Palmer 8/02 + * For port-specific issues, comments, etc., please + * contact jeffrey.palmer@acm.org + *) + +let rtri = ref 0.0 +let rquad = ref 0.0 + +let init_gl width height = + GlDraw.shade_model `smooth; + GlClear.color (0.0, 0.0, 0.0); + GlClear.depth 1.0; + GlClear.clear [`color; `depth]; + Gl.enable `depth_test; + GlFunc.depth_func `lequal; + GlMisc.hint `perspective_correction `nicest + +let draw_gl_scene () = + GlClear.clear [`color; `depth]; + GlMat.load_identity (); + + (* Draw the pyramid *) + GlMat.translate3 (-1.5, 0.0, -6.0); + GlMat.rotate3 !rtri (0.0, 1.0, 0.0); + GlDraw.begins `triangles; + + GlDraw.color ( 1.0, 0.0, 0.0); + GlDraw.vertex3 ( 0.0, 1.0, 0.0); + GlDraw.color ( 0.0, 1.0, 0.0); + GlDraw.vertex3 (-1.0,-1.0, 1.0); + GlDraw.color ( 0.0, 0.0, 1.0); + GlDraw.vertex3 ( 1.0,-1.0, 1.0); + + GlDraw.color ( 1.0, 0.0, 0.0); + GlDraw.vertex3 ( 0.0, 1.0, 0.0); + GlDraw.color ( 0.0, 0.0, 1.0); + GlDraw.vertex3 ( 1.0,-1.0, 1.0); + GlDraw.color ( 0.0, 1.0, 0.0); + GlDraw.vertex3 ( 1.0,-1.0,-1.0); + + GlDraw.color ( 1.0, 0.0, 0.0); + GlDraw.vertex3 ( 0.0, 1.0, 0.0); + GlDraw.color ( 0.0, 1.0, 0.0); + GlDraw.vertex3 ( 1.0,-1.0,-1.0); + GlDraw.color ( 0.0, 0.0, 1.0); + GlDraw.vertex3 (-1.0,-1.0,-1.0); + + GlDraw.color ( 1.0, 0.0, 0.0); + GlDraw.vertex3 ( 0.0, 1.0, 0.0); + GlDraw.color ( 0.0, 0.0, 1.0); + GlDraw.vertex3 (-1.0,-1.0,-1.0); + GlDraw.color ( 0.0, 1.0, 0.0); + GlDraw.vertex3 (-1.0,-1.0, 1.0); + + GlDraw.ends (); + + (* Draw the square *) + GlMat.load_identity (); + GlMat.translate3 (1.5, 0.0, -7.0); + GlMat.rotate3 !rquad (1.0, 1.0, 1.0); + GlDraw.begins `quads; + + GlDraw.color (0.0,1.0,0.0); + GlDraw.vertex3 ( 1.0, 1.0,-1.0); + GlDraw.vertex3 (-1.0, 1.0,-1.0); + GlDraw.vertex3 (-1.0, 1.0, 1.0); + GlDraw.vertex3 ( 1.0, 1.0, 1.0); + + GlDraw.color (1.0,0.5,0.0); + GlDraw.vertex3 ( 1.0,-1.0, 1.0); + GlDraw.vertex3 (-1.0,-1.0, 1.0); + GlDraw.vertex3 (-1.0,-1.0,-1.0); + GlDraw.vertex3 ( 1.0,-1.0,-1.0); + + GlDraw.color (1.0,0.0,0.0); + GlDraw.vertex3 ( 1.0, 1.0, 1.0); + GlDraw.vertex3 (-1.0, 1.0, 1.0); + GlDraw.vertex3 (-1.0,-1.0, 1.0); + GlDraw.vertex3 ( 1.0,-1.0, 1.0); + + GlDraw.color (1.0,1.0,0.0); + GlDraw.vertex3 ( 1.0,-1.0,-1.0); + GlDraw.vertex3 (-1.0,-1.0,-1.0); + GlDraw.vertex3 (-1.0, 1.0,-1.0); + GlDraw.vertex3 ( 1.0, 1.0,-1.0); + + GlDraw.color (0.0,0.0,1.0); + GlDraw.vertex3 (-1.0, 1.0, 1.0); + GlDraw.vertex3 (-1.0, 1.0,-1.0); + GlDraw.vertex3 (-1.0,-1.0,-1.0); + GlDraw.vertex3 (-1.0,-1.0, 1.0); + + GlDraw.color (1.0,0.0,1.0); + GlDraw.vertex3 ( 1.0, 1.0,-1.0); + GlDraw.vertex3 ( 1.0, 1.0, 1.0); + GlDraw.vertex3 ( 1.0,-1.0, 1.0); + GlDraw.vertex3 ( 1.0,-1.0,-1.0); + + GlDraw.ends (); + Glut.swapBuffers (); + rtri := !rtri +. 0.2; + rquad := !rquad -. 0.15 + +(* Handle window reshape events *) +let reshape_cb ~w ~h = + let + ratio = (float_of_int w) /. (float_of_int h) + in + GlDraw.viewport 0 0 w h; + GlMat.mode `projection; + GlMat.load_identity (); + GluMat.perspective 45.0 ratio (0.1, 100.0); + GlMat.mode `modelview; + GlMat.load_identity () + +(* Handle keyboard events *) +let keyboard_cb ~key ~x ~y = + match key with + | 27 (* ESC *) -> exit 0 + | _ -> () + +(* Draw the scene whever idle *) +let idle_cb () = + draw_gl_scene () + +let main () = + let + width = 640 and + height = 480 + in + ignore (Glut.init Sys.argv); + Glut.initDisplayMode ~alpha:true ~depth:true ~double_buffer:true (); + Glut.initWindowSize width height; + ignore (Glut.createWindow "O'Caml OpenGL Lesson 5"); + Glut.displayFunc draw_gl_scene; + Glut.keyboardFunc keyboard_cb; + Glut.reshapeFunc reshape_cb; + Glut.idleFunc(Some idle_cb); + init_gl width height; + Glut.mainLoop () + +let _ = main () diff --git a/LablGlut/lgcompile b/LablGlut/lgcompile new file mode 100755 index 0000000..2b19515 --- /dev/null +++ b/LablGlut/lgcompile @@ -0,0 +1,21 @@ +#!/usr/bin/env perl + +# compile a single-file lablglut demo + +sub sys { + $cmd = @_[0]; + print "$cmd\n"; + system $cmd; +} + +$bname = shift @ARGV; +$bname =~ s/\.ml$//; + +$OCAML = $ENV{OCAML}; + +sys("ocamlc -I $OCAML/lablglut -I $OCAML/lablGL -g -c $bname.ml") or +sys("ocamlc -I $OCAML/lablglut -I $OCAML/lablGL -g -o $bname " . + "$OCAML/lablglut/lablglut.cma $OCAML/lablGL/lablgl.cma $bname.cmo") or +sys("rm $bname.{cmi,cmo}") or +# sys("ocamldebug $bname"); + diff --git a/LablGlut/src/.cvsignore b/LablGlut/src/.cvsignore new file mode 100644 index 0000000..abd517b --- /dev/null +++ b/LablGlut/src/.cvsignore @@ -0,0 +1 @@ +lablglut lablgluttop* dll* *.lib diff --git a/LablGlut/src/.depend b/LablGlut/src/.depend new file mode 100644 index 0000000..775b6fd --- /dev/null +++ b/LablGlut/src/.depend @@ -0,0 +1,12 @@ +gl_constants.cmo: gl_constants.cmi +gl_constants.cmx: gl_constants.cmi +glocaml.cmo: glutcaml.cmi +glocaml.cmx: glutcaml.cmx +glu_constants.cmo: glu_constants.cmi +glu_constants.cmx: glu_constants.cmi +glut.cmo: glut.cmi +glut.cmx: glut.cmi +glut_constants.cmo: glut_constants.cmi +glut_constants.cmx: glut_constants.cmi +glutcaml.cmo: glutcaml.cmi +glutcaml.cmx: glutcaml.cmi diff --git a/LablGlut/src/Makefile b/LablGlut/src/Makefile new file mode 100644 index 0000000..ab564a2 --- /dev/null +++ b/LablGlut/src/Makefile @@ -0,0 +1,94 @@ +# Include shared parts +TOPDIR = ../.. +include $(TOPDIR)/Makefile.common + +# Composite options +INCLUDES = $(GLINCLUDES) $(XINCLUDES) -I$(SRCDIR) +LIBS = $(GLUTLIBS) $(GLLIBS) $(XLIBS) +LIBDIRS = + +OCAMLINC= + +# Files +LIBOBJS = glut.cmo +OPTOBJS = $(LIBOBJS:.cmo=.cmx) +COBJS = wrap_glut$(XO) + +all: lib lablgluttop$(XE) lablglut$(XB) + +opt: libopt + +lib: lablglut.cma + +libopt: lablglut.cmxa + +ifeq ($(TOOLCHAIN), msvc) +liblablglut$(XA): $(COBJS) + $(MKLIB)$@ $(COBJS) +dlllablglut.dll: $(COBJS:$(XO)=.d$(XO)) + $(MKDLL)$@ $(COBJS:$(XO)=.d$(XO)) $(GLUTLIBS) $(GLLIBS) $(OCAMLDLL) +lablglut.cma: liblablglut$(XA) dlllablglut.dll $(LIBOBJS) ../../Makefile.config + $(LINKER) -a -o $@ $(LIBOBJS) \ + -cclib -llablglut -dllib -llablglut \ + -cclib "$(GLLIBS)" -cclib "$(GLUTLIBS)" +lablglut.cmxa: liblablglut$(XA) $(OPTOBJS) ../../Makefile.config + $(OPTLINK) -a -o $@ $(OPTOBJS) -cclib -llablglut \ + -cclib "$(GLLIBS)" -cclib "$(GLUTLIBS)" +else +liblablglut$(XA): lablglut.cma +lablglut.cma: $(COBJS) $(LIBOBJS) ../../Makefile.config + $(LIBRARIAN) -o lablglut $(COBJS) $(LIBOBJS) $(GLUTLIBS) $(GLLIBS) $(XLIBS) +lablglut.cmxa: $(COBJS) $(OPTOBJS) ../../Makefile.config + $(LIBRARIAN) -o lablglut $(COBJS) $(OPTOBJS) $(GLUTLIBS) $(GLLIBS) $(XLIBS) +endif + +lablgluttop$(XE): lablglut.cma + ocamlmktop $(CUSTOMTOP) -I . -I $(SRCDIR) $(OCAMLINC) -o $@ \ + lablglut.cma lablgl.cma + +lablglut: $(CONFIG) Makefile liblablglut$(XA) + $(MAKE) INSTALLDIR="$(INSTALLDIR)" real-$@ + +real-lablglut: + @echo generate lablglut + echo "#!/bin/sh" > lablglut + echo "# toplevel with lablGL and LablGlut" >> lablglut + if test -f dlllablglut$(XS); then \ + echo 'exec ocaml -I "$(INSTALLDIR)" lablgl.cma lablglut.cma $$*' >> lablglut; \ + else echo 'exec "$(INSTALLDIR)/lablgluttop" -I "$(INSTALLDIR)" $$*' >> lablglut; fi + chmod 755 lablglut + +install: + @if test -f lablglut.cma; then $(MAKE) real-install; fi + +preinstall: + if test -d "$(INSTALLDIR)"; then : ; else mkdir -p "$(INSTALLDIR)"; fi + cp $(LIBOBJS:.cmo=.ml) $(LIBOBJS:.cmo=.mli) "$(INSTALLDIR)" + cp liblablglut$(XA) "$(INSTALLDIR)" + cd "$(INSTALLDIR)" && $(RANLIB) liblablglut$(XA) + @if test -f dlllablglut$(XS); then $(MAKE) installdll; \ + else $(MAKE) installtop; fi + cp lablglut$(XB) "$(BINDIR)" + +real-install: preinstall + cp $(LIBOBJS:.cmo=.cmi) lablglut.cma "$(INSTALLDIR)" + @if test -f lablglut.cmxa; then $(MAKE) installopt; fi + +installdll: + cp dlllablglut$(XS) "$(DLLDIR)" + +installtop: + cp lablgluttop$(XE) "$(INSTALLDIR)" + +installopt: + cp lablglut.cmxa lablglut$(XA) $(LIBOBJS:.cmo=.cmx) "$(INSTALLDIR)" + cd "$(INSTALLDIR)" && $(RANLIB) lablglut$(XA) + +clean: + rm -f *.cm* *.o *.obj *.a lib*.lib *.so *.dll *.exe *.opt \ + *_tags.c *_tags.h *~ lablgluttop$(EX) lablglut + +depend: + ocamldep -pp camlp4o *.ml *.mli > .depend + +include .depend diff --git a/LablGlut/src/glut.ml b/LablGlut/src/glut.ml new file mode 100644 index 0000000..5b0e3d5 --- /dev/null +++ b/LablGlut/src/glut.ml @@ -0,0 +1,987 @@ +(* ==== types ==== *) + +type button_t = + | LEFT_BUTTON + | MIDDLE_BUTTON + | RIGHT_BUTTON + | OTHER_BUTTON of int + +type mouse_button_state_t = + | DOWN + | UP + +type special_key_t = + | KEY_F1 + | KEY_F2 + | KEY_F3 + | KEY_F4 + | KEY_F5 + | KEY_F6 + | KEY_F7 + | KEY_F8 + | KEY_F9 + | KEY_F10 + | KEY_F11 + | KEY_F12 + (* directional keys *) + | KEY_LEFT + | KEY_UP + | KEY_RIGHT + | KEY_DOWN + | KEY_PAGE_UP + | KEY_PAGE_DOWN + | KEY_HOME + | KEY_END + | KEY_INSERT + (* for undefined keys *) + | KEY_OTHER of int + +type entry_exit_state_t = + | LEFT + | ENTERED + +type menu_state_t = + | MENU_NOT_IN_USE + | MENU_IN_USE + +type visibility_state_t = + | NOT_VISIBLE + | VISIBLE + +type window_status_t = + | HIDDEN + | FULLY_RETAINED + | PARTIALLY_RETAINED + | FULLY_COVERED + +type color_index_component_t = + | RED + | GREEN + | BLUE + +type layer_t = + | NORMAL + | OVERLAY + +type font_t = + | STROKE_ROMAN + | STROKE_MONO_ROMAN + | BITMAP_9_BY_15 + | BITMAP_8_BY_13 + | BITMAP_TIMES_ROMAN_10 + | BITMAP_TIMES_ROMAN_24 + | BITMAP_HELVETICA_10 + | BITMAP_HELVETICA_12 + | BITMAP_HELVETICA_18 + +type glut_get_t = + | WINDOW_X + | WINDOW_Y + | WINDOW_WIDTH + | WINDOW_HEIGHT + | WINDOW_BUFFER_SIZE + | WINDOW_STENCIL_SIZE + | WINDOW_DEPTH_SIZE + | WINDOW_RED_SIZE + | WINDOW_GREEN_SIZE + | WINDOW_BLUE_SIZE + | WINDOW_ALPHA_SIZE + | WINDOW_ACCUM_RED_SIZE + | WINDOW_ACCUM_GREEN_SIZE + | WINDOW_ACCUM_BLUE_SIZE + | WINDOW_ACCUM_ALPHA_SIZE + | WINDOW_DOUBLEBUFFER + | WINDOW_RGBA + | WINDOW_PARENT + | WINDOW_NUM_CHILDREN + | WINDOW_COLORMAP_SIZE + | WINDOW_NUM_SAMPLES + | WINDOW_STEREO + | WINDOW_CURSOR + | SCREEN_WIDTH + | SCREEN_HEIGHT + | SCREEN_WIDTH_MM + | SCREEN_HEIGHT_MM + | MENU_NUM_ITEMS + (* | DISPLAY_MODE_POSSIBLE : use getBool *) + | INIT_WINDOW_X + | INIT_WINDOW_Y + | INIT_WINDOW_WIDTH + | INIT_WINDOW_HEIGHT + | INIT_DISPLAY_MODE + | ELAPSED_TIME + | WINDOW_FORMAT_ID + +type glut_get_bool_t = + | DISPLAY_MODE_POSSIBLE + +let rgb = 0;; +let rgba = rgb;; (* same as in glut.h *) +let index = 1;; +let single = 0;; +let double = 2;; +let accum = 4;; +let alpha = 8;; +let depth = 16;; +let stencil = 32;; +let multisample = 128;; +let stereo = 256;; +let luminance = 512;; + +type device_get_t = + | HAS_KEYBOARD + | HAS_MOUSE + | HAS_SPACEBALL + | HAS_DIAL_AND_BUTTON_BOX + | HAS_TABLET + | NUM_MOUSE_BUTTONS + | NUM_SPACEBALL_BUTTONS + | NUM_BUTTON_BOX_BUTTONS + | NUM_DIALS + | NUM_TABLET_BUTTONS + | DEVICE_IGNORE_KEY_REPEAT + | DEVICE_KEY_REPEAT + | HAS_JOYSTICK + | OWNS_JOYSTICK + | JOYSTICK_BUTTONS + | JOYSTICK_AXES + | JOYSTICK_POLL_RATE + +type layerget_t = + | OVERLAY_POSSIBLE + (* | LAYER_IN_USE : use layerGetInUse *) + | HAS_OVERLAY + (* | TRANSPARENT_INDEX : use layerGetTransparentIndex *) + | NORMAL_DAMAGED + | OVERLAY_DAMAGED + +type video_resize_t = + | VIDEO_RESIZE_POSSIBLE + | VIDEO_RESIZE_IN_USE + | VIDEO_RESIZE_X_DELTA + | VIDEO_RESIZE_Y_DELTA + | VIDEO_RESIZE_WIDTH_DELTA + | VIDEO_RESIZE_HEIGHT_DELTA + | VIDEO_RESIZE_X + | VIDEO_RESIZE_Y + | VIDEO_RESIZE_WIDTH + | VIDEO_RESIZE_HEIGHT + +type get_modifiers_t = + | ACTIVE_SHIFT + | ACTIVE_CTRL + | ACTIVE_ALT + +let active_shift = 1 +let active_ctrl = 2 +let active_alt = 4 + +type cursor_t = + (* Basic arrows. *) + | CURSOR_RIGHT_ARROW + | CURSOR_LEFT_ARROW + (* Symbolic cursor shapes. *) + | CURSOR_INFO + | CURSOR_DESTROY + | CURSOR_HELP + | CURSOR_CYCLE + | CURSOR_SPRAY + | CURSOR_WAIT + | CURSOR_TEXT + | CURSOR_CROSSHAIR + (* Directional cursors. *) + | CURSOR_UP_DOWN + | CURSOR_LEFT_RIGHT + (* Sizing cursors. *) + | CURSOR_TOP_SIDE + | CURSOR_BOTTOM_SIDE + | CURSOR_LEFT_SIDE + | CURSOR_RIGHT_SIDE + | CURSOR_TOP_LEFT_CORNER + | CURSOR_TOP_RIGHT_CORNER + | CURSOR_BOTTOM_RIGHT_CORNER + | CURSOR_BOTTOM_LEFT_CORNER + | CURSOR_INHERIT (* inherit cursor from parent window *) + | CURSOR_NONE (* blank cursor *) + | CURSOR_FULL_CROSSHAIR (* full-screen crosshair : if available *) + +type game_mode_t = + | GAME_MODE_ACTIVE + | GAME_MODE_POSSIBLE + | GAME_MODE_WIDTH + | GAME_MODE_HEIGHT + | GAME_MODE_PIXEL_DEPTH + | GAME_MODE_REFRESH_RATE + | GAME_MODE_DISPLAY_CHANGED + +type key_repeat_t = + | KEY_REPEAT_OFF + | KEY_REPEAT_ON + | KEY_REPEAT_DEFAULT + +exception BadEnum of string +exception InvalidState of string +exception OverlayNotInUse of string + +open Printf;; + +(* ==== file-local variables ==== *) + +let is_init = ref false;; +let is_displayModeInit = ref false;; +let is_windowSizeInit = ref false;; +let is_windowPositionInit = ref false;; +let has_createdWindow = ref false;; + + (* === GLUT initialization sub-API. === *) +external _glutInit : int -> string array -> int = "ml_glutInit" + +let init ~argv = + if !is_init then argv else begin + is_init := true; + let argc = Array.length argv in + let argv = Array.append argv [|""|] in + let argc = _glutInit argc argv in + Array.sub argv 0 argc + end + +external _glutInitDisplayMode : + double_buffer:bool -> + index:bool -> + accum:bool -> + alpha:bool -> + depth:bool -> + stencil:bool -> + multisample:bool -> + stereo:bool -> + luminance:bool -> + unit = + "bytecode_glutInitDisplayMode" + "native_glutInitDisplayMode" + +let initDisplayMode + ?(double_buffer=false) + ?(index=false) + ?(accum=false) + ?(alpha=false) + ?(depth=false) + ?(stencil=false) + ?(multisample=false) + ?(stereo=false) + ?(luminance=false) + dummy_unit + = + is_displayModeInit := true; + _glutInitDisplayMode + double_buffer + index + accum + alpha + depth + stencil + multisample + stereo + luminance + ;; + +external _glutInitWindowSize : int->int->unit = "ml_glutInitWindowSize" + +external _glutInitWindowPosition : int->int->unit = "ml_glutInitWindowPosition" +let initWindowPosition ~x ~y = + is_windowPositionInit := true; + _glutInitWindowPosition x y;; + +let initWindowSize ~w ~h = + is_windowSizeInit := true; + _glutInitWindowSize w h;; + +external mainLoop : unit->unit = "ml_glutMainLoop" + + (* === GLUT window sub-API. === *) + +external _glutCreateWindow : string->int = "ml_glutCreateWindow" + +let createWindow ~title = + has_createdWindow := true; + let winid = _glutCreateWindow title in + winid;; + +external postRedisplay : unit->unit = + "ml_glutPostRedisplay" +external swapBuffers : unit->unit = + "ml_glutSwapBuffers" +external createSubWindow: win:int->x:int->y:int->w:int->h:int->int = + "ml_glutCreateSubWindow" +external destroyWindow: win:int -> unit = + "ml_glutDestroyWindow" +external setWindow: win:int -> unit = + "ml_glutSetWindow" +external getWindow: unit -> int = + "ml_glutGetWindow" +external setWindowTitle: title:string -> unit = + "ml_glutSetWindowTitle" +external setIconTitle: title:string -> unit = + "ml_glutSetIconTitle" +external positionWindow: x:int -> y:int -> unit = + "ml_glutPositionWindow" +external reshapeWindow: w:int -> h:int -> unit = + "ml_glutReshapeWindow" +external popWindow: unit -> unit = + "ml_glutPopWindow" +external pushWindow: unit -> unit = + "ml_glutPushWindow" +external iconifyWindow: unit -> unit = + "ml_glutIconifyWindow" +external showWindow: unit -> unit = + "ml_glutShowWindow" +external hideWindow: unit -> unit = + "ml_glutHideWindow" +external fullScreen: unit -> unit = + "ml_glutFullScreen" + +external _setCursor: c:int -> unit = "ml_glutSetCursor" +let setCursor c = + let ic = match c with + (* Basic arrows. *) + | CURSOR_RIGHT_ARROW -> 0 (* values from glut.h *) + | CURSOR_LEFT_ARROW -> 1 + (* Symbolic cursor shapes. *) + | CURSOR_INFO -> 2 + | CURSOR_DESTROY -> 3 + | CURSOR_HELP -> 4 + | CURSOR_CYCLE -> 5 + | CURSOR_SPRAY -> 6 + | CURSOR_WAIT -> 7 + | CURSOR_TEXT -> 8 + | CURSOR_CROSSHAIR -> 9 + (* Directional cursors. *) + | CURSOR_UP_DOWN -> 10 + | CURSOR_LEFT_RIGHT -> 11 + (* Sizing cursors. *) + | CURSOR_TOP_SIDE -> 12 + | CURSOR_BOTTOM_SIDE -> 13 + | CURSOR_LEFT_SIDE -> 14 + | CURSOR_RIGHT_SIDE -> 15 + | CURSOR_TOP_LEFT_CORNER -> 16 + | CURSOR_TOP_RIGHT_CORNER -> 17 + | CURSOR_BOTTOM_RIGHT_CORNER -> 18 + | CURSOR_BOTTOM_LEFT_CORNER -> 19 + | CURSOR_INHERIT -> 100 + | CURSOR_NONE -> 101 + | CURSOR_FULL_CROSSHAIR -> 102 + in _setCursor ic + ;; + + (* === GLUT overlay sub-API. === *) +external establishOverlay: unit->unit = "ml_glutEstablishOverlay" +external removeOverlay: unit->unit = "ml_glutRemoveOverlay" +external postOverlayRedisplay: unit->unit = "ml_glutPostOverlayRedisplay" +external showOverlay: unit->unit = "ml_glutShowOverlay" +external hideOverlay: unit->unit = "ml_glutHideOverlay" + +external _useLayer: int -> unit = "ml_glutUseLayer" +let useLayer layer = _useLayer (match layer with NORMAL -> 0 | OVERLAY -> 1) + + (* === GLUT menu sub-API. === *) + +external createMenu: cb:(value:int -> unit) ->int = + "ml_glutCreateMenu" +external destroyMenu: menu:int->unit = + "ml_glutDestroyMenu" +external getMenu: unit->int = + "ml_glutGetMenu" +external setMenu: menu:int->unit = + "ml_glutSetMenu" +external addMenuEntry: label:string->value:int->unit = + "ml_glutAddMenuEntry" +external addSubMenu: label:string->submenu:int->unit = + "ml_glutAddSubMenu" +external changeToMenuEntry: item:int->label:string->value:int->unit = + "ml_glutChangeToMenuEntry" +external changeToSubMenu: item:int->label:string->submenu:int->unit = + "ml_glutChangeToSubMenu" +external removeMenuItem: item:int->unit= + "ml_glutRemoveMenuItem" + +let int_of_button b = match b with + | LEFT_BUTTON -> 0 + | MIDDLE_BUTTON -> 1 + | RIGHT_BUTTON -> 2 + | OTHER_BUTTON n -> n + +let b2i b = int_of_button b;; + +external _attachMenu: button:int->unit= "ml_glutAttachMenu" +let attachMenu ~button = _attachMenu (b2i button);; + +external _detachMenu: button:int->unit= "ml_glutDetachMenu" +let detachMenu ~button = _detachMenu (b2i button);; + + (* === GLUT window callback sub-API. === *) + +let window_wrapper cbFunc wr = + let table = Hashtbl.create 3 in + fun ~cb -> + Hashtbl.add table (getWindow()) cb; + cbFunc ~cb:(wr (fun () -> Hashtbl.find table (getWindow()))) + +external _displayFunc : cb:(unit->unit)->unit = "ml_glutDisplayFunc" +let displayFunc = window_wrapper _displayFunc (fun cb () -> cb () ()) + +external _reshapeFunc : cb:(w:int->h:int->unit)->unit = "ml_glutReshapeFunc" +let reshapeFunc = window_wrapper _reshapeFunc (fun cb ~w -> cb () ~w) + +external _keyboardFunc : cb:(key:int->x:int->y:int->unit)->unit = + "ml_glutKeyboardFunc" +let keyboardFunc = window_wrapper _keyboardFunc (fun cb ~key -> cb () ~key) + +external _glutMouseFunc : cb:(int -> int -> int -> int -> unit)->unit = + "ml_glutMouseFunc" +let mouse_cb_wrapper user_func ibutton istate x y = + let b = match ibutton with + | 0 -> LEFT_BUTTON + | 1 -> MIDDLE_BUTTON + | 2 -> RIGHT_BUTTON + | n -> OTHER_BUTTON n in + let s = match istate with + | 0 -> DOWN + | 1 -> UP + | _ -> raise (BadEnum "istate in mouse_cb_wrapper") in + user_func () ~button:b ~state:s ~x ~y;; +let mouseFunc = window_wrapper _glutMouseFunc mouse_cb_wrapper + +let eta_x cb ~x = cb () ~x + +external _motionFunc : cb:(x:int->y:int->unit)->unit = "ml_glutMotionFunc" +let motionFunc = window_wrapper _motionFunc eta_x + +external _passiveMotionFunc : cb:(x:int->y:int->unit)->unit = + "ml_glutPassiveMotionFunc" +let passiveMotionFunc = window_wrapper _passiveMotionFunc eta_x + +let eta_state cb ~state = cb () ~state + +external _entryFunc : cb:(state:entry_exit_state_t->unit)->unit = + "ml_glutEntryFunc" +let entryFunc = window_wrapper _entryFunc eta_state + +external _visibilityFunc : cb:(state:visibility_state_t->unit)->unit = + "ml_glutVisibilityFunc" +let visibilityFunc = window_wrapper _visibilityFunc eta_state + +(* idleFunc is for the entire program, not just a single window, + so its name does not depend on the window id *) +external _glutIdleFunc:(unit->unit)->unit="ml_glutIdleFunc" + +external _setIdleFuncToNull:unit->unit="ml_glutSetIdleFuncToNull" +let idleFunc ~cb = + match cb with + | None -> _setIdleFuncToNull(); + | Some cb -> + begin + _glutIdleFunc cb; + end +;; + +(* timerFunc is non-window-dependent *) + +external _timerFunc : int -> int -> unit = "ml_glutTimerFunc" + +external init_timerFunc : (int -> unit) -> unit = "init_glutTimerFunc_cb" + +let timer_hashtbl = Hashtbl.create 101 + +let real_call_back i = + Hashtbl.find timer_hashtbl i () + +let _ = + init_timerFunc real_call_back + +let timer_count = ref 0 + +let timerFunc ~ms ~cb:(cb:(value:'a -> unit)) ~value = + let i = !timer_count in + incr timer_count; + Hashtbl.add timer_hashtbl i (fun () -> + Hashtbl.remove timer_hashtbl i; + cb value); + _timerFunc ms i + +let special_of_int = function + | 1 -> KEY_F1 (* values from glut.h *) + | 2 -> KEY_F2 + | 3 -> KEY_F3 + | 4 -> KEY_F4 + | 5 -> KEY_F5 + | 6 -> KEY_F6 + | 7 -> KEY_F7 + | 8 -> KEY_F8 + | 9 -> KEY_F9 + | 10 -> KEY_F10 + | 11 -> KEY_F11 + | 12 -> KEY_F12 + | 100 -> KEY_LEFT + | 101 -> KEY_UP + | 102 -> KEY_RIGHT + | 103 -> KEY_DOWN + | 104 -> KEY_PAGE_UP + | 105 -> KEY_PAGE_DOWN + | 106 -> KEY_HOME + | 107 -> KEY_END + | 108 -> KEY_INSERT + | i -> KEY_OTHER i + +external _glutSpecialFunc : cb:(key:int->x:int->y:int->unit)->unit = + "ml_glutSpecialFunc" +let specialFunc = + window_wrapper _glutSpecialFunc + (fun cb ~key -> cb () ~key:(special_of_int key)) + +external _spaceballMotionFunc: cb:(x:int->y:int->z:int->unit)->unit = + "ml_glutSpaceballMotionFunc" +let spaceballMotionFunc = window_wrapper _spaceballMotionFunc eta_x + +external _spaceballRotateFunc: cb:(x:int->y:int->z:int->unit)->unit = + "ml_glutSpaceballRotateFunc" +let spaceballRotateFunc = window_wrapper _spaceballRotateFunc eta_x + +let eta_button cb ~button = cb () ~button + +external _spaceballButtonFunc: cb:(button:int->state:int->unit)->unit = "ml_glutSpaceballButtonFunc" +let spaceballButtonFunc = window_wrapper _spaceballButtonFunc eta_button + +external _buttonBoxFunc: cb:(button:int->state:int->unit)->unit = + "ml_glutButtonBoxFunc" +let buttonBoxFunc = window_wrapper _buttonBoxFunc eta_button + +external _dialsFunc: cb:(dial:int->value:int->unit)->unit = "ml_glutDialsFunc" +let dialsFunc = window_wrapper _dialsFunc (fun cb ~dial -> cb () ~dial) + +external _tabletMotionFunc: cb:(x:int->y:int->unit)->unit = + "ml_glutTabletMotionFunc" +let tabletMotionFunc = window_wrapper _tabletMotionFunc eta_x + +external _tabletButtonFunc: cb:(button:int->state:int->x:int->y:int->unit)->unit + = "ml_glutTabletButtonFunc" +let tabletButtonFunc = window_wrapper _tabletButtonFunc eta_button + +external menuStatusFunc: cb:(status:menu_state_t->x:int->y:int->unit)->unit = + "ml_glutMenuStatusFunc" + +external _overlayDisplayFunc: cb:(unit->unit)->unit = + "ml_glutOverlayDisplayFunc" +let overlayDisplayFunc = + window_wrapper _overlayDisplayFunc (fun cb () -> cb () ()) + + (* === GLUT color index sub-API. === === *) +external setColor: cell:int->red:float->green:float->blue:float->unit = + "ml_glutSetColor" +external getColor: index:int->component:int->float = + "ml_glutGetColor" +external copyColormap: win:int->unit = + "ml_glutCopyColormap" + + (* === GLUT state retrieval sub-API. === *) +external _get: igtype:int->int = "ml_glutGet" +let get ~gtype = + let igtype = match gtype with + | WINDOW_X -> 100 + | WINDOW_Y -> 101 + | WINDOW_WIDTH -> 102 + | WINDOW_HEIGHT -> 103 + | WINDOW_BUFFER_SIZE -> 104 + | WINDOW_STENCIL_SIZE -> 105 + | WINDOW_DEPTH_SIZE -> 106 + | WINDOW_RED_SIZE -> 107 + | WINDOW_GREEN_SIZE -> 108 + | WINDOW_BLUE_SIZE -> 109 + | WINDOW_ALPHA_SIZE -> 110 + | WINDOW_ACCUM_RED_SIZE -> 111 + | WINDOW_ACCUM_GREEN_SIZE -> 112 + | WINDOW_ACCUM_BLUE_SIZE -> 113 + | WINDOW_ACCUM_ALPHA_SIZE -> 114 + | WINDOW_DOUBLEBUFFER -> 115 + | WINDOW_RGBA -> 116 + | WINDOW_PARENT -> 117 + | WINDOW_NUM_CHILDREN -> 118 + | WINDOW_COLORMAP_SIZE -> 119 + | WINDOW_NUM_SAMPLES -> 120 + | WINDOW_STEREO -> 121 + | WINDOW_CURSOR -> 122 + | SCREEN_WIDTH -> 200 + | SCREEN_HEIGHT -> 201 + | SCREEN_WIDTH_MM -> 202 + | SCREEN_HEIGHT_MM -> 203 + | MENU_NUM_ITEMS -> 300 + (* | DISPLAY_MODE_POSSIBLE -> 400 *) + | INIT_WINDOW_X -> 500 + | INIT_WINDOW_Y -> 501 + | INIT_WINDOW_WIDTH -> 502 + | INIT_WINDOW_HEIGHT -> 503 + | INIT_DISPLAY_MODE -> 504 + | ELAPSED_TIME -> 700 + | WINDOW_FORMAT_ID -> 123 + in _get igtype ;; + +let getBool ~gtype = _get (match gtype with DISPLAY_MODE_POSSIBLE -> 400) <> 0 + +external _deviceGet: idgtype:int->int = "ml_glutDeviceGet" +let deviceGet ~dgtype = + let idgtype = match dgtype with + | HAS_KEYBOARD -> 600 + | HAS_MOUSE -> 601 + | HAS_SPACEBALL -> 602 + | HAS_DIAL_AND_BUTTON_BOX -> 603 + | HAS_TABLET -> 604 + | NUM_MOUSE_BUTTONS -> 605 + | NUM_SPACEBALL_BUTTONS -> 606 + | NUM_BUTTON_BOX_BUTTONS -> 607 + | NUM_DIALS -> 608 + | NUM_TABLET_BUTTONS -> 609 + | DEVICE_IGNORE_KEY_REPEAT -> 610 + | DEVICE_KEY_REPEAT -> 611 + | HAS_JOYSTICK -> 612 + | OWNS_JOYSTICK -> 613 + | JOYSTICK_BUTTONS -> 614 + | JOYSTICK_AXES -> 615 + | JOYSTICK_POLL_RATE -> 616 + in _deviceGet idgtype;; + + (* === GLUT extension support sub-API === *) +external extensionSupported: name:string->bool = "ml_glutExtensionSupported" + +external getModifiers: unit->int = "ml_glutGetModifiers" +(* +let getModifiers () = let m = _getModifiers() in + if m land 1 <> 0 then [ACTIVE_SHIFT] else [] @ + if m land 2 <> 0 then [ACTIVE_CTRL] else [] @ + if m land 4 <> 0 then [ACTIVE_ALT] else [];; +*) + +let int_of_modifiers m = + let ret = ref 0 in + let rec f = function + | [] -> () + | h::t -> begin + ret := (!ret lor (match h with + | ACTIVE_SHIFT -> 1 + | ACTIVE_CTRL -> 2 + | ACTIVE_ALT -> 4)); + f t + end in + f m; + !ret;; + +external _layerGet: int->int = "ml_glutLayerGet" +let layerGet ~lgtype = + let ilgtype = match lgtype with + | OVERLAY_POSSIBLE -> 800 + | HAS_OVERLAY -> 802 + | NORMAL_DAMAGED -> 804 + | OVERLAY_DAMAGED -> 805 in + let ret = _layerGet ilgtype in + if lgtype = OVERLAY_DAMAGED && ret = -1 then + raise (OverlayNotInUse "in layerGet OVERLAY_DAMAGED") + else + ret <> 0 +;; + +let layerGetTransparentIndex() = _layerGet 803 ;; (* from glut.h *) + +let layerGetInUse () = + match _layerGet 801 with + | 0 -> NORMAL + | 1 -> OVERLAY + | _ -> failwith "unexpected value in layerGetInUse" + + (* === GLUT font sub-API === *) + +(* convert font to integer value from glut.h *) +let f2i font = match font with + | STROKE_ROMAN -> 0 + | STROKE_MONO_ROMAN -> 1 + | BITMAP_9_BY_15 -> 2 + | BITMAP_8_BY_13 -> 3 + | BITMAP_TIMES_ROMAN_10 -> 4 + | BITMAP_TIMES_ROMAN_24 -> 5 + | BITMAP_HELVETICA_10 -> 6 + | BITMAP_HELVETICA_12 -> 7 + | BITMAP_HELVETICA_18 -> 8;; + +external _bitmapCharacter: font:int->c:int->unit = "ml_glutBitmapCharacter" +let bitmapCharacter ~font ~c = _bitmapCharacter (f2i font) c;; + +external _bitmapWidth: font:int->c:int->int = "ml_glutBitmapWidth" +let bitmapWidth ~font ~c = _bitmapWidth (f2i font) c;; + +external _strokeCharacter: font:int->c:int->unit = "ml_glutStrokeCharacter" +let strokeCharacter ~font ~c = _strokeCharacter (f2i font) c;; + +external _strokeWidth: font:int->c:int->int = "ml_glutStrokeWidth" +let strokeWidth ~font ~c = _strokeWidth (f2i font) c;; + + (* === GLUT pre-built models sub-API === *) +external wireSphere: radius:float->slices:int->stacks:int->unit = + "ml_glutWireSphere" +external solidSphere: radius:float->slices:int->stacks:int->unit = + "ml_glutSolidSphere" +external wireCone: base:float->height:float->slices:int->stacks:int->unit = + "ml_glutWireCone" +external solidCone: base:float->height:float->slices:int->stacks:int->unit = + "ml_glutSolidCone" +external wireCube: size:float->unit = + "ml_glutWireCube" +external solidCube: size:float->unit = + "ml_glutSolidCube" +external wireTorus: innerRadius:float->outerRadius:float->sides:int->rings:int + ->unit = "ml_glutWireTorus" +external solidTorus: innerRadius:float->outerRadius:float->sides:int->rings:int + ->unit = "ml_glutSolidTorus" +external wireDodecahedron: unit->unit = + "ml_glutWireDodecahedron" +external solidDodecahedron: unit->unit = + "ml_glutSolidDodecahedron" +external wireTeapot: size:float->unit = + "ml_glutWireTeapot" +external solidTeapot: size:float->unit = + "ml_glutSolidTeapot" +external wireOctahedron: unit->unit = + "ml_glutWireOctahedron" +external solidOctahedron: unit->unit = + "ml_glutSolidOctahedron" +external wireTetrahedron: unit->unit = + "ml_glutWireTetrahedron" +external solidTetrahedron: unit->unit = + "ml_glutSolidTetrahedron" +external wireIcosahedron: unit->unit = + "ml_glutWireIcosahedron" +external solidIcosahedron: unit->unit = + "ml_glutSolidIcosahedron" + + (* GLUT version 4 functions included in the GLUT 3.7 distribution *) +external initDisplayString: str:string->unit = "ml_glutInitDisplayString" +external warpPointer: x:int->y:int->unit = "ml_glutWarpPointer" + +external _bitmapLength: font:int->str:string->int = "ml_glutBitmapLength" +let bitmapLength ~font ~str = _bitmapLength (f2i font) str;; + +external _strokeLength: font:int->str:string->int = "ml_glutStrokeLength" +let strokeLength ~font ~str = _strokeLength (f2i font) str;; + +external _windowStatusFunc: (int->unit)->unit = "ml_glutWindowStatusFunc" +let windowStatusFunc ~cb = + _windowStatusFunc + (fun s -> + cb ~state:(match s with + | 0 -> HIDDEN + | 1 -> FULLY_RETAINED + | 2 -> PARTIALLY_RETAINED + | 3 -> FULLY_COVERED + | _ -> failwith "invalid value in glutWindowStatus ocaml callback")) + ;; + +external postWindowRedisplay: win:int->unit = + "ml_glutPostWindowRedisplay" + +external postWindowOverlayRedisplay: win:int->unit = + "ml_glutPostWindowOverlayRedisplay" + +external keyboardUpFunc: cb:(key:int->x:int->y:int->unit)->unit = "ml_glutKeyboardUpFunc" + +external _glutSpecialUpFunc : (key:int->x:int->y:int->unit)->unit = "ml_glutSpecialUpFunc" +let specialUpFunc ~cb = + _glutSpecialUpFunc + (fun ~key ->cb ~key:(special_of_int key));; + +external _ignoreKeyRepeat: ignore:int->unit = "ml_glutIgnoreKeyRepeat" +let ignoreKeyRepeat ~ignore = _ignoreKeyRepeat (if ignore = true then 1 else 0) + +external _setKeyRepeat: mode:int->unit = "ml_glutSetKeyRepeat" +let setKeyRepeat ~mode = + _setKeyRepeat (match mode with + | KEY_REPEAT_OFF -> 0 + | KEY_REPEAT_ON -> 1 + | KEY_REPEAT_DEFAULT -> 2 + );; + +external joystickFunc: cb:(buttonMask:int->x:int->y:int->z:int->unit)-> + pollInterval:int->unit = "ml_glutJoystickFunc" + +external forceJoystickFunc: unit->unit = "ml_glutForceJoystickFunc" + + (* GLUT video resize sub-API. *) +external _videoResizeGet: int->int = "ml_glutVideoResizeGet" +let videoResizeGet which = + let i = match which with + | VIDEO_RESIZE_POSSIBLE -> 900 + | VIDEO_RESIZE_IN_USE -> 901 + | VIDEO_RESIZE_X_DELTA -> 902 + | VIDEO_RESIZE_Y_DELTA -> 903 + | VIDEO_RESIZE_WIDTH_DELTA -> 904 + | VIDEO_RESIZE_HEIGHT_DELTA -> 905 + | VIDEO_RESIZE_X -> 906 + | VIDEO_RESIZE_Y -> 907 + | VIDEO_RESIZE_WIDTH -> 908 + | VIDEO_RESIZE_HEIGHT -> 909 + in _videoResizeGet i +;; + +external setupVideoResizing: unit->unit = + "ml_glutSetupVideoResizing" +external stopVideoResizing: unit->unit = + "ml_glutStopVideoResizing" +external videoResize: x:int->y:int->width:int->height:int->unit = + "ml_glutVideoResize" +external videoPan: x:int->y:int->width:int->height:int->unit = + "ml_glutVideoPan" + + (* GLUT debugging sub-API. *) +external reportErrors: unit->unit = "ml_glutReportErrors" + + (* GLUT game mode sub-API *) +external gameModeString: str:string->unit = "ml_glutGameModeString" + +external enterGameMode: unit->unit = "ml_glutEnterGameMode" + +external leaveGameMode: unit->unit = "ml_glutLeaveGameMode" + +external _gameModeGet: mode:int->int = "ml_glutGameModeGet" + +let gameModeGet ~mode = + let imode = match mode with + | GAME_MODE_ACTIVE -> 0 + | GAME_MODE_POSSIBLE -> 1 + | GAME_MODE_WIDTH -> 2 + | GAME_MODE_HEIGHT -> 3 + | GAME_MODE_PIXEL_DEPTH -> 4 + | GAME_MODE_REFRESH_RATE -> 5 + | GAME_MODE_DISPLAY_CHANGED -> 6 in + _gameModeGet imode;; + + (* ocaml specific *) +let string_of_special key = match key with + | KEY_F1 -> "KEY_F1" + | KEY_F2 -> "KEY_F2" + | KEY_F3 -> "KEY_F3" + | KEY_F4 -> "KEY_F4" + | KEY_F5 -> "KEY_F5" + | KEY_F6 -> "KEY_F6" + | KEY_F7 -> "KEY_F7" + | KEY_F8 -> "KEY_F8" + | KEY_F9 -> "KEY_F9" + | KEY_F10 -> "KEY_F10" + | KEY_F11 -> "KEY_F11" + | KEY_F12 -> "KEY_F12" + | KEY_LEFT -> "KEY_LEFT" + | KEY_UP -> "KEY_UP" + | KEY_RIGHT -> "KEY_RIGHT" + | KEY_DOWN -> "KEY_DOWN" + | KEY_PAGE_UP -> "KEY_PAGE_UP" + | KEY_PAGE_DOWN -> "KEY_PAGE_DOWN" + | KEY_HOME -> "KEY_HOME" + | KEY_END -> "KEY_END" + | KEY_INSERT -> "KEY_INSERT" + | KEY_OTHER i -> "KEY_OTHER " ^ string_of_int i + +let int_of_cursor c = match c with + | CURSOR_RIGHT_ARROW -> 0 + | CURSOR_LEFT_ARROW -> 1 + | CURSOR_INFO -> 2 + | CURSOR_DESTROY -> 3 + | CURSOR_HELP -> 4 + | CURSOR_CYCLE -> 5 + | CURSOR_SPRAY -> 6 + | CURSOR_WAIT -> 7 + | CURSOR_TEXT -> 8 + | CURSOR_CROSSHAIR -> 9 + | CURSOR_UP_DOWN -> 10 + | CURSOR_LEFT_RIGHT -> 11 + | CURSOR_TOP_SIDE -> 12 + | CURSOR_BOTTOM_SIDE -> 13 + | CURSOR_LEFT_SIDE -> 14 + | CURSOR_RIGHT_SIDE -> 15 + | CURSOR_TOP_LEFT_CORNER -> 16 + | CURSOR_TOP_RIGHT_CORNER -> 17 + | CURSOR_BOTTOM_RIGHT_CORNER -> 18 + | CURSOR_BOTTOM_LEFT_CORNER -> 19 + | CURSOR_INHERIT -> 100 + | CURSOR_NONE -> 101 + | CURSOR_FULL_CROSSHAIR -> 102 + +let string_of_cursor c = match c with + | CURSOR_RIGHT_ARROW -> "CURSOR_RIGHT_ARROW" + | CURSOR_LEFT_ARROW -> "CURSOR_LEFT_ARROW" + | CURSOR_INFO -> "CURSOR_INFO" + | CURSOR_DESTROY -> "CURSOR_DESTROY" + | CURSOR_HELP -> "CURSOR_HELP" + | CURSOR_CYCLE -> "CURSOR_CYCLE" + | CURSOR_SPRAY -> "CURSOR_SPRAY" + | CURSOR_WAIT -> "CURSOR_WAIT" + | CURSOR_TEXT -> "CURSOR_TEXT" + | CURSOR_CROSSHAIR -> "CURSOR_CROSSHAIR" + | CURSOR_UP_DOWN -> "CURSOR_UP_DOWN" + | CURSOR_LEFT_RIGHT -> "CURSOR_LEFT_RIGHT" + | CURSOR_TOP_SIDE -> "CURSOR_TOP_SIDE" + | CURSOR_BOTTOM_SIDE -> "CURSOR_BOTTOM_SIDE" + | CURSOR_LEFT_SIDE -> "CURSOR_LEFT_SIDE" + | CURSOR_RIGHT_SIDE -> "CURSOR_RIGHT_SIDE" + | CURSOR_TOP_LEFT_CORNER -> "CURSOR_TOP_LEFT_CORNER" + | CURSOR_TOP_RIGHT_CORNER -> "CURSOR_TOP_RIGHT_CORNER" + | CURSOR_BOTTOM_RIGHT_CORNER -> "CURSOR_BOTTOM_RIGHT_CORNER" + | CURSOR_BOTTOM_LEFT_CORNER -> "CURSOR_BOTTOM_LEFT_CORNER" + | CURSOR_INHERIT -> "CURSOR_INHERIT" + | CURSOR_NONE -> "CURSOR_NONE" + | CURSOR_FULL_CROSSHAIR -> "CURSOR_FULL_CROSSHAIR" + ;; + +let int_of_modifier m = match m with + | ACTIVE_SHIFT -> 1 + | ACTIVE_CTRL -> 2 + | ACTIVE_ALT -> 4 + ;; + +(* +let int_of_modifiers ms = + List.fold_left (lor) 0 (List.map int_of_modifier ms);; +*) + +let string_of_button b = match b with + | LEFT_BUTTON -> "LEFT_BUTTON" + | MIDDLE_BUTTON -> "MIDDLE_BUTTON" + | RIGHT_BUTTON -> "RIGHT_BUTTON" + | OTHER_BUTTON n -> "OTHER_BUTTON" ^ string_of_int n + ;; + +let string_of_button_state s = match s with + | DOWN -> "DOWN" + | UP -> "UP" + ;; + +let string_of_modifier m = match m with + | ACTIVE_SHIFT -> "ACTIVE_SHIFT" + | ACTIVE_CTRL -> "ACTIVE_CTRL" + | ACTIVE_ALT -> "ACTIVE_ALT" + ;; + +(* convert a list of strings to a single string *) +let string_of_strings l = + let rec _string_of_list l = match l with + | [] -> "" + | h::t -> h^(if t=[] then "" else ", "^(_string_of_list t)) + in "[ " ^ (_string_of_list l) ^ " ]";; + +let string_of_modifiers ml = + string_of_strings (List.map string_of_modifier ml);; + +let string_of_window_status status = match status with + | HIDDEN -> "HIDDEN" + | FULLY_RETAINED -> "FULLY_RETAINED" + | PARTIALLY_RETAINED -> "PARTIALLY_RETAINED" + | FULLY_COVERED -> "FULLY_COVERED" + ;; + +let string_of_vis_state vis = match vis with + | NOT_VISIBLE -> "NOT_VISIBLE" + | VISIBLE -> "VISIBLE" + ;; + diff --git a/LablGlut/src/glut.mli b/LablGlut/src/glut.mli new file mode 100644 index 0000000..bbe4484 --- /dev/null +++ b/LablGlut/src/glut.mli @@ -0,0 +1,392 @@ +(* + + glut.mli: interface for the lablglut GLUT binding. + +*) + +type button_t = + | LEFT_BUTTON + | MIDDLE_BUTTON + | RIGHT_BUTTON + | OTHER_BUTTON of int + +type mouse_button_state_t = + | DOWN + | UP + +type special_key_t = + | KEY_F1 + | KEY_F2 + | KEY_F3 + | KEY_F4 + | KEY_F5 + | KEY_F6 + | KEY_F7 + | KEY_F8 + | KEY_F9 + | KEY_F10 + | KEY_F11 + | KEY_F12 + (* directional keys *) + | KEY_LEFT + | KEY_UP + | KEY_RIGHT + | KEY_DOWN + | KEY_PAGE_UP + | KEY_PAGE_DOWN + | KEY_HOME + | KEY_END + | KEY_INSERT + (* for undefined keys *) + | KEY_OTHER of int + +type entry_exit_state_t = + | LEFT + | ENTERED + +type menu_state_t = + | MENU_NOT_IN_USE + | MENU_IN_USE + +type visibility_state_t = + | NOT_VISIBLE + | VISIBLE + +type window_status_t = + | HIDDEN + | FULLY_RETAINED + | PARTIALLY_RETAINED + | FULLY_COVERED + +type color_index_component_t = + | RED + | GREEN + | BLUE + +type layer_t = + | NORMAL + | OVERLAY + +type font_t = + | STROKE_ROMAN + | STROKE_MONO_ROMAN + | BITMAP_9_BY_15 + | BITMAP_8_BY_13 + | BITMAP_TIMES_ROMAN_10 + | BITMAP_TIMES_ROMAN_24 + | BITMAP_HELVETICA_10 + | BITMAP_HELVETICA_12 + | BITMAP_HELVETICA_18 + +type glut_get_t = + | WINDOW_X + | WINDOW_Y + | WINDOW_WIDTH + | WINDOW_HEIGHT + | WINDOW_BUFFER_SIZE + | WINDOW_STENCIL_SIZE + | WINDOW_DEPTH_SIZE + | WINDOW_RED_SIZE + | WINDOW_GREEN_SIZE + | WINDOW_BLUE_SIZE + | WINDOW_ALPHA_SIZE + | WINDOW_ACCUM_RED_SIZE + | WINDOW_ACCUM_GREEN_SIZE + | WINDOW_ACCUM_BLUE_SIZE + | WINDOW_ACCUM_ALPHA_SIZE + | WINDOW_DOUBLEBUFFER + | WINDOW_RGBA + | WINDOW_PARENT + | WINDOW_NUM_CHILDREN + | WINDOW_COLORMAP_SIZE + | WINDOW_NUM_SAMPLES + | WINDOW_STEREO + | WINDOW_CURSOR + | SCREEN_WIDTH + | SCREEN_HEIGHT + | SCREEN_WIDTH_MM + | SCREEN_HEIGHT_MM + | MENU_NUM_ITEMS + (* | DISPLAY_MODE_POSSIBLE : use getBool *) + | INIT_WINDOW_X + | INIT_WINDOW_Y + | INIT_WINDOW_WIDTH + | INIT_WINDOW_HEIGHT + | INIT_DISPLAY_MODE + | ELAPSED_TIME + | WINDOW_FORMAT_ID + +type glut_get_bool_t = + | DISPLAY_MODE_POSSIBLE + +(* display mode bit masks *) +val rgb:int +val rgba:int +val index:int +val single:int +val double:int +val accum:int +val alpha:int +val depth:int +val stencil:int +val multisample:int +val stereo:int +val luminance:int + +type device_get_t = + | HAS_KEYBOARD + | HAS_MOUSE + | HAS_SPACEBALL + | HAS_DIAL_AND_BUTTON_BOX + | HAS_TABLET + | NUM_MOUSE_BUTTONS + | NUM_SPACEBALL_BUTTONS + | NUM_BUTTON_BOX_BUTTONS + | NUM_DIALS + | NUM_TABLET_BUTTONS + | DEVICE_IGNORE_KEY_REPEAT + | DEVICE_KEY_REPEAT + | HAS_JOYSTICK + | OWNS_JOYSTICK + | JOYSTICK_BUTTONS + | JOYSTICK_AXES + | JOYSTICK_POLL_RATE + +type layerget_t = + | OVERLAY_POSSIBLE + (* | LAYER_IN_USE : use layerGetInUse *) + | HAS_OVERLAY + (* | TRANSPARENT_INDEX : use layerGetTransparentIndex *) + | NORMAL_DAMAGED + | OVERLAY_DAMAGED + +type video_resize_t = + | VIDEO_RESIZE_POSSIBLE + | VIDEO_RESIZE_IN_USE + | VIDEO_RESIZE_X_DELTA + | VIDEO_RESIZE_Y_DELTA + | VIDEO_RESIZE_WIDTH_DELTA + | VIDEO_RESIZE_HEIGHT_DELTA + | VIDEO_RESIZE_X + | VIDEO_RESIZE_Y + | VIDEO_RESIZE_WIDTH + | VIDEO_RESIZE_HEIGHT + +(* key modifier bit masks *) +val active_shift:int +val active_ctrl:int +val active_alt:int + +type cursor_t = + (* Basic arrows. *) + | CURSOR_RIGHT_ARROW + | CURSOR_LEFT_ARROW + (* Symbolic cursor shapes. *) + | CURSOR_INFO + | CURSOR_DESTROY + | CURSOR_HELP + | CURSOR_CYCLE + | CURSOR_SPRAY + | CURSOR_WAIT + | CURSOR_TEXT + | CURSOR_CROSSHAIR + (* Directional cursors. *) + | CURSOR_UP_DOWN + | CURSOR_LEFT_RIGHT + (* Sizing cursors. *) + | CURSOR_TOP_SIDE + | CURSOR_BOTTOM_SIDE + | CURSOR_LEFT_SIDE + | CURSOR_RIGHT_SIDE + | CURSOR_TOP_LEFT_CORNER + | CURSOR_TOP_RIGHT_CORNER + | CURSOR_BOTTOM_RIGHT_CORNER + | CURSOR_BOTTOM_LEFT_CORNER + | CURSOR_INHERIT (* inherit cursor from parent window *) + | CURSOR_NONE (* blank cursor *) + | CURSOR_FULL_CROSSHAIR (* full-screen crosshair (if available) *) + +type game_mode_t = + | GAME_MODE_ACTIVE + | GAME_MODE_POSSIBLE + | GAME_MODE_WIDTH + | GAME_MODE_HEIGHT + | GAME_MODE_PIXEL_DEPTH + | GAME_MODE_REFRESH_RATE + | GAME_MODE_DISPLAY_CHANGED + +type key_repeat_t = + | KEY_REPEAT_OFF + | KEY_REPEAT_ON + | KEY_REPEAT_DEFAULT + +exception BadEnum of string +exception InvalidState of string + + (* GLUT initialization sub-API. *) +val init: argv:(string array)->string array (* returns new argv *) +val initDisplayMode: (* The last argument must be () *) + ?double_buffer:bool-> + ?index:bool-> + ?accum:bool-> + ?alpha:bool-> + ?depth:bool-> + ?stencil:bool-> + ?multisample:bool-> + ?stereo:bool-> + ?luminance:bool-> + unit-> + unit +val initWindowPosition: x:int->y:int->unit +val initWindowSize: w:int->h:int->unit +val mainLoop: unit->unit + + (* GLUT window sub-API. *) +val createWindow: title:string->int (* returns window id *) +val postRedisplay: unit->unit +val swapBuffers: unit->unit +val createSubWindow: win:int->x:int->y:int->w:int->h:int->int +val destroyWindow: win:int->unit +val getWindow: unit->int +val setWindow: win:int->unit +val setWindowTitle: title:string->unit +val setIconTitle: title:string->unit +val positionWindow: x:int->y:int->unit +val reshapeWindow: w:int->h:int->unit +val popWindow: unit->unit +val pushWindow: unit->unit +val iconifyWindow: unit->unit +val showWindow: unit->unit +val hideWindow: unit->unit +val fullScreen: unit->unit +val setCursor: cursor_t->unit + + (* GLUT overlay sub-API. *) +val establishOverlay: unit->unit +val removeOverlay: unit->unit +val useLayer: layer_t->unit +val postOverlayRedisplay: unit->unit +val showOverlay: unit->unit +val hideOverlay: unit->unit + + (* GLUT menu sub-API. *) +val createMenu: cb:(value:int->unit)->int +val destroyMenu: menu:int->unit +val getMenu: unit->int +val setMenu: menu:int->unit +val addMenuEntry: label:string->value:int->unit +val addSubMenu: label:string->submenu:int->unit +val changeToMenuEntry: item:int->label:string->value:int->unit +val changeToSubMenu: item:int->label:string->submenu:int->unit +val removeMenuItem: item:int->unit +val attachMenu: button:button_t->unit +val detachMenu: button:button_t->unit + + (* GLUT window callback sub-API. *) +val displayFunc: cb:(unit->unit)->unit +val reshapeFunc: cb:(w:int->h:int->unit)->unit +val keyboardFunc: cb:(key:int->x:int->y:int->unit)->unit +val mouseFunc: cb:(button:button_t->state:mouse_button_state_t-> + x:int->y:int->unit)->unit +val motionFunc: cb:(x:int->y:int->unit)->unit +val passiveMotionFunc: cb:(x:int->y:int->unit)->unit +val entryFunc: cb:(state:entry_exit_state_t->unit)->unit +val visibilityFunc: cb:(state:visibility_state_t->unit)->unit +val idleFunc: cb:((unit->unit) option)->unit +(* you can set as many timer as you want simultanesouly *) +val timerFunc: ms:int->cb:(value:'a->unit)->value:'a->unit +val specialFunc: cb:(key:special_key_t->x:int->y:int->unit)->unit +val spaceballMotionFunc: cb:(x:int->y:int->z:int->unit)->unit +val spaceballRotateFunc: cb:(x:int->y:int->z:int->unit)->unit +val spaceballButtonFunc: cb:(button:int->state:int->unit)->unit +val buttonBoxFunc: cb:(button:int->state:int->unit)->unit +val dialsFunc: cb:(dial:int->value:int->unit)->unit +val tabletMotionFunc: cb:(x:int->y:int->unit)->unit +val tabletButtonFunc: cb:(button:int->state:int->x:int->y:int->unit)->unit +val menuStatusFunc: cb:(status:menu_state_t->x:int->y:int->unit)->unit +val overlayDisplayFunc: cb:(unit->unit)->unit + + (* GLUT color index sub-API. *) +val setColor: cell:int->red:float->green:float->blue:float->unit +val getColor: index:int->component:int->float +val copyColormap: win:int->unit + + (* GLUT state retrieval sub-API. *) +val get: gtype:glut_get_t->int +val getBool: gtype:glut_get_bool_t->bool +val deviceGet: dgtype:device_get_t->int + + (* GLUT extension support sub-API *) +val extensionSupported: name:string->bool +val getModifiers: unit->int +val layerGetTransparentIndex: unit->int +val layerGetInUse: unit->layer_t +val layerGet: lgtype:layerget_t->bool + + (* GLUT font sub-API *) +val bitmapCharacter: font:font_t->c:int->unit +val bitmapWidth: font:font_t->c:int->int +val strokeCharacter: font:font_t->c:int->unit +val strokeWidth: font:font_t->c:int->int + + (* GLUT pre-built models sub-API *) +val wireSphere: radius:float->slices:int->stacks:int->unit +val solidSphere: radius:float->slices:int->stacks:int->unit +val wireCone: base:float->height:float->slices:int->stacks:int->unit +val solidCone: base:float->height:float->slices:int->stacks:int->unit +val wireCube: size:float->unit +val solidCube: size:float->unit +val wireTorus: innerRadius:float->outerRadius:float->sides:int->rings:int->unit +val solidTorus: innerRadius:float->outerRadius:float->sides:int->rings:int->unit +val wireDodecahedron: unit->unit +val solidDodecahedron: unit->unit +val wireTeapot: size:float->unit +val solidTeapot: size:float->unit +val wireOctahedron: unit->unit +val solidOctahedron: unit->unit +val wireTetrahedron: unit->unit +val solidTetrahedron: unit->unit +val wireIcosahedron: unit->unit +val solidIcosahedron: unit->unit + + (* GLUT game mode sub-API *) +val gameModeString: str:string->unit +val enterGameMode: unit->unit +val leaveGameMode: unit->unit +val gameModeGet: mode:game_mode_t->int + + (* GLUT version 4 functions included in the GLUT 3.7 distribution *) +val initDisplayString: str:string->unit +val warpPointer: x:int->y:int->unit +val bitmapLength: font:font_t->str:string->int +val strokeLength: font:font_t->str:string->int +val windowStatusFunc: cb:(state:window_status_t->unit)->unit +val postWindowRedisplay: win:int->unit +val postWindowOverlayRedisplay: win:int->unit +val keyboardUpFunc: cb:(key:int->x:int->y:int->unit)->unit +val specialUpFunc: cb:(key:special_key_t->x:int->y:int->unit)->unit +val ignoreKeyRepeat: ignore:bool->unit +val setKeyRepeat: mode:key_repeat_t->unit +val joystickFunc: cb:(buttonMask:int->x:int->y:int->z:int->unit)-> + pollInterval:int->unit +val forceJoystickFunc: unit->unit + + (* GLUT video resize sub-API. *) +val videoResizeGet: video_resize_t->int +val setupVideoResizing: unit->unit +val stopVideoResizing: unit->unit +val videoResize: x:int->y:int->width:int->height:int->unit +val videoPan: x:int->y:int->width:int->height:int->unit + + (* GLUT debugging sub-API. *) +val reportErrors: unit->unit + + (* ocaml-specific *) +val string_of_button: button_t->string +val string_of_button_state: mouse_button_state_t->string +val string_of_special: special_key_t->string +val string_of_window_status: window_status_t->string +val string_of_vis_state: visibility_state_t->string +val string_of_cursor: cursor_t->string +val int_of_cursor: cursor_t->int + diff --git a/LablGlut/src/lablglut.bat b/LablGlut/src/lablglut.bat new file mode 100755 index 0000000..8c9b14a --- /dev/null +++ b/LablGlut/src/lablglut.bat @@ -0,0 +1,2 @@ +@rem toplevel for lablGL with glut support +ocaml -I +lablgl lablgl.cma lablglut.cma %1 %2 %3 %4 %5 %6 %7 %8 %9 \ No newline at end of file diff --git a/LablGlut/src/ml_gl.h b/LablGlut/src/ml_gl.h new file mode 100644 index 0000000..f3ba095 --- /dev/null +++ b/LablGlut/src/ml_gl.h @@ -0,0 +1,132 @@ +/* $Id: ml_gl.h,v 1.2 2003-10-28 05:16:37 ijtrotts Exp $ */ +/* This file was copied (gratefully) from J. Garrigue's LablGL */ + +#ifndef _ml_gl_ +#define _ml_gl_ + +void ml_raise_gl (const char *errmsg) Noreturn; +#define copy_string_check lablgl_copy_string_check +value copy_string_check (const char *str); + +GLenum GLenum_val (value); + +#define Float_val(dbl) ((GLfloat) Double_val(dbl)) +#define Addr_val(addr) ((GLvoid *) addr) +#define Val_addr(addr) ((value) addr) +#define Type_raw(raw) (GLenum_val(Kind_raw(raw))) +#define Type_void_raw(raw) Type_raw(raw), Void_raw(raw) + +#define ML_0(cname) \ +CAMLprim value ml_##cname (value unit) \ +{ cname (); return Val_unit; } +#define ML_1(cname, conv1) \ +CAMLprim value ml_##cname (value arg1) \ +{ cname (conv1(arg1)); return Val_unit; } +#define ML_2(cname, conv1, conv2) \ +CAMLprim value ml_##cname (value arg1, value arg2) \ +{ cname (conv1(arg1), conv2(arg2)); return Val_unit; } +#define ML_3(cname, conv1, conv2, conv3) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3) \ +{ cname (conv1(arg1), conv2(arg2), conv3(arg3)); return Val_unit; } +#define ML_4(cname, conv1, conv2, conv3, conv4) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4) \ +{ cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4)); \ + return Val_unit; } +#define ML_5(cname, conv1, conv2, conv3, conv4, conv5) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ + value arg5) \ +{ cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), conv5(arg5)); \ + return Val_unit; } +#define ML_6(cname, conv1, conv2, conv3, conv4, conv5, conv6) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ + value arg5, value arg6) \ +{ cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), conv5(arg5), \ + conv6(arg6)); \ + return Val_unit; } +#define ML_7(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ + value arg5, value arg6, value arg7) \ +{ cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), conv5(arg5), \ + conv6(arg6), conv7(arg7)); \ + return Val_unit; } +#define ML_8(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv8) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ + value arg5, value arg6, value arg7, value arg8) \ +{ cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), conv5(arg5), \ + conv6(arg6), conv7(arg7), conv8(arg8)); \ + return Val_unit; } + +#define ML_0_(cname, conv) \ +CAMLprim value ml_##cname (value unit) \ +{ return conv (cname ()); } +#define ML_1_(cname, conv1, conv) \ +CAMLprim value ml_##cname (value arg1) \ +{ return conv (cname (conv1(arg1))); } +#define ML_2_(cname, conv1, conv2, conv) \ +CAMLprim value ml_##cname (value arg1, value arg2) \ +{ return conv (cname (conv1(arg1), conv2(arg2))); } +#define ML_3_(cname, conv1, conv2, conv3, conv) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3) \ +{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3))); } +#define ML_4_(cname, conv1, conv2, conv3, conv4, conv) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4) \ +{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4))); } +#define ML_5_(cname, conv1, conv2, conv3, conv4, conv5, conv) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ + value arg5) \ +{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \ + conv5(arg5))); } +#define ML_6_(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ + value arg5, value arg6) \ +{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \ + conv5(arg5), conv6(arg6))); } +#define ML_7_(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ + value arg5, value arg6, value arg7) \ +{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \ + conv5(arg5), conv6(arg6), conv7(arg7))); } +#define ML_8_(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv8, \ + conv) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ + value arg5, value arg6, value arg7, value arg8) \ +{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \ + conv5(arg5), conv6(arg6), conv7(arg7), conv8(arg8))); } + +/* Use with care: needs the argument index */ +#define Ignore(x) +#define Split(x,f,g) f(x), g(x) Ignore +#define Split3(x,f,g,h) f(x), g(x), h(x) Ignore +#define Pair(x,f,g) f(Field(x,0)), g(Field(x,1)) Ignore +#define Triple(x,f,g,h) f(Field(x,0)), g(Field(x,1)), h(Field(x,2)) Ignore + +/* For more than 5 arguments */ +#define ML_bc6(cname) \ +CAMLprim value cname##_bc (value *argv, int argn) \ +{ return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5]); } + +#define ML_bc7(cname) \ +CAMLprim value cname##_bc (value *argv, int argn) \ +{ return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6]); } + +#define ML_bc8(cname) \ +CAMLprim value cname##_bc (value *argv, int argn) \ +{ return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6], \ + argv[7]); } + + +/* subtleties of openGL 1.1 vs 1.2 */ +#if !defined(GL_DOUBLE) && defined(GL_DOUBLE_EXT) +#define GL_DOUBLE GL_DOUBLE_EXT +#endif +#if !defined(GL_TEXTURE_PRIORITY) && defined(GL_TEXTURE_PRIORITY_EXT) +#define GL_TEXTURE_PRIORITY GL_TEXTURE_PRIORITY_EXT +#endif +#if !defined(GL_PROXY_TEXTURE_1D) && defined(GL_PROXY_TEXTURE_1D_EXT) +#define GL_PROXY_TEXTURE_1D GL_PROXY_TEXTURE_1D_EXT +#endif +#if !defined(GL_PROXY_TEXTURE_2D) && defined(GL_PROXY_TEXTURE_2D_EXT) +#define GL_PROXY_TEXTURE_2D GL_PROXY_TEXTURE_2D_EXT +#endif + +#endif diff --git a/LablGlut/src/wrap_gl.c b/LablGlut/src/wrap_gl.c new file mode 100644 index 0000000..009ca48 --- /dev/null +++ b/LablGlut/src/wrap_gl.c @@ -0,0 +1,154 @@ +#ifdef __APPLE__ +#include +#else +#include +#endif +#include +#include + +#include +#include + +static void ocaml_gl_warning(const char msg[]) +{ + fprintf(stderr, "OCaml Open GL warning : %s", msg); + fflush(stderr); +} + +value ocaml_glClear ( + value will_clear_color_buffer, + value will_clear_depth_buffer) +{ + GLbitfield mask = 0; + mask |= (Bool_val(will_clear_color_buffer) ? GL_COLOR_BUFFER_BIT : 0); + mask |= (Bool_val(will_clear_depth_buffer) ? GL_DEPTH_BUFFER_BIT : 0); + glClear(mask); + return Val_unit; +} + +value ocaml_glClearColor (value r, value g, value b, value a) +{ + glClearColor(Double_val(r), Double_val(g), Double_val(b), Double_val(a)); + return Val_unit; +} + +value ocaml_glBegin (value primitive_type) +{ + switch( Int_val(primitive_type) ) + { + case 0: glBegin(GL_POINTS); break; + case 1: glBegin(GL_LINES); break; + case 2: glBegin(GL_LINE_LOOP); break; + case 3: glBegin(GL_LINE_STRIP); break; + case 4: glBegin(GL_TRIANGLES); break; + case 5: glBegin(GL_TRIANGLE_STRIP); break; + case 6: glBegin(GL_TRIANGLE_FAN); break; + case 7: glBegin(GL_QUADS); break; + case 8: glBegin(GL_QUAD_STRIP); break; + case 9: glBegin(GL_POLYGON); break; + default: + ocaml_gl_warning("Unrecognized primitive type in ocaml_glBegin()\n"); + } + return Val_unit; +} + +value ocaml_glVertex3d (value vx, value vy, value vz) +{ + double x,y,z; + x = Double_val(vx); + y = Double_val(vy); + z = Double_val(vz); + glVertex3d(x,y,z); + return Val_unit; +} + +value ocaml_glVertex2d (value vx, value vy) +{ + double x,y; + x = Double_val(vx); + y = Double_val(vy); + glVertex2d(x,y); + return Val_unit; +} + + +value ocaml_glColor3d (value r, value g, value b) +{ + glColor3d(Double_val(r), Double_val(g), Double_val(b)); + return Val_unit; +} + +// TexCoord + +// Normal + +value ocaml_glEnd () +{ + glEnd(); + return Val_unit; +} + +value ocaml_glFlush () +{ + glFlush(); + return Val_unit; +} + +value ocaml_glViewport (value vx, value vy, value vwidth, value vheight) +{ + int x,y,w,h; + x=Int_val(vx); + y=Int_val(vy); + w=Int_val(vwidth); + h=Int_val(vheight); + glViewport(x, y, w, h); + return Val_unit; +} + +value ocaml_glMatrixMode (value mode) +{ + int imode = Int_val(mode); + switch(imode) + { + case 0: glMatrixMode(GL_MODELVIEW); break; + case 1: glMatrixMode(GL_PROJECTION); break; + case 2: glMatrixMode(GL_TEXTURE); break; + default: + ocaml_gl_warning("Unrecognized mode in ocaml_glMatrixMode()\n"); + } + return Val_unit; +} + +value ocaml_glLoadIdentity () +{ + glLoadIdentity(); + return Val_unit; +} + +value ocaml_glShadeModel (value model) +{ + switch(Int_val(model)) + { + case 0: glShadeModel(GL_FLAT); break; + case 1: glShadeModel(GL_SMOOTH); break; + default: + ocaml_gl_warning("Unrecognized mode in ocaml_glShadeModel()\n"); + } + return Val_unit; +} + +value native_ocaml_glOrtho( + value left, value right, value bot, value top, value znear, value zfar) +{ + glOrtho(Double_val(left), Double_val(right), Double_val(bot), Double_val(top), + Double_val(znear), Double_val(zfar)); + return Val_unit; +} + +value bytecode_ocaml_glOrtho(value * args, int num_args) +{ + native_ocaml_glOrtho(args[0], args[1], args[2], args[3], args[4], args[5]); + return Val_unit; +} + + diff --git a/LablGlut/src/wrap_glut.c b/LablGlut/src/wrap_glut.c new file mode 100644 index 0000000..c869e17 --- /dev/null +++ b/LablGlut/src/wrap_glut.c @@ -0,0 +1,414 @@ +/* + * wrap_glut.c + * + * an OCaml wrapper for a subset of Mark Kilgard's GLUT + * + * written by ijt + * + */ + +#ifdef _WIN32 +#define GLUT_DISABLE_ATEXIT_HACK +#include +#endif +#ifdef __APPLE__ +#include +#else +#include +#endif +#include +#include +#include +#include + +#include +#include +#include +#include +#include +#include + +#include "ml_gl.h" + +#define VoidPtr_val(x) ((void*) Int_val(x)) + +/* ML_0(glutMainLoop) */ +CAMLprim value ml_glutMainLoop (value unit) \ +{ + enter_blocking_section (); + glutMainLoop (); + leave_blocking_section (); + return Val_unit; +} + + +ML_0(glutSwapBuffers) /* makes a function called ml_glutSwapBuffers() */ +ML_0(glutPostRedisplay) +ML_2(glutInitWindowSize, Int_val, Int_val) +ML_2(glutInitWindowPosition, Int_val, Int_val) +ML_1_(glutCreateWindow, String_val, Val_int) +ML_5_(glutCreateSubWindow, Int_val, Int_val, Int_val, Int_val, Int_val, Val_int) +ML_1(glutDestroyWindow, Int_val) +ML_0_(glutGetWindow, Val_int) /* return win id */ +ML_1(glutSetWindow, Int_val) +ML_1(glutSetWindowTitle, String_val) +ML_1(glutSetIconTitle, String_val) +ML_2(glutPositionWindow, Int_val, Int_val) +ML_2(glutReshapeWindow, Int_val, Int_val) +ML_0(glutPopWindow) +ML_0(glutPushWindow) +ML_0(glutIconifyWindow) +ML_0(glutShowWindow) +ML_0(glutHideWindow) +ML_0(glutFullScreen) +ML_1(glutSetCursor, Int_val) +ML_0(glutEstablishOverlay) +ML_0(glutRemoveOverlay) +ML_1(glutUseLayer, Int_val) +ML_0(glutPostOverlayRedisplay) +ML_0(glutShowOverlay) +ML_0(glutHideOverlay) +ML_1(glutDestroyMenu, Int_val) +ML_0_(glutGetMenu, Val_int) +ML_1(glutSetMenu, Int_val) +ML_2(glutAddMenuEntry, String_val, Int_val) +ML_2(glutAddSubMenu, String_val, Int_val) +ML_3(glutChangeToMenuEntry, Int_val, String_val, Int_val) +ML_3(glutChangeToSubMenu, Int_val, String_val, Int_val) +ML_1(glutRemoveMenuItem, Int_val) +ML_1(glutAttachMenu, Int_val) +ML_1(glutDetachMenu, Int_val) +ML_4(glutSetColor, Int_val, Float_val, Float_val, Float_val) +ML_2_(glutGetColor, Int_val, Int_val, copy_double) +ML_1(glutCopyColormap, Int_val) +ML_1_(glutGet, Int_val, Val_int) +ML_1_(glutDeviceGet, Int_val, Val_int) +ML_1_(glutExtensionSupported, String_val, Val_bool) +ML_0_(glutGetModifiers, Val_int) +ML_1_(glutLayerGet, Int_val, Val_int) + +ML_1_(glutVideoResizeGet, Int_val, Val_int) +ML_0(glutSetupVideoResizing) +ML_0(glutStopVideoResizing) +ML_4(glutVideoResize, Int_val, Int_val, Int_val, Int_val) +ML_4(glutVideoPan, Int_val, Int_val, Int_val, Int_val) +ML_0(glutReportErrors) + +ML_3(glutWireSphere, Float_val, Int_val, Int_val) +ML_3(glutSolidSphere, Float_val, Int_val, Int_val) +ML_4(glutWireCone, Float_val, Float_val, Int_val, Int_val) +ML_4(glutSolidCone, Float_val, Float_val, Int_val, Int_val) +ML_1(glutWireCube, Float_val) +ML_1(glutSolidCube, Float_val) +ML_4(glutWireTorus, Float_val, Float_val, Int_val, Int_val) +ML_4(glutSolidTorus, Float_val, Float_val, Int_val, Int_val) +ML_0(glutWireDodecahedron) +ML_0(glutSolidDodecahedron) +ML_1(glutWireTeapot, Float_val) +ML_1(glutSolidTeapot, Float_val) +ML_0(glutWireOctahedron) +ML_0(glutSolidOctahedron) +ML_0(glutWireTetrahedron) +ML_0(glutSolidTetrahedron) +ML_0(glutWireIcosahedron) +ML_0(glutSolidIcosahedron) +ML_1(glutGameModeString, String_val) +ML_0(glutEnterGameMode) +ML_0(glutLeaveGameMode) +ML_1_(glutGameModeGet, Int_val, Val_int) + +CAMLprim value ml_glutInit( value v_argc, char **argv ) +{ + int argc = Int_val(v_argc); + /* The input array must have one more element */ + argv[argc] = NULL; + glutInit(&argc, argv); /* Safe: no callback */ + return Val_int(argc); +} + +CAMLprim value native_glutInitDisplayMode( + value double_buffer, + value index, + value accum, + value alpha, + value depth, + value stencil, + value multisample, + value stereo, + value luminance) +{ + unsigned int acc = 0; + acc |= Bool_val(double_buffer) ? GLUT_DOUBLE : 0; + acc |= Bool_val(index) ? GLUT_INDEX : 0; + acc |= Bool_val(accum) ? GLUT_ACCUM : 0; + acc |= Bool_val(alpha) ? GLUT_RGBA : 0; + acc |= Bool_val(depth) ? GLUT_DEPTH : 0; + acc |= Bool_val(stencil) ? GLUT_STENCIL : 0; + acc |= Bool_val(multisample) ? GLUT_MULTISAMPLE : 0; + acc |= Bool_val(stereo) ? GLUT_STEREO : 0; + acc |= Bool_val(luminance) ? GLUT_LUMINANCE : 0; + glutInitDisplayMode(acc); + return Val_unit; +} + +CAMLprim value bytecode_glutInitDisplayMode ( value * args, int num_args) +{ + assert(num_args == 9); + native_glutInitDisplayMode( + args[0],/*double_buffer*/ + args[1],/*index*/ + args[2],/*accum*/ + args[3],/*alpha*/ + args[4],/*depth*/ + args[5],/*stencil*/ + args[6],/*multisample*/ + args[7],/*stereo*/ + args[8] /*luminance*/ + ); + return Val_unit; +} + +/* associations between callback functions and window ids are made on the + OCaml side. */ + +/* TODO: make these easier to read. gcc was complaining about backslashes, + for reasons that aren't clear to me. */ + +#define REGISTER_CB(glut_func) \ + CAMLprim value ml_##glut_func(value cb) { \ + glut_func(glut_func##_cb ); \ + if (glut_func##_value) { \ + if (glut_func##_value == cb) return Val_unit; \ + caml_remove_global_root(&glut_func##_value); \ + } \ + glut_func##_value = cb; \ + caml_register_global_root(&glut_func##_value); \ + return Val_unit; \ + } + +// for callback with return value for the hooking function +#define REGISTER_CB_(glut_func, conv) \ + CAMLprim value ml_##glut_func(value cb) { \ + value r = conv(glut_func(glut_func##_cb )); \ + if (glut_func##_value) { \ + if (glut_func##_value == cb) return r; \ + caml_remove_global_root(&glut_func##_value); \ + } \ + glut_func##_value = cb; \ + caml_register_global_root(&glut_func##_value); \ + return r; \ + } + +// for callback with one extra argument for the hooking function +#define REGISTER__CB(glut_func, conv) \ + CAMLprim value ml_##glut_func(value cb, value arg) { \ + glut_func(glut_func##_cb, conv(arg) ); \ + if (glut_func##_value) { \ + if (glut_func##_value == cb) return Val_unit; \ + caml_remove_global_root(&glut_func##_value); \ + } \ + glut_func##_value = cb; \ + caml_register_global_root(&glut_func##_value); \ + return Val_unit; \ + } + +#define CB_0(glut_func) \ + value glut_func##_value = 0; \ + static void glut_func##_cb( void ) { \ + leave_blocking_section (); \ + callback(glut_func##_value, Val_unit); \ + enter_blocking_section (); \ + } \ + REGISTER_CB(glut_func) + +#define CB_1(glut_func, type1, conv1) \ + value glut_func##_value = 0; \ + static void glut_func##_cb( type1 arg1 ) { \ + leave_blocking_section (); \ + callback(glut_func##_value, conv1(arg1)); \ + enter_blocking_section (); \ + } \ + REGISTER_CB(glut_func) + +// for callback with return value for the hooking function +#define CB_1_(glut_func, type1, conv1, conv) \ + value glut_func##_value = 0; \ + static void glut_func##_cb( type1 arg1 ) { \ + leave_blocking_section (); \ + callback(glut_func##_value, conv1(arg1)); \ + enter_blocking_section (); \ + } \ + REGISTER_CB_(glut_func, conv) + +#define CB_2(glut_func, type1, conv1, type2, conv2) \ + value glut_func##_value = 0; \ + static void glut_func##_cb( type1 arg1, type2 arg2 ) { \ + leave_blocking_section (); \ + callback2(glut_func##_value, conv1(arg1), conv2(arg2)); \ + enter_blocking_section (); \ + } \ + REGISTER_CB(glut_func) + +#define CB_3(glut_func, type1, conv1, type2, conv2, type3, conv3) \ + value glut_func##_value = 0; \ + static void glut_func##_cb( type1 arg1, type2 arg2, type3 arg3 ) { \ + leave_blocking_section (); \ + callback3(glut_func##_value, conv1(arg1), conv2(arg2), conv3(arg3)); \ + enter_blocking_section (); \ + } \ + REGISTER_CB(glut_func) + +#define CB_4(glut_func, type1, conv1, type2, conv2, type3, conv3, type4, conv4)\ + value glut_func##_value = 0; \ + static void glut_func##_cb( type1 arg1, type2 arg2, type3 arg3, type4 arg4 )\ + { \ + value args[4]; \ + leave_blocking_section (); \ + args[0] = conv1(arg1); \ + args[1] = conv2(arg2); \ + args[2] = conv3(arg3); \ + args[3] = conv4(arg4); \ + callbackN (glut_func##_value, 4, args); \ + enter_blocking_section (); \ + } \ + REGISTER_CB(glut_func) + +// for callback with one extra argument for the hooking function +#define CB__4(glut_func, type1, conv1, type2, conv2, type3, conv3, type4, conv4, conv) \ + value glut_func##_value = 0; \ + static void glut_func##_cb( type1 arg1, type2 arg2, type3 arg3, type4 arg4 )\ + { \ + value args[4]; \ + leave_blocking_section (); \ + args[0] = conv1(arg1); \ + args[1] = conv2(arg2); \ + args[2] = conv3(arg3); \ + args[3] = conv4(arg4); \ + callbackN (glut_func##_value, 4, args); \ + enter_blocking_section (); \ + } \ + REGISTER__CB(glut_func, conv) + +CB_0(glutDisplayFunc) +CB_1(glutVisibilityFunc, int, Val_int) +CB_1_(glutCreateMenu,int, Val_int, Val_int) +CB_2(glutReshapeFunc, int, Val_int, int, Val_int) +CB_3(glutKeyboardFunc, unsigned char, Val_int, int, Val_int, int, Val_int) +CB_2(glutMotionFunc, int, Val_int, int, Val_int) +CB_3(glutSpecialFunc, int, Val_int, int, Val_int, int, Val_int) +CB_2(glutPassiveMotionFunc, int, Val_int, int, Val_int) +CB_1(glutEntryFunc, int, Val_int) +CB_3(glutSpaceballMotionFunc, int, Val_int, int, Val_int, int, Val_int) +CB_3(glutSpaceballRotateFunc, int, Val_int, int, Val_int, int, Val_int) +CB_2(glutSpaceballButtonFunc, int, Val_int, int, Val_int) +CB_2(glutButtonBoxFunc, int, Val_int, int, Val_int) +CB_2(glutDialsFunc, int, Val_int, int, Val_int) +CB_2(glutTabletMotionFunc, int, Val_int, int, Val_int) +CB_4(glutTabletButtonFunc, int, Val_int, int, Val_int, int, Val_int, int, Val_int) +CB_3(glutMenuStatusFunc, int, Val_int, int, Val_int, int, Val_int) +CB_0(glutOverlayDisplayFunc) +CB_4(glutMouseFunc, int, Val_int, int, Val_int, int, Val_int, int, Val_int) +CB_0(glutIdleFunc) + +CAMLprim value ml_glutSetIdleFuncToNull( value unit ) +{ + glutIdleFunc(NULL); + if (glutIdleFunc_value) { + caml_remove_global_root(&glutIdleFunc_value); + glutIdleFunc_value = 0; + } + return Val_unit; +} + +static value caml_glutTimerFunc_cb = 0; + +CAMLprim void init_glutTimerFunc_cb(value v) +{ + caml_glutTimerFunc_cb = v; + caml_register_global_root(&caml_glutTimerFunc_cb); +} + +static void glutTimerFunc_cb(int val) +{ + leave_blocking_section (); + callback (caml_glutTimerFunc_cb, (value) val); + enter_blocking_section (); +} + +CAMLprim value ml_glutTimerFunc(value millis, value timer_count) // set Timer callback +{ + glutTimerFunc(Int_val(millis), &glutTimerFunc_cb, (int) timer_count); // register with GLUT + return Val_unit; +} + +/* font stuff */ + +/* integer code to font */ +static void* i2font(int i) +{ + switch(i) { + case 0: return GLUT_STROKE_ROMAN; + case 1: return GLUT_STROKE_MONO_ROMAN; + case 2: return GLUT_BITMAP_9_BY_15; + case 3: return GLUT_BITMAP_8_BY_13; + case 4: return GLUT_BITMAP_TIMES_ROMAN_10; + case 5: return GLUT_BITMAP_TIMES_ROMAN_24; + case 6: return GLUT_BITMAP_HELVETICA_10; + case 7: return GLUT_BITMAP_HELVETICA_12; + case 8: return GLUT_BITMAP_HELVETICA_18; + default: + caml_failwith("wrap_glut.c: unrecognized font. impossible...\n"); + } +} + +CAMLprim value ml_glutBitmapCharacter(value font, value c) +{ + glutBitmapCharacter(i2font(Int_val(font)), Int_val(c)); + return Val_unit; +} + +CAMLprim value ml_glutBitmapWidth(value font, value c) +{ + return Val_int(glutBitmapWidth(i2font(Int_val(font)), Int_val(c))); +} + +CAMLprim value ml_glutStrokeCharacter(value font, value c) +{ + glutStrokeCharacter(i2font(Int_val(font)), Int_val(c)); + return Val_unit; +} + +CAMLprim value ml_glutStrokeWidth(value font, value c) +{ + return Val_int(glutStrokeWidth(i2font(Int_val(font)), Int_val(c))); +} + +/* GLUT 4 functions included with GLUT 3.7 */ +ML_1(glutInitDisplayString, String_val) +ML_2(glutWarpPointer, Int_val, Int_val) + +CAMLprim value ml_glutBitmapLength(value font, value str) +{ + /* need to do something about the unsignedness of the chars expected? */ + return Val_int(glutBitmapLength(i2font(Int_val(font)), String_val(str))); +} + +CAMLprim value ml_glutStrokeLength(value font, value str) +{ + /* need to do something about the unsignedness of the chars expected? */ + return Val_int(glutStrokeLength(i2font(Int_val(font)), String_val(str))); +} + +CB_1(glutWindowStatusFunc, int, Val_int) + +ML_1(glutPostWindowRedisplay, Int_val) + +ML_1(glutPostWindowOverlayRedisplay, Val_int) +CB_3(glutKeyboardUpFunc, unsigned char, Val_int, int, Val_int, int, Val_int) +CB_3(glutSpecialUpFunc, int, Val_int, int, Val_int, int, Val_int) +ML_1(glutIgnoreKeyRepeat, Int_val) +ML_1(glutSetKeyRepeat, Int_val) +CB__4(glutJoystickFunc, unsigned int, Val_int, int, Val_int, int, Val_int, int, Val_int, Int_val) +ML_0(glutForceJoystickFunc) + + diff --git a/META b/META new file mode 100644 index 0000000..a979cc5 --- /dev/null +++ b/META @@ -0,0 +1,19 @@ +description "Bindings for OpenGL" +version="1.05" +directory="+lablGL" +archive(byte) = "lablgl.cma" +archive(native) = "lablgl.cmxa" + +package "togl" ( + exists_if = "togl.cma,togl.cmxa" + requires = "labltk lablgl" + archive(byte) = "togl.cma" + archive(native) = "togl.cmxa" +) + +package "glut" ( + exists_if = "lablglut.cma,lablglut.cmxa" + requires = "lablgl" + archive(byte) = "lablglut.cma" + archive(native) = "lablglut.cmxa" +) \ No newline at end of file diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..ab3dc20 --- /dev/null +++ b/Makefile @@ -0,0 +1,48 @@ +# Main Makefile, to compile subdirectories + +# default +LIBDIR = `ocamlc -where` +INSTALLDIR = $(LIBDIR)/lablGL +DLLDIR = $(LIBDIR)/stublibs +CONFIG = Makefile.config +include $(CONFIG) + +all: lib togl glut + +opt: libopt toglopt glutopt + +lib: + cd src && $(MAKE) all LIBDIR="$(LIBDIR)" + +libopt: + cd src && $(MAKE) opt + +togl: lib + cd Togl/src && $(MAKE) all + +toglopt: libopt + cd Togl/src && $(MAKE) opt + +glut: lib + cd LablGlut/src && $(MAKE) + +glutopt: libopt + cd LablGlut/src && $(MAKE) opt + +preinstall: + cd src && $(MAKE) preinstall INSTALLDIR="$(INSTALLDIR)" DLLDIR="$(DLLDIR)" + cd Togl/src && $(MAKE) preinstall INSTALLDIR="$(INSTALLDIR)" DLLDIR="$(DLLDIR)" + cd LablGlut/src && $(MAKE) preinstall INSTALLDIR="$(INSTALLDIR)" DLLDIR="$(DLLDIR)" + +install: + @$(MAKE) real-install INSTALLDIR="$(INSTALLDIR)" DLLDIR="$(DLLDIR)" + +real-install: + cd src && $(MAKE) install + cd Togl/src && $(MAKE) install + cd LablGlut/src && $(MAKE) install + +clean: + cd src && $(MAKE) clean + cd Togl/src && $(MAKE) clean + cd LablGlut/src && $(MAKE) clean diff --git a/Makefile.common b/Makefile.common new file mode 100644 index 0000000..7da0bfe --- /dev/null +++ b/Makefile.common @@ -0,0 +1,57 @@ +# Common parts of the Makefile, shared by everybody + +# Ocaml commands +CAMLC=ocamlc +CAMLOPT=ocamlopt +COMPILER=$(CAMLC) -c -w s +OPTCOMP=$(CAMLOPT) -c +LIBRARIAN=ocamlmklib +OPTLIB=$(CAMLOPT) -a +LINKER=$(CAMLC) +OPTLINK=$(CAMLOPT) +SRCDIR=$(TOPDIR)/src +VAR2DEF=ocamlrun $(SRCDIR)/var2def +VAR2SWITCH=ocamlrun $(SRCDIR)/var2switch + +# Default settings +CONFIG = $(TOPDIR)/Makefile.config +LIBDIR = `$(CAMLC) -where` +DLLDIR = $(LIBDIR)/stublibs +INSTALLDIR = $(LIBDIR)/lablGL +TOGLDIR = Togl +TOGL_WS = TOGL_X11 +COPTS = -c -O + +# Default toolchain (unix) +TOOLCHAIN = unix +XA = .a +XB = +XE = +XO = .o +XS = .so + +# Windows specific +MKLIB=link /lib /nologo /debugtype:CV /out: +MKDLL=link /nologo /dll /out: +OCAMLDLL= "$(LIBDIR)/ocamlrun$(XA)" + +include $(CONFIG) + +# Default rules +.SUFFIXES: .ml .mli .cmo .cmi .cmx .c .var .h .opt $(XA) $(XO) $(XE) .d$(XO) + +.ml.cmo: + $(COMPILER) $(OCAMLINC) $< + +.ml.cmx: + $(OPTCOMP) $(OCAMLINC) $< + +.mli.cmi: + $(COMPILER) $(OCAMLINC) $< + +.c$(XO): + $(COMPILER) -ccopt "$(COPTS) $(INCLUDES)" $< + +.var.h: + $(VAR2DEF) < $< > $@ + diff --git a/Makefile.config.ex b/Makefile.config.ex new file mode 100644 index 0000000..87febe5 --- /dev/null +++ b/Makefile.config.ex @@ -0,0 +1,68 @@ +# LablGL and Togl configuration file +# +# Please have a look at the config/Makefile in the Objective Caml distribution, +# or at the labltklink script to get the information needed here +# + +##### Adjust these always + +# Uncomment if you have the fast ".opt" compilers +#CAMLC = ocamlc.opt +#CAMLOPT = ocamlopt.opt + +# Where to put the lablgl script +BINDIR = /usr/local/bin + +# Where to find X headers +XINCLUDES = -I/usr/X11R6/include +# X libs (for broken RTLD_GLOBAL: e.g. FreeBSD 4.0) +#XLIBS = -L/usr/X11R6/lib -lXext -lXmu -lX11 -lXi + +# Where to find Tcl/Tk headers +# This must the same version as for LablTk +TKINCLUDES = -I/usr/local/include +# Tcl/Tk libs (for broken RTLD_GLOBAL: e.g. FreeBSD 4.0) +#TKLIBS = -L/usr/local/lib -ltk84 -ltcl84 + +# Where to find OpenGL/Mesa/Glut headers and libraries +GLINCLUDES = +GLLIBS = -lGL -lGLU +GLUTLIBS = -lglut +# The following libraries may be required (try to add them one at a time) +#GLLIBS = -lGL -lGLU -lXmu -lXext -lXi -lcipher -lpthread + +# How to index a library after installing (ranlib required on MacOSX) +RANLIB = : +#RANLIB = ranlib + +##### Uncomment these for windows +#TKLIBS = tk83.lib tcl83.lib gdi32.lib user32.lib +#GLLIBS = opengl32.lib glu32.lib +#TOOLCHAIN = msvc +#XA = .lib +#XB = .bat +#XE = .exe +#XO = .obj +#XS = .dll + +##### Adjust these if non standard + +# The Objective Caml library directory +#LIBDIR = `ocamlc -where` + +# Where to put dlls (if dynamic loading available) +#DLLDIR = `ocamlc -where`/stublibs + +# Where to put LablGL (standard) +#INSTALLDIR = $(LIBDIR)/lablGL + +# Where is Togl (default) +#TOGLDIR = Togl + +# Togl Window System +# Should be one of TOGL_X11, TOGL_WGL (windows), TOGL_AGL (macosx) +# TOGL_AGL isn't supported currently +#TOGL_WS = TOGL_X11 + +# C Compiler options +#COPTS = -c -O diff --git a/Makefile.config.freebsd b/Makefile.config.freebsd new file mode 100644 index 0000000..208c6ce --- /dev/null +++ b/Makefile.config.freebsd @@ -0,0 +1,60 @@ +# LablGL and Togl configuration file +# +# Please have a look at the config/Makefile in the Objective Caml distribution, +# or at the labltklink script to get the information needed here +# + +# Makefile.config that has been tested under FreeBSD 4.8 + +##### Adjust these always + +# Where to put the lablgl script +BINDIR = /usr/local/bin + +# Where to find X headers +XINCLUDES = -I/usr/X11R6/include +# X libs (for broken RTLD_GLOBAL: e.g. FreeBSD 4.0) +XLIBS = -L/usr/X11R6/lib -lXext -lXmu -lX11 + +# Where to find Tcl/Tk headers +# This must the same version as for LablTk +TKINCLUDES = -I/usr/local/include/tcl8.4 -I/usr/local/include/tk8.4 +# Tcl/Tk libs (for broken RTLD_GLOBAL: e.g. FreeBSD 4.0) +TKLIBS = -L/usr/local/lib -ltk84 -ltcl84 + +# Where to find OpenGL/Mesa headers and libraries +GLINCLUDES = +GLLIBS = -lGL -lGLU +GLUTLIBS = -lglut +# The following libraries may be required (try to add them one at a time) + +# How to index a library after installing (required on MacOSX) +RANLIB = : +#RANLIB = ranlib + +##### Uncomment these for windows +#TKLIBS = tk83.lib tcl83.lib gdi32.lib user32.lib +#GLLIBS = opengl32.lib glu32.lib +#TOOLCHAIN = msvc +#XA = .lib +#XB = .bat +#XE = .exe +#XO = .obj +#XS = .dll + +##### Adjust these if non standard + +# The Objective Caml library directory +#LIBDIR = `ocamlc -where` + +# Where to put dlls (if dynamic loading available) +#DLLDIR = `ocamlc -where`/stublibs + +# Where to put LablGL (standard) +#INSTALLDIR = $(LIBDIR)/lablGL + +# Where is Togl (default) +#TOGLDIR = Togl + +# C Compiler options +#COPTS = -c -O diff --git a/Makefile.config.linux.mdk b/Makefile.config.linux.mdk new file mode 100644 index 0000000..1d39127 --- /dev/null +++ b/Makefile.config.linux.mdk @@ -0,0 +1,60 @@ +# LablGL and Togl configuration file +# +# Please have a look at the config/Makefile in the Objective Caml distribution, +# or at the labltklink script to get the information needed here +# + +# Makefile.config that has been tested under Linux Mandrake 9.1 + +##### Adjust these always + +# Where to put the lablgl script +BINDIR = /usr/local/bin + +# Where to find X headers +XINCLUDES = -I/usr/X11R6/include +# X libs (for broken RTLD_GLOBAL: e.g. FreeBSD 4.0) +XLIBS = -L/usr/X11R6/lib -lXext -lXmu -lX11 + +# Where to find Tcl/Tk headers +# This must the same version as for LablTk +TKINCLUDES = +# Tcl/Tk libs (for broken RTLD_GLOBAL: e.g. FreeBSD 4.0) +TKLIBS = + +# Where to find OpenGL/Mesa headers and libraries +GLINCLUDES = +GLLIBS = -lGL -lGLU +GLUTLIBS = -lglut +# The following libraries may be required (try to add them one at a time) + +# How to index a library after installing (required on MacOSX) +RANLIB = : +#RANLIB = ranlib + +##### Uncomment these for windows +#TKLIBS = tk83.lib tcl83.lib gdi32.lib user32.lib +#GLLIBS = opengl32.lib glu32.lib +#TOOLCHAIN = msvc +#XA = .lib +#XB = .bat +#XE = .exe +#XO = .obj +#XS = .dll + +##### Adjust these if non standard + +# The Objective Caml library directory +#LIBDIR = `ocamlc -where` + +# Where to put dlls (if dynamic loading available) +#DLLDIR = `ocamlc -where`/stublibs + +# Where to put LablGL (standard) +#INSTALLDIR = $(LIBDIR)/lablGL + +# Where is Togl (default) +#TOGLDIR = Togl + +# C Compiler options +#COPTS = -c -O diff --git a/Makefile.config.mingw b/Makefile.config.mingw new file mode 100644 index 0000000..30a25e0 --- /dev/null +++ b/Makefile.config.mingw @@ -0,0 +1,78 @@ +# LablGL and Togl configuration file +# +# Please have a look at the config/Makefile in the Objective Caml distribution, +# or at the labltklink script to get the information needed here +# + +##### Adjust these always + +# Uncomment if you have the fast ".opt" compilers +CAMLC = ocamlc.opt +CAMLOPT = ocamlopt.opt +LIBRARIAN = ocamlmklib -verbose -ocamlc ocamlc -ocamlopt ocamlopt + +# Where to put the lablgl script +OCAMLDIR = c:/OCaml +BINDIR = $(OCAMLDIR)/bin +DLLDIR = $(OCAMLDIR)/lib/stublibs +INSTALLDIR = $(OCAMLDIR)/lib/lablGL + +# Where to find X headers +#XINCLUDES = -I/usr/X11R6/include +# X libs (for broken RTLD_GLOBAL: e.g. FreeBSD 4.0) +#XLIBS = -L/usr/X11R6/lib -lXext -lXmu -lX11 + +# Where to find Tcl/Tk headers +# This must the same version as for LablTk +TK_ROOT = C:/Tcl +TKINCLUDES = -I"$(TK_ROOT)/include" +# Tcl/Tk libs (for broken RTLD_GLOBAL: e.g. FreeBSD 4.0) +#TKLIBS = -ltk83 -ltcl83 +#TKLIBS = -ldopt "$(TK_ROOT)/bin/tcl85.dll" -ldopt "$(TK_ROOT)/bin/tk85.dll" +TKLIBS0 = -L$(TK_ROOT)/lib tcl85.lib tk85.lib -lws2_32 -luser32 -lgdi32 +TKLIBS = -ldopt -L$(TK_ROOT)/bin -ldopt tcl85.dll -ldopt tk85.dll \ + -ccopt -L$(TK_ROOT)/lib -cclib tcl85.lib -cclib tk85.lib \ + -lws2_32 -luser32 -lgdi32 + +# Where to find OpenGL/Mesa/Glut headers and libraries +GLINCLUDES = -DHAS_GLEXT_H -DGL_GLEXT_PROTOTYPES -DGLU_VERSION_1_3 +GLLIBS = -lglu32 -lopengl32 +GLLIBS0 = $(GLLIBS) +GLUTLIBS = -lglut32 +GLUTLIBS0 = $(GLUTLIBS) +# The following libraries may be required (try to add them one at a time) +#GLLIBS = -lGL -lGLU -lXmu -lXext -lXi -lcipher -lpthread + +# How to index a library after installing (ranlib required on MacOSX) +RANLIB = : +#RANLIB = ranlib + +##### Uncomment these for windows +#TOOLCHAIN = msvc +XB = .bat +XE = .exe +XS = .dll +MKLIB = ar rcs +MKDLL = gcc -mno-cygwin -shared -o +##### Adjust these if non standard + +# The Objective Caml library directory +# must set it by hand as spaces are not allowed +#LIBDIR = `ocamlc -where` + +# Where to put dlls (if dynamic loading available) +#DLLDIR = `ocamlc -where`/stublibs + +# Where to put LablGL (standard) +#INSTALLDIR = $(LIBDIR)/lablGL + +# Where is Togl (default) +#TOGLDIR = Togl + +# Togl Window System +# Should be one of TOGL_X11, TOGL_WGL (windows), TOGL_AGL (macosx) +# TOGL_AGL isn't supported currently +TOGL_WS = TOGL_WGL + +# C Compiler options +COPTS = -c -O -DHAS_SYS_TIME diff --git a/Makefile.config.msvc b/Makefile.config.msvc new file mode 100644 index 0000000..1273098 --- /dev/null +++ b/Makefile.config.msvc @@ -0,0 +1,74 @@ +# LablGL and Togl configuration file +# +# Please have a look at the config/Makefile in the Objective Caml distribution, +# or at the labltklink script to get the information needed here +# + +##### Adjust these always + +# Uncomment if you have the fast ".opt" compilers +CAMLC = ocamlc.opt +CAMLOPT = ocamlopt.opt +LIBRARIAN = ocamlmklib -verbose -ocamlc ocamlc -ocamlopt ocamlopt + +# Where to put the lablgl script +OCAMLDIR = c:/Program Files/Objective Caml MSVC +BINDIR = $(OCAMLDIR)/bin +DLLDIR = $(OCAMLDIR)/lib/stublibs +INSTALLDIR = $(OCAMLDIR)/lib/lablGL + +# Where to find X headers +XINCLUDES = -I/usr/X11R6/include +# X libs (for broken RTLD_GLOBAL: e.g. FreeBSD 4.0) +#XLIBS = -L/usr/X11R6/lib -lXext -lXmu -lX11 + +# Where to find Tcl/Tk headers +# This must the same version as for LablTk +TK_ROOT = C:/Tcl +TKINCLUDES = -I$(TK_ROOT)/include +# Tcl/Tk libs (for broken RTLD_GLOBAL: e.g. FreeBSD 4.0) +TKLIBS0 = -L$(TK_ROOT)/lib tk84.lib tcl84.lib gdi32.lib user32.lib +TKLIBS = -ldopt "$(TKLIBS0)" -cclib "$(TKLIBS0)" + +# Where to find OpenGL/Mesa/Glut headers and libraries +GLINCLUDES = +GLLIBS0 = opengl32.lib glu32.lib +GLLIBS = -ldopt "$(GLLIBS0)" -cclib "$(GLLIBS0)" +GLUTLIBS0 = glut32.lib +GLUTLIBS = -ldopt "$(GLUTLIBS0)" -cclib "$(GLUTLIBS0)" +# The following libraries may be required (try to add them one at a time) +#GLLIBS = -lGL -lGLU -lXmu -lXext -lXi -lcipher -lpthread + +# How to index a library after installing (ranlib required on MacOSX) +RANLIB = : +#RANLIB = ranlib + +##### Uncomment these for windows +#TOOLCHAIN = msvc +XA = .lib +XB = .bat +XE = .exe +XO = .obj +XS = .dll + +##### Adjust these if non standard + +# The Objective Caml library directory +#LIBDIR = `ocamlc -where` + +# Where to put dlls (if dynamic loading available) +#DLLDIR = `ocamlc -where`/stublibs + +# Where to put LablGL (standard) +#INSTALLDIR = $(LIBDIR)/lablGL + +# Where is Togl (default) +#TOGLDIR = Togl + +# Togl Window System +# Should be one of TOGL_X11, TOGL_WGL (windows), TOGL_AGL (macosx) +# TOGL_AGL isn't supported currently +TOGL_WS = TOGL_WGL + +# C Compiler options +COPTS = -c diff --git a/Makefile.config.osx b/Makefile.config.osx new file mode 100644 index 0000000..404f8d1 --- /dev/null +++ b/Makefile.config.osx @@ -0,0 +1,54 @@ +# LablGL and Togl configuration file +# +# Please have a look at the config/Makefile in the Objective Caml distribution, +# or at the labltklink script to get the information needed here +# + +##### Adjust these always + +# Uncomment if you have the fast ".opt" compilers +CAMLC = ocamlc.opt +CAMLOPT = ocamlopt.opt + +# Where to put the lablgl script +BINDIR = /usr/local/bin + +# Where to find Tcl/Tk headers +# This must be the same version as for LablTk +# On OSX, Togl works only with the X11 version of Tk +# Here we use the X11 version of tk and mesa installed by macports +# While we only use the GLX part of mesa, the libGL.dylib in +# /usr/X11/lib is not compatible with macports. +TKINCLUDES = -I/opt/local/include +# Libs for Togl +TKLIBS = -L/opt/local/lib -lGL -lXmu + +# Where to find OpenGL/Mesa headers and libraries +GLINCLUDES = +GLLIBS = -framework OpenGL +GLUTLIBS = -framework GLUT + +# How to index a library after installing (ranlib required on MacOSX) +RANLIB = ranlib + +##### Adjust these if non standard + +# The Objective Caml library directory +#LIBDIR = `ocamlc -where` + +# Where to put dlls (if dynamic loading available) +#DLLDIR = `ocamlc -where`/stublibs + +# Where to put LablGL (standard) +#INSTALLDIR = $(LIBDIR)/lablGL + +# Where is Togl (default) +#TOGLDIR = Togl + +# Togl Window System +# Should be one of TOGL_X11, TOGL_WGL (windows), TOGL_AGL (macosx) +# TOGL_AGL isn't supported currently +#TOGL_WS = TOGL_X11 + +# C Compiler options +#COPTS = -c -O diff --git a/Makefile.config.ubuntu b/Makefile.config.ubuntu new file mode 100644 index 0000000..c8f1630 --- /dev/null +++ b/Makefile.config.ubuntu @@ -0,0 +1,60 @@ +# LablGL and Togl configuration file +# +# Please have a look at the config/Makefile in the Objective Caml distribution, +# or at the labltklink script to get the information needed here +# + +# Makefile.config that has been tested under Linux Mandrake 9.1 + +##### Adjust these always + +# Where to put the lablgl script +BINDIR = /usr/local/bin + +# Where to find X headers +XINCLUDES = +# X libs (for broken RTLD_GLOBAL: e.g. FreeBSD 4.0) +XLIBS = -lXext -lXmu -lX11 + +# Where to find Tcl/Tk headers +# This must the same version as for LablTk +TKINCLUDES = -I/usr/include/tcl8.5 +# Tcl/Tk libs (for broken RTLD_GLOBAL: e.g. FreeBSD 4.0) +TKLIBS = + +# Where to find OpenGL/Mesa headers and libraries +GLINCLUDES = +GLLIBS = -lGL -lGLU +GLUTLIBS = -lglut +# The following libraries may be required (try to add them one at a time) + +# How to index a library after installing (required on MacOSX) +RANLIB = : +#RANLIB = ranlib + +##### Uncomment these for windows +#TKLIBS = tk83.lib tcl83.lib gdi32.lib user32.lib +#GLLIBS = opengl32.lib glu32.lib +#TOOLCHAIN = msvc +#XA = .lib +#XB = .bat +#XE = .exe +#XO = .obj +#XS = .dll + +##### Adjust these if non standard + +# The Objective Caml library directory +#LIBDIR = `ocamlc -where` + +# Where to put dlls (if dynamic loading available) +#DLLDIR = `ocamlc -where`/stublibs + +# Where to put LablGL (standard) +#INSTALLDIR = $(LIBDIR)/lablGL + +# Where is Togl (default) +#TOGLDIR = Togl + +# C Compiler options +#COPTS = -c -O diff --git a/README b/README new file mode 100644 index 0000000..95c86b6 --- /dev/null +++ b/README @@ -0,0 +1,376 @@ + + LablGL 1.05: Installation and Use instructions + +1. Description + + LablGL is an OpenGL interface for Objective Caml. It includes two +interfaces: the Togl widget, for comfortable use with LablTk, and +LablGlut for standalone applications not using Tcl/Tk. + +2. Requisites + + * Objective Caml 3.05 to 4.01 + * LablTk (included in Objective Caml, requires Tcl/Tk) for Togl support + * OpenGL + * glut (included in Mesa) for glut support + * GNU make (for conditionals) + + Objective Caml can be obtained from + http://caml.inria.fr/ocaml/ + + OpenGL (with hardware support) may already be on your machine. + XFree86 supports the GLX protocol since version 4.0, with hardware +acceleration on some platforms. It is available on most recent Linux +configurations. + If you are not lucky enough to have built-in OpenGL support, you can +still use Mesa, an openGL-compatible freeware, which works on almost +everything. + http://www.mesa3d.org/ + + LablGl also uses the Togl widget, but the code is already included +in this distribution (version 1.7). You may obtain more information +about Togl at: + http://www.mesa3d.org/brianp/Togl.html +Note that Togl is only compatible with vanilla Tcl/Tk: specially +patched versions may not work. For instance 8.2.3+ included in old +debian distributions does not work. + + LablGlut requires glut, which is already included in recent versions +of Mesa and XFree86. For windows you need to obtain it from + http://www.xmission.com/~nate/glut.html + +3. Installation + +Precompiled versions of lablGL are available for Windows, and a number +of Unix versions. For Linux, just install the package. + +Windows binary distribution: + The file lablgl-1.05-win32.zip supports the mingw windows installer + for ocaml 4.01. + + a) Install the lablGL distribution. + The simplest way is to use the command-line version of unzip, and + unpack it on top of your Objective Caml distribution. + C:\Program Files\Objective Caml> unzip lablgl-1.04-win32.zip + If you unpacked it somewhere else you must copy manually the + contents of the bin, lib\stublibs and lib\lablGL directories to + the corresponding directories of the Objective Caml distribution. + + b) Compile the Caml parts. + Go to the lib\lablGL directory, and execute the following command + C:\...\lib\lablGL\> ocaml build.ml + It will generate the bytecode and native versions of the library. + Note that every time you install a new version of Objective Caml + you will need to repeat this last step. + Look carefully at the last line of output of this script, it should + tell you which ocaml port you are using. If the guess is wrong, you + edit build.ml to correct this. + + c) For glut support, download glut32.dll and copy it to the bin + directory of the OCaml distribution (or somewhere else in your + path.) + + After this, you should be able to compile and run programs as either + bytecode or native code. + +Compilation from source (if there is no package): + + 0) On MacOSX, if you want to use Togl, you must use the X11 version + of Tcl/Tk. Here we assume that ocaml was installed from macports. + Then you must also install the mesa port from macports, to obtain + a compatible version of GLX. + + a) Create Makefile.config. + Some tested configurations are provided. + If none of them fits your needs, start with Makefile.config.ex. + + b) Build LablGL with both Togl(Tcl/Tk) and Glut support. + % make + + If you need only Togl support, do + % make togl + If you need only Glut support, do + % make glut + If you need neither (use the library with lablGtk for instance) + % make lib + + + c) For the native code version (you need the native code version of LablTk), + % make opt + + Similarly, you can also do + % make {toglopt,glutopt,libopt} + + d) Install LablGL + % make install + + This will install all the available parts. + + To compile for Windows, Makefile.config.msvc and + Makefile.config.mingw are provided. Note however that the DLL + produced for Togl by mingw does not work with the ocaml 3.11 binary + distribution, you must use the one produced by MSVC, included in + the binary distribution above. + +4. Use + + Examples are in the Togl/examples and LablGlut/examples directories. + + * The lablgl toplevel + This is a toplevel, like ocaml, including LablTk, Unix, Str, LablGL + and Togl. + You may use it either as a toplevel, or directly to run scripts. + To run an example in Togl/examples, type: + % lablgl example.ml + where example.ml is one of: (by order of complexity) + simple.ml + scene.ml + checker.ml + double.ml + planet.ml + texturesurf.ml + gears.ml + morph3d.ml + tennis.ml + + Note that some XFree86 do not seem to support single buffer + rendering. The first 3 examples will not work in that case. + + * Similarely, there is a lablglut toplevel. + For instance, move to the folder LablGlut/examples/lablGL and type + + % lablglut gears.ml + + * compiling and linking + You need to include either labltk.cma, lablgl.cma and togl.cma or' + lablgl.cma and lablglut.cma in your link: + ocamlc -I +labltk -I +lablGL \ + labltk.cma lablgl.cma togl.cma ... -o program + ocamlc -I +lablGL lablgl.cma lablglut.cma ... -o program + +5. Writing programs + + All of the GL and GLU libraries are available. Read a good book + about how to use these. Translating from OpenGL to LablGL is rather + straightforward: there is a LablGL function for each OpenGL one. + For ease of retrieving, both GL and GLU are cut in smaller modules + of related functions. See in appendix A which modules your function + is in. By default it has the same name, gl or glu omited, and + capitals replaced by underscores. When arguments are labelled, the + names are taken from the man page or the C prototype. + + OpenGL makes heavy use of enumerations, with names starting with + GL_ or GLU_ . Since their meaning is often overloaded, they are all + converted to polymorphic variants. In most cases just replace prefix + by a backquote and convert to low case. When you have a doubt the + best way is to have a look with OCamlBrowser. + + Using Togl is also straightforward. Everything works like in + LablTk. You create an openGL widget with Togl.create, and then you + apply various functions on it. See Togl's README in Togl/src/Togl/README + for details. + + To use LablGlut you need to look at glut's documentation on your system. + The approach is close to LablGL's. + +6. Comments and bug reports + + mailto:garrigue@kurims.kyoto-u.ac.jp + + This library has been tested on a number of programs, but this is + far from testing all of OpenGL functionality. There are bugs, but + at least we didn't find any in our examples. + +7. Authors + + Jacques Garrigue, Isaac Trotts, Erick Tryzelaar and Christophe + Raffali participated to this release. + +A. Modules + + There are 12 modules for GL and 5 modules for GLU. + Modules marked with (*) contain LablGL specific functions. + +Gl: Common data types and functions. + glFlush + glFinish + glEnable + glDisable + glIsEnabled + glGetError + +GlArray: Array functions + glEdgeFlagPointer -> edge_flag + glTexCoordPointer -> tex_coord + glIndexPointer -> index + glNormalPointer -> normal + glVertexPointer -> vertex + glEnableClientState -> enable + glDisableClientState -> disable + glArrayElement -> element + glDrawArrays + glDrawElements + +GlClear: Clearing functions. + glClear + glClearAccum -> accum + glClearColor -> color + glClearDepth -> depth + glClearIndex -> index + glClearStencil -> stencil + +GlDraw: Drawing functions. + glBegin -> begins + glColor + glCullFace + glEdgeFlag + glEnd -> ends + glFrontFace + glIndex + glLineStipple + glLineWidth + glNormal + glPointSize + glPolygonOffset + glPolygonMode + glPolygonStipple + glRect + glShadeModel + glVertex + glViewport + +GlFunc: Filtering functions. + glAccum + glAlphaFunc + glBlendFunc + glColorMask + glDepthFunc + glDepthMask + glDrawBuffer + glIndexMask + glLogicOp + glReadBuffer + glStencilFunc + glStencilMask + glStencilOp + +GlLight: Lighting functions. + glColorMaterial + glFog + glLight + glLightModel (gl 1.2 with `color_control) + glMaterial + +GlList: Call list functions. (*) + glCallList -> call + glCallLists + glDeleteLists + glEndList -> ends + glGenLists + glIsList + glNewList -> begins + +GlMap: Map and meshes functions. + glEvalCoord1 + glEvalCoord2 + glEvalMesh1 + glEvalMesh2 + glEvalPoint1 + glEvalPoint2 + glMap1 + glMap2 + glMapGrid1 -> grid1 + glMapGrid2 -> grid2 + +GlMat: Matrix functions. (*) + glFrustum + glLoadIdentity + glLoadMatrix -> load + glLoadTransposeMatrix -> load_transpose (gl 1.3) + glMatrixMode -> mode + glMultMatrix -> mult + glMultTransposeMatrix -> mult_transpose (gl 1.3) + glOrtho + glPopMatrix -> pop + glPushMatrix -> push + glRotate + glScale + glTranslate + glGetDoublev -> get_matrix (only for modelview, projection, and texture) + +GlMisc: Miscellanous functions. + glClipPlane + glGetString + glHint + glInitNames + glLoadName + glPassThrough + glPopAttrib + glPopName + glPushAttrib + glPushName + glRenderMode + glScissor + glSelectBuffer + +GlPix: Rasterized pixel functions. (*) + glBitmap + glCopyPixels -> copy + glDrawPixels -> draw + glPixelMap -> map + glPixelStore -> store + glPixelTransfer -> transfer + glPixelZoom -> zoom + glRasterPos + glReadPixels -> read + +GlTex: Texturing functions. + glTexCoord -> coord + glTexEnv -> env + glTexGen -> gen + glTexImage1D -> image1d + glTexImage2D -> image2d + glTexParameter -> parameter (gl 1.4 with generate_mipmap) + +GluMat: GLU matrix functions. + gluLookAt + gluOrtho2D + gluPerspective + gluPickMatrix + gluProject + gluUnProject + +GluMisc: GLU miscellanous functions. + gluBuild1DMipmaps + gluBuild2DMipmaps + gluGetString + gluScaleImage + +GluNurbs: Nurbs functions. + gluBeginCurve + gluBeginSurface + gluBeginTrim + gluEndCurve + gluEndSurface + gluEndTrim + gluLoadSamplingMatrices + gluNewNurbsRenderer -> create + gluNurbsCurve -> curve + gluNurbsProperty -> property + gluNurbsPwlCurve -> pwl_curve + gluNurbsSurface -> surface + +GluQuadric: Quadric functions. + gluCylinder + gluDisk + gluNewQuadric -> create + gluPartialDisk + gluQuadricDrawStyle -> draw_style + gluQuadricNormals -> normals + gluQuadricOrientation -> orientation + gluQuadricTexture -> texture + gluSphere + +GluTess: Tessalating functions. + Only glu 1.2 API is supported. + Either render directly or produce lists of triangles. diff --git a/Togl/examples/Makefile b/Togl/examples/Makefile new file mode 100644 index 0000000..86fe6ca --- /dev/null +++ b/Togl/examples/Makefile @@ -0,0 +1,4 @@ +# Makefile for examples subdir + +clean: + rm -f *.cm* *.o *.opt diff --git a/Togl/examples/README b/Togl/examples/README new file mode 100644 index 0000000..9918d96 --- /dev/null +++ b/Togl/examples/README @@ -0,0 +1,3 @@ +$Id: README,v 1.3 2003-09-26 08:25:27 garrigue Exp $ + +Here are a few examples for LablGL. diff --git a/Togl/examples/checker.ml b/Togl/examples/checker.ml new file mode 100644 index 0000000..d0ad71b --- /dev/null +++ b/Togl/examples/checker.ml @@ -0,0 +1,73 @@ +(* $Id: checker.ml,v 1.8 2001-05-08 01:58:25 garrigue Exp $ *) + +let image_height = 64 +and image_width = 64 + +let make_image () = + let image = + GlPix.create `ubyte ~format:`rgb ~width:image_width ~height:image_height in + for i = 0 to image_width - 1 do + for j = 0 to image_height - 1 do + Raw.sets (GlPix.to_raw image) ~pos:(3*(i*image_height+j)) + (if (i land 8 ) lxor (j land 8) = 0 + then [|255;255;255|] + else [|0;0;0|]) + done + done; + image + +let myinit () = + GlClear.color (0.0, 0.0, 0.0); + Gl.enable `depth_test; + GlFunc.depth_func `less; + + let image = make_image () in + GlPix.store (`unpack_alignment 1); + GlTex.image2d image; + List.iter (GlTex.parameter ~target:`texture_2d) + [ `wrap_s `clamp; + `wrap_t `clamp; + `mag_filter `nearest; + `min_filter `nearest ]; + GlTex.env (`mode `decal); + Gl.enable `texture_2d; + GlDraw.shade_model `flat + +let display () = + GlClear.clear [`color;`depth]; + GlDraw.begins `quads; + GlTex.coord2(0.0, 0.0); GlDraw.vertex3(-2.0, -1.0, 0.0); + GlTex.coord2(0.0, 1.0); GlDraw.vertex3(-2.0, 1.0, 0.0); + GlTex.coord2(1.0, 1.0); GlDraw.vertex3(0.0, 1.0, 0.0); + GlTex.coord2(1.0, 0.0); GlDraw.vertex3(0.0, -1.0, 0.0); + + GlTex.coord2(0.0, 0.0); GlDraw.vertex3(1.0, -1.0, 0.0); + GlTex.coord2(0.0, 1.0); GlDraw.vertex3(1.0, 1.0, 0.0); + GlTex.coord2(1.0, 1.0); GlDraw.vertex3(2.41421, 1.0, -1.41421); + GlTex.coord2(1.0, 0.0); GlDraw.vertex3(2.41421, -1.0, -1.41421); + GlDraw.ends (); + Gl.flush () + +let reshape togl = + let w = Togl.width togl and h = Togl.height togl in + GlDraw.viewport ~x:0 ~y:0 ~w ~h; + GlMat.mode `projection; + GlMat.load_identity (); + GluMat.perspective ~fovy:60.0 ~aspect:(1.0 *. float w /. float h) ~z:(1.0,30.0); + GlMat.mode `modelview; + GlMat.load_identity (); + GlMat.translate ~z:(-3.6) () + +open Tk + +let main () = + let top = openTk () in + let togl = + Togl.create ~width:500 ~height:500 ~rgba:true ~depth:true top in + myinit (); + Togl.display_func togl ~cb:display; + Togl.reshape_func togl ~cb:(fun () -> reshape togl); + pack ~expand:true ~fill:`Both [togl]; + mainLoop () + +let _ = main () diff --git a/Togl/examples/double.ml b/Togl/examples/double.ml new file mode 100644 index 0000000..c54ff4d --- /dev/null +++ b/Togl/examples/double.ml @@ -0,0 +1,124 @@ +(* $Id: double.ml,v 1.11 2001-05-08 01:58:25 garrigue Exp $ *) + +class view togl ~title = object (self) + val mutable corner_x = 0. + val mutable corner_y = 0. + val mutable corner_z = 0. + val font_base = Togl.load_bitmap_font togl ~font:`Fixed_8x13 + val mutable x_angle = 0. + val mutable y_angle = 0. + val mutable z_angle = 0. + + method togl = togl + + method reshape = + let width = Togl.width togl and height = Togl.height togl in + let aspect = float width /. float height in + GlDraw.viewport ~x:0 ~y:0 ~w:width ~h:height; + (* Set up projection transform *) + GlMat.mode `projection; + GlMat.load_identity (); + GlMat.frustum ~x:(-.aspect, aspect) ~y:(-1.0, 1.0) ~z:(1.0, 10.0); + corner_x <- -. aspect; + corner_y <- -1.0; + corner_z <- -1.1; + (* Change back to model view transform for rendering *) + GlMat.mode `modelview + + method print_string s = + GlList.call_lists ~base:font_base(`byte s) + + method display = + GlClear.clear [`color;`depth]; + GlMat.load_identity(); (* Reset modelview matrix to the identity matrix *) + GlMat.translate ~z:(-3.0) (); (* Move the camera back three units *) + GlMat.rotate ~angle:x_angle ~x:1. (); (* Rotate by X, Y, Z angles *) + GlMat.rotate ~angle:y_angle ~y:1. (); + GlMat.rotate ~angle:z_angle ~z:1. (); + + Gl.enable `depth_test; + + (* Front face *) + GlDraw.begins `quads; + GlDraw.color (0.0, 0.7, 0.1); (* Green *) + GlDraw.vertex3 (-1.0, 1.0, 1.0); + GlDraw.vertex3(1.0, 1.0, 1.0); + GlDraw.vertex3(1.0, -1.0, 1.0); + GlDraw.vertex3(-1.0, -1.0, 1.0); + (* Back face *) + GlDraw.color (0.9, 1.0, 0.0); (* Yellow *) + GlDraw.vertex3(-1.0, 1.0, -1.0); + GlDraw.vertex3(1.0, 1.0, -1.0); + GlDraw.vertex3(1.0, -1.0, -1.0); + GlDraw.vertex3(-1.0, -1.0, -1.0); + (* Top side face *) + GlDraw.color (0.2, 0.2, 1.0); (* Blue *) + GlDraw.vertex3(-1.0, 1.0, 1.0); + GlDraw.vertex3(1.0, 1.0, 1.0); + GlDraw.vertex3(1.0, 1.0, -1.0); + GlDraw.vertex3(-1.0, 1.0, -1.0); + (* Bottom side face *) + GlDraw.color (0.7, 0.0, 0.1); (* Red *) + GlDraw.vertex3(-1.0, -1.0, 1.0); + GlDraw.vertex3(1.0, -1.0, 1.0); + GlDraw.vertex3(1.0, -1.0, -1.0); + GlDraw.vertex3(-1.0, -1.0, -1.0); + GlDraw.ends(); + + Gl.disable `depth_test; + GlMat.load_identity(); + GlDraw.color( 1.0, 1.0, 1.0 ); + GlPix.raster_pos ~x:corner_x ~y:corner_y ~z:corner_z (); + self#print_string title; + Togl.swap_buffers togl + + method x_angle a = x_angle <- a; Togl.render togl + method y_angle a = y_angle <- a; Togl.render togl + method z_angle a = z_angle <- a; Togl.render togl +end + +let create_view ~parent ~double = + new view + (Togl.create ~width:200 ~height:200 ~depth:true ~rgba:true ~double parent) + +open Tk + +let main () = + let top = openTk () in + let f = Frame.create top in + let single = create_view ~parent:f ~double:false ~title:"Single buffer" + and double = create_view ~parent:f ~double:true ~title:"Double buffer" in + let sx = + Scale.create ~label:"X Axis" ~min:0. ~max:360. ~orient:`Horizontal + ~command:(fun x -> single#x_angle x; double#x_angle x) top + and sy = + Scale.create ~label:"Y Axis" ~min:0. ~max:360. ~orient:`Horizontal + ~command:(fun y -> single#y_angle y; double#y_angle y) top + and button = + Button.create ~text:"Quit" ~command:(fun () -> destroy top) top + in + + List.iter + (fun o -> + Togl.display_func o#togl ~cb:(fun () -> o#display); + Togl.reshape_func o#togl ~cb:(fun () -> o#reshape); + bind o#togl ~events:[`Modified([`Button1],`Motion)] + ~fields:[`MouseX;`MouseY] + ~action:(fun ev -> + let width = Togl.width o#togl + and height =Togl.height o#togl + and x = ev.ev_MouseX + and y = ev.ev_MouseY in + let x_angle = 360. *. float y /. float height + and y_angle = 360. *. float (width - x) /. float width in + Scale.set sx x_angle; + Scale.set sy y_angle)) + [single;double]; + + pack ~side:`Left ~padx:3 ~pady:3 ~fill:`Both ~expand:true + [single#togl; double#togl]; + pack ~fill:`Both ~expand:true [f]; + pack ~fill:`X [coe sx; coe sy; coe button]; + mainLoop () + +let _ = main () diff --git a/Togl/examples/gears.ml b/Togl/examples/gears.ml new file mode 100644 index 0000000..3e86fde --- /dev/null +++ b/Togl/examples/gears.ml @@ -0,0 +1,245 @@ +(* $Id: gears.ml,v 1.16 2001-05-08 01:58:25 garrigue Exp $ *) + +(* + * 3-D gear wheels. This program is in the public domain. + * + * Brian Paul + * LablGL version by Jacques Garrigue + *) + +let pi = acos (-1.) + +(* + * 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: inner_radius - radius of hole at center + * outer_radius - radius at center of teeth + * width - width of gear + * teeth - number of teeth + * tooth_depth - depth of tooth + *) +let gear ~inner ~outer ~width ~teeth ~tooth_depth = + let r0 = inner + and r1 = outer -. tooth_depth /. 2.0 + and r2 = outer +. tooth_depth /. 2.0 in + + let ta = 2.0 *. pi /. float teeth in + let da = ta /. 4.0 in + + GlDraw.shade_model `flat; + + GlDraw.normal ~z:1.0 (); + + let vertex ~r ~z ?(s=0) i = + let angle = float i *. ta +. float s *. da in + GlDraw.vertex ~x:(r *. cos angle) ~y:(r *. sin angle) ~z () + in + + (* draw front face *) + let z = width *. 0.5 in + GlDraw.begins `quad_strip; + for i=0 to teeth do + vertex i ~r:r0 ~z; + vertex i ~r:r1 ~z; + vertex i ~r:r0 ~z; + vertex i ~r:r1 ~z ~s:3; + done; + GlDraw.ends (); + + (* draw front sides of teeth *) + GlDraw.begins `quads; + for i=0 to teeth - 1 do + vertex i ~r:r1 ~z; + vertex i ~r:r2 ~s:1 ~z; + vertex i ~r:r2 ~s:2 ~z; + vertex i ~r:r1 ~s:3 ~z; + done; + GlDraw.ends (); + + GlDraw.normal ~z:(-1.0) (); + + (* draw back face *) + let z = -. width *. 0.5 in + GlDraw.begins `quad_strip; + for i=0 to teeth do + vertex i ~r:r1 ~z; + vertex i ~r:r0 ~z; + vertex i ~r:r1 ~s:3 ~z; + vertex i ~r:r0 ~z; + done; + GlDraw.ends (); + + (* draw back sides of teeth *) + GlDraw.begins `quads; + for i=0 to teeth - 1 do + vertex i ~r:r1 ~s:3 ~z; + vertex i ~r:r2 ~s:2 ~z; + vertex i ~r:r2 ~s:1 ~z; + vertex i ~r:r1 ~z; + done; + GlDraw.ends (); + + (* draw outward faces of teeth *) + let z = width *. 0.5 and z' = width *. (-0.5) in + GlDraw.begins `quad_strip; + for i=0 to teeth - 1 do + let angle = float i *. ta in + vertex i ~r:r1 ~z; + vertex i ~r:r1 ~z:z'; + let u = r2 *. cos(angle+.da) -. r1 *. cos(angle) + and v = r2 *. sin(angle+.da) -. r1 *. sin(angle) in + GlDraw.normal ~x:v ~y:(-.u) (); + vertex i ~r:r2 ~s:1 ~z; + vertex i ~r:r2 ~s:1 ~z:z'; + GlDraw.normal ~x:(cos angle) ~y:(sin angle) (); + vertex i ~r:r2 ~s:2 ~z; + vertex i ~r:r2 ~s:2 ~z:z'; + let u = r1 *. cos(angle +. 3. *. da) -. r2 *. cos(angle +. 2. *. da) + and v = r1 *. sin(angle +. 3. *. da) -. r2 *. sin(angle +. 2. *. da) in + GlDraw.normal ~x:v ~y:(-.u) (); + vertex i ~r:r1 ~s:3 ~z; + vertex i ~r:r1 ~s:3 ~z:z'; + GlDraw.normal ~x:(cos angle) ~y:(sin angle) (); + done; + vertex 0 ~r:r1 ~z; + vertex 0 ~r:r1 ~z:z'; + GlDraw.ends (); + + GlDraw.shade_model `smooth; + + (* draw inside radius cylinder *) + GlDraw.begins `quad_strip; + for i=0 to teeth do + let angle = float i *. ta in + GlDraw.normal ~x:(-. cos angle) ~y:(-. sin angle) (); + vertex i ~r:r0 ~z:z'; + vertex i ~r:r0 ~z; + done; + GlDraw.ends () + +class view ~gear1 ~gear2 ~gear3 ?(limit=0) togl = object (self) + val mutable view_rotx = 0.0 + val mutable view_roty = 0.0 + val mutable view_rotz = 0.0 + val mutable angle = 0.0 + val mutable count = 1 + + method rotx a = view_rotx <- a + method roty a = view_roty <- a + + method draw = + GlClear.clear [`color;`depth]; + + GlMat.push (); + GlMat.rotate ~angle:view_rotx ~x:1.0 (); + GlMat.rotate ~angle:view_roty ~y:1.0 (); + GlMat.rotate ~angle:view_rotz ~z:1.0 (); + + GlMat.push (); + GlMat.translate ~x:(-3.0) ~y:(-2.0) (); + GlMat.rotate ~angle:angle ~z:1.0 (); + (* gear inner:1.0 outer:4.0 width:1.0 teeth:20 tooth_depth:0.7; *) + GlList.call gear1; + GlMat.pop (); + + GlMat.push (); + GlMat.translate ~x:3.1 ~y:(-2.0) (); + GlMat.rotate ~angle:(-2.0 *. angle -. 9.0) ~z:1.0 (); + (* gear inner:0.5 outer:2.0 width:2.0 teeth:10 tooth_depth:0.7; *) + GlList.call gear2; + GlMat.pop (); + + GlMat.push (); + GlMat.translate ~x:(-3.1) ~y:4.2 (); + GlMat.rotate ~angle:(-2.0 *. angle -. 25.0) ~z:1.0 (); + (* gear inner:1.3 outer:2.0 width:0.5 teeth:10 tooth_depth:0.7; *) + GlList.call gear3; + GlMat.pop (); + + GlMat.pop (); + + Togl.swap_buffers togl; + + count <- count + 1; + if count =limit then exit 0 + + method idle = + angle <- angle +. 2.0; + self#draw + + method reshape = + let w = Togl.width togl and h = Togl.height togl in + GlDraw.viewport ~x:0 ~y:0 ~w ~h; + GlMat.mode `projection; + GlMat.load_identity (); + let r = float w /. float h in + let r' = 1. /. r in + if (w>h) then + GlMat.frustum ~x:(-. r,r) ~y:(-1.0,1.0) ~z:(5.0,60.0) + else + GlMat.frustum ~x:(-1.0,1.0) ~y:(-.r',r') ~z:(5.0,60.0); + + GlMat.mode `modelview; + GlMat.load_identity(); + GlMat.translate ~z:(-40.0) (); + GlClear.clear[`color;`depth] +end + +let init () = + let pos = 5.0, 5.0, 10.0, 0.0 + and red = 0.8, 0.1, 0.0, 1.0 + and green = 0.0, 0.8, 0.2, 1.0 + and blue = 0.2, 0.2, 1.0, 1.0 in + + GlLight.light ~num:0 (`position pos); + List.iter Gl.enable + [`cull_face;`lighting;`light0;`depth_test;`normalize]; + + (* make the gears *) + let make_gear ~inner ~outer ~width ~teeth ~color = + let list = GlList.create `compile in + GlLight.material ~face:`front (`ambient_and_diffuse color); + gear ~inner ~outer ~width ~teeth ~tooth_depth:0.7; + GlList.ends (); + list + in + let gear1 = make_gear ~inner:1.0 ~outer:4.0 ~width:1.0 ~teeth:20 ~color:red + and gear2 = make_gear ~inner:0.5 ~outer:2.0 ~width:2.0 ~teeth:10 ~color:green + and gear3 = make_gear ~inner:1.3 ~outer:2.0 ~width:0.5 ~teeth:10 ~color:blue in + + (gear1, gear2, gear3) + +open Tk + +let main () = + let top = openTk () in + let f = Frame.create top in + let v = Textvariable.create () in + let my_scale = + Scale.create ~min:0. ~max:180. ~showvalue:false ~highlightbackground:`Black + in + let togl = + Togl.create f ~width:300 ~height:300 + ~rgba:true ~depth:true ~double:true + and sh = my_scale f ~orient:`Horizontal + and sv = my_scale top ~orient:`Vertical + in + + Wm.title_set top "Gears"; + + let gear1, gear2, gear3 = init() in + let view = new view togl ~gear1 ~gear2 ~gear3 in + Scale.configure sv ~command:(view#rotx); + Scale.configure sh ~command:(view#roty); + Scale.set sh 20.; Scale.set sv 40.; + Togl.reshape_func togl ~cb:(fun () -> view#reshape); + Togl.display_func togl ~cb:(fun () -> view#draw); + Togl.timer_func ~ms:20 ~cb:(fun () -> view#idle); + pack [sv] ~side:`Right ~fill:`Y; + pack [f] ~expand:true ~fill:`Both; + pack [togl] ~side:`Top ~expand:true ~fill:`Both; + pack [sh] ~side:`Bottom ~fill:`X; + Tk.mainLoop () + +let _ = main () diff --git a/Togl/examples/gears_a.ml b/Togl/examples/gears_a.ml new file mode 100644 index 0000000..eb907d5 --- /dev/null +++ b/Togl/examples/gears_a.ml @@ -0,0 +1,261 @@ +(* $Id: gears_a.ml,v 1.2 2003-10-01 10:11:41 raffalli Exp $ *) + +(* + * 3-D gear wheels. This program is in the public domain. + * + * Brian Paul + * LablGL version by Jacques Garrigue + * + * gears_a.ml: use vertex arrays + *) + +let pi = acos (-1.) + +(* + * 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: inner_radius - radius of hole at center + * outer_radius - radius at center of teeth + * width - width of gear + * teeth - number of teeth + * tooth_depth - depth of tooth + *) +let gear ~inner ~outer ~width ~teeth ~tooth_depth = + let r0 = inner + and r1 = outer -. tooth_depth /. 2.0 + and r2 = outer +. tooth_depth /. 2.0 in + + let ta = 2.0 *. pi /. float teeth in + let da = ta /. 4.0 in + + GlDraw.shade_model `flat; + + GlDraw.normal ~z:1.0 (); + + let vertex ~r ~z ?(s=0) i = + let angle = float i *. ta +. float s *. da in + GlDraw.vertex ~x:(r *. cos angle) ~y:(r *. sin angle) ~z () + in + + let raw = Raw.create `float (12 * (teeth+1)) in + GlArray.vertex `three raw; + let count = ref 0 in + + let vertexa ~r ~z ?(s=0) i = + let angle = float i *. ta +. float s *. da in + let pos = !count * 3 in + Raw.set_float raw ~pos (r *. cos angle); + Raw.set_float raw ~pos:(pos+1) (r *. sin angle); + Raw.set_float raw ~pos:(pos+2) z; + incr count + in + + (* draw front face *) + let z = width *. 0.5 in + for i=0 to teeth do + vertexa i ~r:r0 ~z; + vertexa i ~r:r1 ~z; + vertexa i ~r:r0 ~z; + vertexa i ~r:r1 ~z ~s:3; + done; + GlArray.draw_arrays `quad_strip 0 !count; + count := 0; + + (* draw front sides of teeth *) + for i=0 to teeth - 1 do + vertexa i ~r:r1 ~z; + vertexa i ~r:r2 ~s:1 ~z; + vertexa i ~r:r2 ~s:2 ~z; + vertexa i ~r:r1 ~s:3 ~z; + done; + GlArray.draw_arrays `quads 0 !count; + count := 0; + + GlDraw.normal ~z:(-1.0) (); + + (* draw back face *) + let z = -. width *. 0.5 in + for i=0 to teeth do + vertexa i ~r:r1 ~z; + vertexa i ~r:r0 ~z; + vertexa i ~r:r1 ~s:3 ~z; + vertexa i ~r:r0 ~z; + done; + GlArray.draw_arrays `quad_strip 0 !count; + count := 0; + + (* draw back sides of teeth *) + for i=0 to teeth - 1 do + vertexa i ~r:r1 ~s:3 ~z; + vertexa i ~r:r2 ~s:2 ~z; + vertexa i ~r:r2 ~s:1 ~z; + vertexa i ~r:r1 ~z; + done; + GlArray.draw_arrays `quads 0 !count; + count := 0; + + (* draw outward faces of teeth *) + let z = width *. 0.5 and z' = width *. (-0.5) in + GlDraw.begins `quad_strip; + for i=0 to teeth - 1 do + let angle = float i *. ta in + vertex i ~r:r1 ~z; + vertex i ~r:r1 ~z:z'; + let u = r2 *. cos(angle+.da) -. r1 *. cos(angle) + and v = r2 *. sin(angle+.da) -. r1 *. sin(angle) in + GlDraw.normal ~x:v ~y:(-.u) (); + vertex i ~r:r2 ~s:1 ~z; + vertex i ~r:r2 ~s:1 ~z:z'; + GlDraw.normal ~x:(cos angle) ~y:(sin angle) (); + vertex i ~r:r2 ~s:2 ~z; + vertex i ~r:r2 ~s:2 ~z:z'; + let u = r1 *. cos(angle +. 3. *. da) -. r2 *. cos(angle +. 2. *. da) + and v = r1 *. sin(angle +. 3. *. da) -. r2 *. sin(angle +. 2. *. da) in + GlDraw.normal ~x:v ~y:(-.u) (); + vertex i ~r:r1 ~s:3 ~z; + vertex i ~r:r1 ~s:3 ~z:z'; + GlDraw.normal ~x:(cos angle) ~y:(sin angle) (); + done; + vertex 0 ~r:r1 ~z; + vertex 0 ~r:r1 ~z:z'; + GlDraw.ends (); + + GlDraw.shade_model `smooth; + + (* draw inside radius cylinder *) + GlDraw.begins `quad_strip; + for i=0 to teeth do + let angle = float i *. ta in + GlDraw.normal ~x:(-. cos angle) ~y:(-. sin angle) (); + vertex i ~r:r0 ~z:z'; + vertex i ~r:r0 ~z; + done; + GlDraw.ends () + +class view ~gear1 ~gear2 ~gear3 ?(limit=0) togl = object (self) + val mutable view_rotx = 0.0 + val mutable view_roty = 0.0 + val mutable view_rotz = 0.0 + val mutable angle = 0.0 + val mutable count = 1 + + method rotx a = view_rotx <- a + method roty a = view_roty <- a + + method draw = + GlClear.clear [`color;`depth]; + + GlMat.push (); + GlMat.rotate ~angle:view_rotx ~x:1.0 (); + GlMat.rotate ~angle:view_roty ~y:1.0 (); + GlMat.rotate ~angle:view_rotz ~z:1.0 (); + + GlMat.push (); + GlMat.translate ~x:(-3.0) ~y:(-2.0) (); + GlMat.rotate ~angle:angle ~z:1.0 (); + (* gear inner:1.0 outer:4.0 width:1.0 teeth:20 tooth_depth:0.7; *) + GlList.call gear1; + GlMat.pop (); + + GlMat.push (); + GlMat.translate ~x:3.1 ~y:(-2.0) (); + GlMat.rotate ~angle:(-2.0 *. angle -. 9.0) ~z:1.0 (); + (* gear inner:0.5 outer:2.0 width:2.0 teeth:10 tooth_depth:0.7; *) + GlList.call gear2; + GlMat.pop (); + + GlMat.push (); + GlMat.translate ~x:(-3.1) ~y:4.2 (); + GlMat.rotate ~angle:(-2.0 *. angle -. 25.0) ~z:1.0 (); + (* gear inner:1.3 outer:2.0 width:0.5 teeth:10 tooth_depth:0.7; *) + GlList.call gear3; + GlMat.pop (); + + GlMat.pop (); + + Togl.swap_buffers togl; + + count <- count + 1; + if count =limit then exit 0 + + method idle = + angle <- angle +. 2.0; + self#draw + + method reshape = + let w = Togl.width togl and h = Togl.height togl in + GlDraw.viewport ~x:0 ~y:0 ~w ~h; + GlMat.mode `projection; + GlMat.load_identity (); + let r = float w /. float h in + let r' = 1. /. r in + if (w>h) then + GlMat.frustum ~x:(-. r,r) ~y:(-1.0,1.0) ~z:(5.0,60.0) + else + GlMat.frustum ~x:(-1.0,1.0) ~y:(-.r',r') ~z:(5.0,60.0); + + GlMat.mode `modelview; + GlMat.load_identity(); + GlMat.translate ~z:(-40.0) (); + GlClear.clear[`color;`depth] +end + +let init () = + let pos = 5.0, 5.0, 10.0, 0.0 + and red = 0.8, 0.1, 0.0, 1.0 + and green = 0.0, 0.8, 0.2, 1.0 + and blue = 0.2, 0.2, 1.0, 1.0 in + + GlLight.light ~num:0 (`position pos); + List.iter Gl.enable + [`cull_face;`lighting;`light0;`depth_test;`normalize]; + GlArray.enable `vertex; + + (* make the gears *) + let make_gear ~inner ~outer ~width ~teeth ~color = + let list = GlList.create `compile in + GlLight.material ~face:`front (`ambient_and_diffuse color); + gear ~inner ~outer ~width ~teeth ~tooth_depth:0.7; + GlList.ends (); + list + in + let gear1 = make_gear ~inner:1.0 ~outer:4.0 ~width:1.0 ~teeth:20 ~color:red + and gear2 = make_gear ~inner:0.5 ~outer:2.0 ~width:2.0 ~teeth:10 ~color:green + and gear3 = make_gear ~inner:1.3 ~outer:2.0 ~width:0.5 ~teeth:10 ~color:blue in + + (gear1, gear2, gear3) + +open Tk + +let main () = + let top = openTk () in + let f = Frame.create top in + let v = Textvariable.create () in + let my_scale = + Scale.create ~min:0. ~max:180. ~showvalue:false ~highlightbackground:`Black + in + let togl = + Togl.create f ~width:300 ~height:300 + ~rgba:true ~depth:true ~double:true + and sh = my_scale f ~orient:`Horizontal + and sv = my_scale top ~orient:`Vertical + in + + Wm.title_set top "Gears"; + + let gear1, gear2, gear3 = init() in + let view = new view togl ~gear1 ~gear2 ~gear3 in + Scale.configure sv ~command:(view#rotx); + Scale.configure sh ~command:(view#roty); + Scale.set sh 20.; Scale.set sv 40.; + Togl.reshape_func togl ~cb:(fun () -> view#reshape); + Togl.display_func togl ~cb:(fun () -> view#draw); + Togl.timer_func ~ms:20 ~cb:(fun () -> view#idle); + pack [sv] ~side:`Right ~fill:`Y; + pack [f] ~expand:true ~fill:`Both; + pack [togl] ~side:`Top ~expand:true ~fill:`Both; + pack [sh] ~side:`Bottom ~fill:`X; + Tk.mainLoop () + +let _ = main () diff --git a/Togl/examples/morph3d.ml b/Togl/examples/morph3d.ml new file mode 100644 index 0000000..9047b6e --- /dev/null +++ b/Togl/examples/morph3d.ml @@ -0,0 +1,599 @@ +(* $Id: morph3d.ml,v 1.18 2001-05-08 01:58:25 garrigue Exp $ *) + +open StdLabels + +(*- + * morph3d.c - Shows 3D morphing objects (TK Version) + * + * This program was inspired on a WindowsNT(R)'s screen saver. It was written + * from scratch and it was not based on any other source code. + * + * Porting it to xlock (the final objective of this code since the moment I + * decided to create it) was possible by comparing the original Mesa's gear + * demo with it's ported version, so thanks for Danny Sung for his indirect + * help (look at gear.c in xlock source tree). NOTE: At the moment this code + * was sent to Brian Paul for package inclusion, the XLock Version was not + * available. In fact, I'll wait it to appear on the next Mesa release (If you + * are reading this, it means THIS release) to send it for xlock package + * inclusion). It will probably there be a GLUT version too. + * + * Thanks goes also to Brian Paul for making it possible and inexpensive + * to use OpenGL at home. + * + * Since I'm not a native english speaker, my apologies for any gramatical + * mistake. + * + * My e-mail addresses are + * + * vianna@cat.cbpf.br + * and + * marcelo@venus.rdc.puc-rio.br + * + * Marcelo F. Vianna (Feb-13-1997) + *) + +(* +This document is VERY incomplete, but tries to describe the mathematics used +in the program. At this moment it just describes how the polyhedra are +generated. On futhurer versions, this document will be probabbly improved. + +Since I'm not a native english speaker, my apologies for any gramatical +mistake. + +Marcelo Fernandes Vianna +- Undergraduate in Computer Engeneering at Catholic Pontifical University +- of Rio de Janeiro (PUC-Rio) Brasil. +- e-mail: vianna@cat.cbpf.br or marcelo@venus.rdc.puc-rio.br +- Feb-13-1997 + +POLYHEDRA GENERATION + +For the purpose of this program it's not sufficient to know the polyhedra +vertexes coordinates. Since the morphing algorithm applies a nonlinear +transformation over the surfaces (faces) of the polyhedron, each face has +to be divided into smaller ones. The morphing algorithm needs to transform +each vertex of these smaller faces individually. It's a very time consoming +task. + +In order to reduce calculation overload, and since all the macro faces of +the polyhedron are transformed by the same way, the generation is made by +creating only one face of the polyhedron, morphing it and then rotating it +around the polyhedron center. + +What we need to know is the face radius of the polyhedron (the radius of +the inscribed sphere) and the angle between the center of two adjacent +faces using the center of the sphere as the angle's vertex. + +The face radius of the regular polyhedra are known values which I decided +to not waste my time calculating. Following is a table of face radius for +the regular polyhedra with edge length = 1: + + TETRAHEDRON : 1/(2*sqrt(2))/sqrt(3) + CUBE : 1/2 + OCTAHEDRON : 1/sqrt(6) + DODECAHEDRON : T^2 * sqrt((T+2)/5) / 2 -> where T=(sqrt(5)+1)/2 + ICOSAHEDRON : (3*sqrt(3)+sqrt(15))/12 + +I've not found any reference about the mentioned angles, so I needed to +calculate them, not a trivial task until I figured out how :) +Curiously these angles are the same for the tetrahedron and octahedron. +A way to obtain this value is inscribing the tetrahedron inside the cube +by matching their vertexes. So you'll notice that the remaining unmatched +vertexes are in the same straight line starting in the cube/tetrahedron +center and crossing the center of each tetrahedron's face. At this point +it's easy to obtain the bigger angle of the isosceles triangle formed by +the center of the cube and two opposite vertexes on the same cube face. +The edges of this triangle have the following lenghts: sqrt(2) for the base +and sqrt(3)/2 for the other two other edges. So the angle we want is: + +-----------------------------------------------------------+ + | 2*ARCSIN(sqrt(2)/sqrt(3)) = 109.47122063449069174 degrees | + +-----------------------------------------------------------+ +For the cube this angle is obvious, but just for formality it can be +easily obtained because we also know it's isosceles edge lenghts: +sqrt(2)/2 for the base and 1/2 for the other two edges. So the angle we +want is: + +-----------------------------------------------------------+ + | 2*ARCSIN((sqrt(2)/2)/1) = 90.000000000000000000 degrees | + +-----------------------------------------------------------+ +For the octahedron we use the same idea used for the tetrahedron, but now +we inscribe the cube inside the octahedron so that all cubes's vertexes +matches excatly the center of each octahedron's face. It's now clear that +this angle is the same of the thetrahedron one: + +-----------------------------------------------------------+ + | 2*ARCSIN(sqrt(2)/sqrt(3)) = 109.47122063449069174 degrees | + +-----------------------------------------------------------+ +For the dodecahedron it's a little bit harder because it's only relationship +with the cube is useless to us. So we need to solve the problem by another +way. The concept of Face radius also exists on 2D polygons with the name +Edge radius: + Edge Radius For Pentagon (ERp) + ERp = (1/2)/TAN(36 degrees) * VRp = 0.6881909602355867905 + (VRp is the pentagon's vertex radio). + Face Radius For Dodecahedron + FRd = T^2 * sqrt((T+2)/5) / 2 = 1.1135163644116068404 +Why we need ERp? Well, ERp and FRd segments forms a 90 degrees angle, +completing this triangle, the lesser angle is a half of the angle we are +looking for, so this angle is: + +-----------------------------------------------------------+ + | 2*ARCTAN(ERp/FRd) = 63.434948822922009981 degrees | + +-----------------------------------------------------------+ +For the icosahedron we can use the same method used for dodecahedron (well +the method used for dodecahedron may be used for all regular polyhedra) + Edge Radius For Triangle (this one is well known: 1/3 of the triangle height) + ERt = sin(60)/3 = sqrt(3)/6 = 0.2886751345948128655 + Face Radius For Icosahedron + FRi= (3*sqrt(3)+sqrt(15))/12 = 0.7557613140761707538 +So the angle is: + +-----------------------------------------------------------+ + | 2*ARCTAN(ERt/FRi) = 41.810314895778596167 degrees | + +-----------------------------------------------------------+ + +*) + + +let scale = 0.3 + +let vect_mul (x1,y1,z1) (x2,y2,z2) = + (y1 *. z2 -. z1 *. y2, z1 *. x2 -. x1 *. z2, x1 *. y2 -. y1 *. x2) + +let sqr a = a *. a + +(* Increasing this values produces better image quality, the price is speed. *) +(* Very low values produces erroneous/incorrect plotting *) +let tetradivisions = 23 +let cubedivisions = 20 +let octadivisions = 21 +let dodecadivisions = 10 +let icodivisions = 15 + +let tetraangle = 109.47122063449069174 +let cubeangle = 90.000000000000000000 +let octaangle = 109.47122063449069174 +let dodecaangle = 63.434948822922009981 +let icoangle = 41.810314895778596167 + +let pi = acos (-1.) +let sqrt2 = sqrt 2. +let sqrt3 = sqrt 3. +let sqrt5 = sqrt 5. +let sqrt6 = sqrt 6. +let sqrt15 = sqrt 15. +let cossec36_2 = 0.8506508083520399322 +let cosd x = cos (float x /. 180. *. pi) +let sind x = sin (float x /. 180. *. pi) +let cos72 = cosd 72 +let sin72 = sind 72 +let cos36 = cosd 36 +let sin36 = sind 36 + +(*************************************************************************) + +let front_shininess = 60.0 +let front_specular = 0.7, 0.7, 0.7, 1.0 +let ambient = 0.0, 0.0, 0.0, 1.0 +let diffuse = 1.0, 1.0, 1.0, 1.0 +let position0 = 1.0, 1.0, 1.0, 0.0 +let position1 = -1.0,-1.0, 1.0, 0.0 +let lmodel_ambient = 0.5, 0.5, 0.5, 1.0 +let lmodel_twoside = true + +let materialRed = 0.7, 0.0, 0.0, 1.0 +let materialGreen = 0.1, 0.5, 0.2, 1.0 +let materialBlue = 0.0, 0.0, 0.7, 1.0 +let materialCyan = 0.2, 0.5, 0.7, 1.0 +let materialYellow = 0.7, 0.7, 0.0, 1.0 +let materialMagenta = 0.6, 0.2, 0.5, 1.0 +let materialWhite = 0.7, 0.7, 0.7, 1.0 +let materialGray = 0.2, 0.2, 0.2, 1.0 +let all_gray = Array.create 20 materialGray + +let vertex ~xf ~yf ~zf ~ampvr2 = + let xa = xf +. 0.01 and yb = yf +. 0.01 in + let xf2 = sqr xf and yf2 = sqr yf in + let factor = 1. -. (xf2 +. yf2) *. ampvr2 + and factor1 = 1. -. (sqr xa +. yf2) *. ampvr2 + and factor2 = 1. -. (xf2 +. sqr yb) *. ampvr2 in + let vertx = factor *. xf and verty = factor *. yf + and vertz = factor *. zf in + let neiax = factor1 *. xa -. vertx and neiay = factor1 *. yf -. verty + and neiaz = factor1 *. zf -. vertz and neibx = factor2 *. xf -. vertx + and neiby = factor2 *. yb -. verty and neibz = factor2 *. zf -. vertz in + GlDraw.normal3 (vect_mul (neiax, neiay, neiaz) (neibx, neiby, neibz)); + GlDraw.vertex3 (vertx, verty, vertz) + +let triangle ~edge ~amp ~divisions ~z = + let divi = float divisions in + let vr = edge *. sqrt3 /. 3. in + let ampvr2 = amp /. sqr vr + and zf = edge *. z in + let ax = edge *. (0.5 /. divi) + and ay = edge *. (-0.5 *. sqrt3 /. divi) + and bx = edge *. (-0.5 /. divi) in + for ri = 1 to divisions do + GlDraw.begins `triangle_strip; + for ti = 0 to ri - 1 do + vertex ~zf ~ampvr2 + ~xf:(float (ri-ti) *. ax +. float ti *. bx) + ~yf:(vr +. float (ri-ti) *. ay +. float ti *. ay); + vertex ~zf ~ampvr2 + ~xf:(float (ri-ti-1) *. ax +. float ti *. bx) + ~yf:(vr +. float (ri-ti-1) *. ay +. float ti *. ay) + done; + vertex ~xf:(float ri *. bx) ~yf:(vr +. float ri *. ay) ~zf ~ampvr2; + GlDraw.ends () + done + +let square ~edge ~amp ~divisions ~z = + let divi = float divisions in + let zf = edge *. z + and ampvr2 = amp /. sqr (edge *. sqrt2 /. 2.) in + for yi = 0 to divisions - 1 do + let yf = edge *. (-0.5 +. float yi /. divi) in + let yf2 = sqr yf in + let y = yf +. 1.0 /. divi *. edge in + let y2 = sqr y in + GlDraw.begins `quad_strip; + for xi = 0 to divisions do + let xf = edge *. (-0.5 +. float xi /. divi) in + vertex ~xf ~yf:y ~zf ~ampvr2; + vertex ~xf ~yf ~zf ~ampvr2 + done; + GlDraw.ends () + done + +let pentagon ~edge ~amp ~divisions ~z = + let divi = float divisions in + let zf = edge *. z + and ampvr2 = amp /. sqr(edge *. cossec36_2) in + let x = + Array.init 6 + ~f:(fun fi -> -. cos (float fi *. 2. *. pi /. 5. +. pi /. 10.) + /. divi *. cossec36_2 *. edge) + and y = + Array.init 6 + ~f:(fun fi -> sin (float fi *. 2. *. pi /. 5. +. pi /. 10.) + /. divi *. cossec36_2 *. edge) + in + for ri = 1 to divisions do + for fi = 0 to 4 do + GlDraw.begins `triangle_strip; + for ti = 0 to ri-1 do + vertex ~zf ~ampvr2 + ~xf:(float(ri-ti) *. x.(fi) +. float ti *. x.(fi+1)) + ~yf:(float(ri-ti) *. y.(fi) +. float ti *. y.(fi+1)); + vertex ~zf ~ampvr2 + ~xf:(float(ri-ti-1) *. x.(fi) +. float ti *. x.(fi+1)) + ~yf:(float(ri-ti-1) *. y.(fi) +. float ti *. y.(fi+1)) + done; + vertex ~xf:(float ri *. x.(fi+1)) ~yf:(float ri *. y.(fi+1)) ~zf ~ampvr2; + GlDraw.ends () + done + done + +let call_list list color = + GlLight.material ~face:`both (`diffuse color); + GlList.call list + +let draw_tetra ~amp ~divisions ~color = + let list = GlList.create `compile in + triangle ~edge:2.0 ~amp ~divisions ~z:(0.5 /. sqrt6); + GlList.ends(); + + call_list list color.(0); + GlMat.push(); + GlMat.rotate ~angle:180.0 ~z:1.0 (); + GlMat.rotate ~angle:(-.tetraangle) ~x:1.0 (); + call_list list color.(1); + GlMat.pop(); + GlMat.push(); + GlMat.rotate ~angle:180.0 ~y:1.0 (); + GlMat.rotate ~angle:(-180.0 +. tetraangle) ~x:0.5 ~y:(sqrt3 /. 2.) (); + call_list list color.(2); + GlMat.pop(); + GlMat.rotate ~angle:180.0 ~y:1.0 (); + GlMat.rotate ~angle:(-180.0 +. tetraangle) ~x:0.5 ~y:(-.sqrt3 /. 2.) (); + call_list list color.(3); + + GlList.delete list + +let draw_cube ~amp ~divisions ~color = + let list = GlList.create `compile in + square ~edge:2.0 ~amp ~divisions ~z:0.5; + GlList.ends (); + + call_list list color.(0); + for i = 1 to 3 do + GlMat.rotate ~angle:cubeangle ~x:1.0 (); + call_list list color.(i) + done; + GlMat.rotate ~angle:cubeangle ~y:1.0 (); + call_list list color.(4); + GlMat.rotate ~angle:(2.0 *. cubeangle) ~y:1.0 (); + call_list list color.(5); + + GlList.delete list + +let draw_octa ~amp ~divisions ~color = + let list = GlList.create `compile in + triangle ~edge:2.0 ~amp ~divisions ~z:(1.0 /. sqrt6); + GlList.ends (); + + let do_list (i,y) = + GlMat.push(); + GlMat.rotate ~angle:180.0 ~y:1.0 (); + GlMat.rotate ~angle:(-.octaangle) ~x:0.5 ~y (); + call_list list color.(i); + GlMat.pop() + in + call_list list color.(0); + GlMat.push(); + GlMat.rotate ~angle:180.0 ~z:1.0 (); + GlMat.rotate ~angle:(-180.0 +. octaangle) ~x:1.0 (); + call_list list color.(1); + GlMat.pop(); + List.iter [2, sqrt3 /. 2.0; 3, -.sqrt3 /. 2.0] ~f:do_list; + GlMat.rotate ~angle:180.0 ~x:1.0 (); + GlLight.material ~face:`both (`diffuse color.(4)); + GlList.call list; + GlMat.push(); + GlMat.rotate ~angle:180.0 ~z:1.0 (); + GlMat.rotate ~angle:(-180.0 +. octaangle) ~x:1.0 (); + GlLight.material ~face:`both (`diffuse color.(5)); + GlList.call list; + GlMat.pop(); + List.iter [6, sqrt3 /. 2.0; 7, -.sqrt3 /. 2.0] ~f:do_list; + + GlList.delete list + +let draw_dodeca ~amp ~divisions ~color = + let tau = (sqrt5 +. 1.0) /. 2.0 in + let list = GlList.create `compile in + pentagon ~edge:2.0 ~amp ~divisions + ~z:(sqr(tau) *. sqrt ((tau+.2.0)/.5.0) /. 2.0); + GlList.ends (); + + let do_list (i,angle,x,y) = + GlMat.push(); + GlMat.rotate ~angle:angle ~x ~y (); + call_list list color.(i); + GlMat.pop(); + in + GlMat.push (); + call_list list color.(0); + GlMat.rotate ~angle:180.0 ~z:1.0 (); + List.iter ~f:do_list + [ 1, -.dodecaangle, 1.0, 0.0; + 2, -.dodecaangle, cos72, sin72; + 3, -.dodecaangle, cos72, -.sin72; + 4, dodecaangle, cos36, -.sin36; + 5, dodecaangle, cos36, sin36 ]; + GlMat.pop (); + GlMat.rotate ~angle:180.0 ~x:1.0 (); + call_list list color.(6); + GlMat.rotate ~angle:180.0 ~z:1.0 (); + List.iter ~f:do_list + [ 7, -.dodecaangle, 1.0, 0.0; + 8, -.dodecaangle, cos72, sin72; + 9, -.dodecaangle, cos72, -.sin72; + 10, dodecaangle, cos36, -.sin36 ]; + GlMat.rotate ~angle:dodecaangle ~x:cos36 ~y:sin36 (); + call_list list color.(11); + + GlList.delete list + +let draw_ico ~amp ~divisions ~color = + let list = GlList.create `compile in + triangle ~edge:1.5 ~amp ~divisions + ~z:((3.0 *. sqrt3 +. sqrt15) /. 12.0); + GlList.ends (); + + let do_list1 i = + GlMat.rotate ~angle:180.0 ~y:1.0 (); + GlMat.rotate ~angle:(-180.0 +. icoangle) ~x:0.5 ~y:(sqrt3/.2.0) (); + call_list list color.(i) + and do_list2 i = + GlMat.rotate ~angle:180.0 ~y:1.0 (); + GlMat.rotate ~angle:(-180.0 +. icoangle) ~x:0.5 ~y:(-.sqrt3/.2.0) (); + call_list list color.(i) + and do_list3 i = + GlMat.rotate ~angle:180.0 ~z:1.0 (); + GlMat.rotate ~angle:(-.icoangle) ~x:1.0 (); + call_list list color.(i) + in + GlMat.push (); + call_list list color.(0); + GlMat.push (); + do_list3 1; + GlMat.push (); + do_list1 2; + GlMat.pop (); + do_list2 3; + GlMat.pop (); + GlMat.push (); + do_list1 4; + GlMat.push (); + do_list1 5; + GlMat.pop(); + do_list3 6; + GlMat.pop (); + do_list2 7; + GlMat.push (); + do_list2 8; + GlMat.pop (); + do_list3 9; + GlMat.pop (); + GlMat.rotate ~angle:180.0 ~x:1.0 (); + call_list list color.(10); + GlMat.push (); + do_list3 11; + GlMat.push (); + do_list1 12; + GlMat.pop (); + do_list2 13; + GlMat.pop (); + GlMat.push (); + do_list1 14; + GlMat.push (); + do_list1 15; + GlMat.pop (); + do_list3 16; + GlMat.pop (); + do_list2 17; + GlMat.push (); + do_list2 18; + GlMat.pop (); + do_list3 19; + + GlList.delete list + +class view togl = object (self) + val togl = togl + val mutable smooth = true + val mutable step = 0. + val mutable obj = 1 + val mutable draw_object = fun ~amp -> () + val mutable magnitude = 0. + + method width = Togl.width togl + method height = Togl.height togl + + method draw = + let ratio = float self#height /. float self#width in + GlClear.clear [`color;`depth]; + GlMat.push (); + GlMat.translate () ~z:(-10.0); + GlMat.scale () ~x:(scale *. ratio) ~y:scale ~z:scale; + GlMat.translate () + ~x:(2.5 *. ratio *. sin (step *. 1.11)) + ~y:(2.5 *. cos (step *. 1.25 *. 1.11)); + GlMat.rotate ~angle:(step *. 100.) ~x:1.0 (); + GlMat.rotate ~angle:(step *. 95.) ~y:1.0 (); + GlMat.rotate ~angle:(step *. 90.) ~z:1.0 (); + draw_object ~amp:((sin step +. 1.0/.3.0) *. (4.0/.5.0) *. magnitude); + GlMat.pop(); + Gl.flush(); + Togl.swap_buffers togl; + step <- step +. 0.05 + + method reshape = + GlDraw.viewport ~x:0 ~y:0 ~w:self#width ~h:self#height; + GlMat.mode `projection; + GlMat.load_identity(); + GlMat.frustum ~x:(-1.0, 1.0) ~y:(-1.0, 1.0) ~z:(5.0, 15.0); + GlMat.mode `modelview + + method key sym = + begin match sym with + "1" -> obj <- 1 + | "2" -> obj <- 2 + | "3" -> obj <- 3 + | "4" -> obj <- 4 + | "5" -> obj <- 5 + | "Return" -> smooth <- not smooth + | "Escape" -> Tk.destroy (Winfo.toplevel togl); exit 0 + | _ -> () + end; + self#pinit + + method pinit = + begin match obj with + 1 -> + draw_object <- draw_tetra + ~divisions:tetradivisions + ~color:[|materialRed; materialGreen; + materialBlue; materialWhite|]; + magnitude <- 2.5 + | 2 -> + draw_object <- draw_cube + ~divisions:cubedivisions + ~color:[|materialRed; materialGreen; materialCyan; + materialMagenta; materialYellow; materialBlue|]; + magnitude <- 2.0 + | 3 -> + draw_object <- draw_octa + ~divisions:octadivisions + ~color:[|materialRed; materialGreen; materialBlue; + materialWhite; materialCyan; materialMagenta; + materialGray; materialYellow|]; + magnitude <- 2.5 + | 4 -> + draw_object <- draw_dodeca + ~divisions:dodecadivisions + ~color:[|materialRed; materialGreen; materialCyan; + materialBlue; materialMagenta; materialYellow; + materialGreen; materialCyan; materialRed; + materialMagenta; materialBlue; materialYellow|]; + magnitude <- 2.0 + | 5 -> + draw_object <- draw_ico + ~divisions:icodivisions + ~color:[|materialRed; materialGreen; materialBlue; + materialCyan; materialYellow; materialMagenta; + materialRed; materialGreen; materialBlue; + materialWhite; materialCyan; materialYellow; + materialMagenta; materialRed; materialGreen; + materialBlue; materialCyan; materialYellow; + materialMagenta; materialGray|]; + magnitude <- 3.5 + | _ -> () + end; + GlDraw.shade_model (if smooth then `smooth else `flat) +end + +open Tk + +let main () = + List.iter ~f:print_string + [ "Morph 3D - Shows morphing platonic polyhedra\n"; + "Author: Marcelo Fernandes Vianna (vianna@cat.cbpf.br)\n"; + "Ported to LablGL by Jacques Garrigue\n\n"; + " [1] - Tetrahedron\n"; + " [2] - Hexahedron (Cube)\n"; + " [3] - Octahedron\n"; + " [4] - Dodecahedron\n"; + " [5] - Icosahedron\n"; + "[RETURN] - Toggle smooth/flat shading\n"; + " [ESC] - Quit\n" ]; + flush stdout; + + let top = openTk () in + let togl = Togl.create top ~width:640 ~height:480 + ~depth:true ~double:true ~rgba:true in + Wm.title_set top "Morph 3D - Shows morphing platonic polyhedra"; + GlClear.depth 1.0; + GlClear.color (0.0, 0.0, 0.0); + GlDraw.color (1.0, 1.0, 1.0); + + GlClear.clear [`color;`depth]; + Gl.flush(); + Togl.swap_buffers togl; + + List.iter ~f:(GlLight.light ~num:0) + [`ambient ambient; `diffuse diffuse; `position position0]; + List.iter ~f:(GlLight.light ~num:1) + [`ambient ambient; `diffuse diffuse; `position position1]; + GlLight.light_model (`ambient lmodel_ambient); + GlLight.light_model (`two_side lmodel_twoside); + List.iter ~f:Gl.enable + [`lighting;`light0;`light1;`depth_test;`normalize]; + + GlLight.material ~face:`both (`shininess front_shininess); + GlLight.material ~face:`both (`specular front_specular); + + GlMisc.hint `fog `fastest; + GlMisc.hint `perspective_correction `fastest; + GlMisc.hint `polygon_smooth `fastest; + + let view = new view togl in + view#pinit; + + Togl.display_func togl ~cb:(fun () -> view#draw); + Togl.reshape_func togl ~cb:(fun () -> view#reshape); + Togl.timer_func ~ms:20 ~cb:(fun () -> view#draw); + bind togl ~events:[`KeyPress] ~fields:[`KeySymString] + ~action:(fun ev -> view#key ev.ev_KeySymString); + bind togl ~events:[`Enter] ~action:(fun _ -> Focus.set togl); + pack [togl] ~expand:true ~fill:`Both; + mainLoop () + +let _ = main () diff --git a/Togl/examples/planet.ml b/Togl/examples/planet.ml new file mode 100644 index 0000000..0a0f3fb --- /dev/null +++ b/Togl/examples/planet.ml @@ -0,0 +1,120 @@ +(* $Id: planet.ml,v 1.17 2001-09-07 06:50:01 garrigue Exp $ *) + +#load"unix.cma";; + +class planet togl = object (self) + val togl = togl + val mutable year = 0.0 + val mutable day = 0.0 + val mutable eye = 0.0 + val mutable time = 0.0 + + method tick new_time = + if time = 0. then time <- new_time else + let diff = new_time -. time in + time <- new_time; + day <- mod_float (day +. diff *. 200.) 360.0; + year <- mod_float (year +. diff *. 20.) 360.0 + method day_add = + day <- mod_float (day +. 10.0) 360.0 + method day_subtract = + day <- mod_float (day -. 10.0) 360.0 + method year_add = + year <- mod_float (year +. 5.0) 360.0 + method year_subtract = + year <- mod_float (year -. 5.0) 360.0 + method eye x = + eye <- x; self#display + + method display = + GlClear.clear [`color;`depth]; + + GlDraw.color (1.0, 1.0, 1.0); + GlMat.push(); + GlMat.rotate ~angle:eye ~x:1. (); +(* draw sun *) + GlLight.material ~face:`front (`specular (1.0,1.0,0.0,1.0)); + GlLight.material ~face:`front (`shininess 5.0); + GluQuadric.sphere ~radius:1.0 ~slices:32 ~stacks:32 (); +(* draw smaller planet *) + GlMat.rotate ~angle:year ~y:1.0 (); + GlMat.translate () ~x:3.0; + GlMat.rotate ~angle:day ~y:1.0 (); + GlDraw.color (0.0, 1.0, 1.0); + GlDraw.shade_model `flat; + GlLight.material ~face:`front(`shininess 128.0); + GluQuadric.sphere ~radius:0.2 ~slices:10 ~stacks:10 (); + GlDraw.shade_model `smooth; + GlMat.pop (); + Gl.flush (); + Togl.swap_buffers togl +end + +let myinit () = + let light_ambient = 0.5, 0.5, 0.5, 1.0 + and light_diffuse = 1.0, 0.8, 0.2, 1.0 + and light_specular = 1.0, 1.0, 1.0, 1.0 + (* light_position is NOT default value *) + and light_position = 1.0, 1.0, 1.0, 0.0 + in + List.iter (GlLight.light ~num:0) + [ `ambient light_ambient; `diffuse light_diffuse; + `specular light_specular; `position light_position ]; + GlFunc.depth_func `less; + List.iter Gl.enable [`lighting; `light0; `depth_test]; + GlDraw.shade_model `smooth + + +let my_reshape togl = + let w = Togl.width togl and h = Togl.height togl in + GlDraw.viewport ~x:0 ~y:0 ~w ~h; + GlMat.mode `projection; + GlMat.load_identity(); + GluMat.perspective ~fovy:60.0 ~aspect:(float w /. float h) ~z:(1.0,20.0); + GlMat.mode `modelview; + GlMat.load_identity(); + GlMat.translate () ~z:(-5.0) + +(* Main Loop + * Open window with initial window size, title bar, + * RGBA display mode, and handle input events. + *) +open Tk + +let main () = + let top = openTk () in + let togl = + Togl.create top ~width:700 ~height:500 ~double:true ~rgba:true + ~depth:true in + Wm.title_set top "Planet"; + + myinit (); + + let planet = new planet togl in + let scale = + Scale.create top ~min:(-45.) ~max:45. ~orient:`Vertical + ~command:(planet#eye) ~showvalue:false ~highlightbackground:`Black in + bind togl ~events:[`Enter] ~action:(fun _ -> Focus.set togl); + bind scale ~events:[`Enter] ~action:(fun _ -> Focus.set scale); + bind togl ~events:[`KeyPress] ~fields:[`KeySymString] + ~action:(fun ev -> + begin match ev.ev_KeySymString with + "Left" -> planet#year_subtract + | "Right" -> planet#year_add + | "Up" -> planet#day_add + | "Down" -> planet#day_subtract + | "Escape" -> destroy top; exit 0 + | _ -> () + end; + planet#display); + Togl.timer_func ~ms:20 + ~cb:(fun () -> planet#tick (Unix.gettimeofday()); planet#display); + Togl.display_func togl ~cb:(fun () -> planet#display); + Togl.reshape_func togl ~cb:(fun () -> my_reshape togl); + my_reshape togl; + pack [togl] ~side:`Left ~expand:true ~fill:`Both; + pack [scale] ~side:`Right ~fill:`Y; + Focus.set togl; + mainLoop () + +let _ = Printexc.print main () diff --git a/Togl/examples/scene.ml b/Togl/examples/scene.ml new file mode 100644 index 0000000..22b5d61 --- /dev/null +++ b/Togl/examples/scene.ml @@ -0,0 +1,111 @@ +(* $Id: scene.ml,v 1.12 2001-05-08 01:58:26 garrigue Exp $ *) + +(* Initialize material property and light source. + *) +let myinit () = + let light_ambient = 0.0, 0.0, 0.0, 1.0 + and light_diffuse = 1.0, 1.0, 1.0, 1.0 + and light_specular = 1.0, 1.0, 1.0, 1.0 + (* light_position is NOT default value *) + and light_position = 1.0, 1.0, 1.0, 0.0 + in + GlLight.light ~num:0 (`ambient light_ambient); + GlLight.light ~num:0 (`diffuse light_diffuse); + GlLight.light ~num:0 (`specular light_specular); + GlLight.light ~num:0 (`position light_position); + + GlFunc.depth_func `less; + List.iter Gl.enable [`lighting; `light0; `depth_test] + +let pi = acos (-1.) + +let solid_torus ~inner ~outer = + let slices = 32 and faces = 16 in + let slice_angle = 2.0 *. pi /. float slices + and face_angle = 2.0 *. pi /. float faces in + let vertex ~i ~j = + let angle1 = slice_angle *. float i + and angle2 = face_angle *. float j in + GlDraw.normal3 (cos angle1 *. cos angle2, + -. sin angle1 *. cos angle2, + sin angle2); + GlDraw.vertex3 + ((outer +. inner *. cos angle2) *. cos angle1, + -. (outer +. inner *. cos angle2) *. sin angle1, + inner *. sin angle2) + in + GlDraw.begins `quads; + for i = 0 to slices - 1 do + for j = 0 to faces - 1 do + vertex ~i ~j; + vertex ~i:(i+1) ~j; + vertex ~i:(i+1) ~j:(j+1); + vertex ~i ~j:(j+1); + done + done; + GlDraw.ends () + +let solid_cone ~radius ~height = + GluQuadric.cylinder ~base:radius ~top:0. ~height ~slices:15 ~stacks:10 () + +let solid_sphere ~radius = + GluQuadric.sphere ~radius ~slices:32 ~stacks:32 () + +let display () = + GlClear.clear [`color; `depth]; + + GlMat.push (); + GlMat.rotate ~angle:20.0 ~x:1.0 (); + + GlMat.push (); + GlMat.translate ~x:(-0.75) ~y:0.5 (); + GlMat.rotate ~angle:90.0 ~x:1.0 (); + solid_torus ~inner:0.275 ~outer:0.85; + GlMat.pop (); + + GlMat.push (); + GlMat.translate ~x:(-0.75) ~y:(-0.5) (); + GlMat.rotate ~angle:270.0 ~x:1.0 (); + solid_cone ~radius:1.0 ~height:2.0; + GlMat.pop (); + + GlMat.push (); + GlMat.translate ~x:0.75 ~z:(-1.0) (); + solid_sphere ~radius:1.0; + GlMat.pop (); + + GlMat.pop (); + Gl.flush () + +let my_reshape ~w ~h = + GlDraw.viewport ~x:0 ~y:0 ~w ~h; + GlMat.mode `projection; + GlMat.load_identity (); + if w <= h then + GlMat.ortho ~x:(-2.5,2.5) ~z:(-10.0,10.0) + ~y:(-2.5 *. float h /. float w, 2.5 *. float h /. float w) + else + GlMat.ortho ~y:(-2.5,2.5) ~z:(-10.0,10.0) + ~x:(-2.5 *. float w /. float h, 2.5 *. float w /. float h); + GlMat.mode `modelview + +(* Main Loop + * Open window with initial window size, title bar, + * RGBA display mode, and handle input events. + *) + +open Tk + +let main () = + let top = openTk () in + let togl = + Togl.create top ~rgba:true ~depth:true ~width:500 ~height:500 in + Wm.title_set top "Scene"; + myinit (); + Togl.reshape_func togl + ~cb:(fun () -> my_reshape ~w:(Togl.width togl) ~h:(Togl.height togl)); + Togl.display_func togl ~cb:display; + pack [togl] ~expand:true ~fill:`Both; + mainLoop () + +let _ = Printexc.print main () diff --git a/Togl/examples/simple.ml b/Togl/examples/simple.ml new file mode 100644 index 0000000..161007f --- /dev/null +++ b/Togl/examples/simple.ml @@ -0,0 +1,35 @@ +(* $Id: simple.ml,v 1.10 2002-04-27 02:35:45 garrigue Exp $ *) + +open Tk + +let main () = + (* Aux.init_display_mode [`rgb;`single;`depth]; + Aux.init_position ~x:0 ~y:0 ~w:500 ~h:500; + Aux.init_window ~title:"LablGL"; *) + let top = openTk () in + let togl = + Togl.create top ~width:500 ~height:500 ~rgba:true ~depth:true ~double:true + in + Wm.title_set top "LablGL"; + pack ~fill:`Both [togl]; + Togl.display_func togl ~cb: + begin fun () -> + GlClear.color (0.0, 0.0, 0.0); + GlClear.clear [`color]; + GlDraw.color (1.0, 1.0, 1.0); + GlMat.mode `projection; + GlMat.load_identity (); + GlMat.ortho ~x:(-1.0,1.0) ~y:(-1.0,1.0) ~z:(-1.0,1.0); + GlDraw.begins `polygon; + GlDraw.vertex ~x:(-0.5) ~y:(-0.5) (); + GlDraw.vertex ~x:(-0.5) ~y:(0.5) (); + GlDraw.vertex ~x:(0.5) ~y:(0.5) (); + GlDraw.vertex ~x:(0.5) ~y:(-0.5) (); + GlDraw.ends (); + Gl.flush (); + Togl.swap_buffers togl + end; + ignore (Timer.add ~ms:10000 ~callback:(fun () -> destroy top)); + mainLoop () + +let _ = main () diff --git a/Togl/examples/tennis.ml b/Togl/examples/tennis.ml new file mode 100644 index 0000000..04ebecf --- /dev/null +++ b/Togl/examples/tennis.ml @@ -0,0 +1,517 @@ +(* This program was written by Yasuhiko Minamide, nan@kurims.kyoto-u.ac.jp *) +(* $Id: tennis.ml,v 1.17 2001-05-08 01:58:26 garrigue Exp $ *) + +open StdLabels + +let image_height = 64 +and image_width = 64 + +let make_image () = + let image = + GlPix.create `ubyte ~width:image_width ~height:image_height ~format:`rgba in + for i = 0 to image_width - 1 do + for j = 0 to image_height - 1 do + Raw.sets (GlPix.to_raw image) ~pos:(4*(i*image_height+j)) + (if (((i land 6 ) = 6) or ((j land 6) = 6)) + then [|0;0;0;255|] + else [|255;255;255;0|]) + done + done; + image + + + +let image_height = 256 +and image_width = 256 + + +let make_image2 () = + let on_circle (x0,y0) (x,y) = + let d = (x -. x0) *. (x -. x0) +. (y -. y0) *. (y -. y0) in + ((d > 0.9 *. 0.9) && (d < 1.1 *. 1.1)) in + + let on_line (x,y) = + if x <= -.2.0 then on_circle (-. 2.0, 0.0) (x,y) + else if x >= 2.0 then on_circle (2.0, 0.0) (x,y) + else ((0.9 < y) && (y < 1.1)) || ((-1.1 <= y) && ( y <= -0.9)) in + + let on_white (i,j) = + let x = (float (i - 128) /. 128.0) *. 6.0 in + let y = (float (j - 128) /. 128.0) *. 2.0 in + on_line (x,y) in + + let image = + GlPix.create `ubyte ~width:image_width ~height:image_height ~format:`rgb in + for i = 0 to image_width - 1 do + for j = 0 to image_height - 1 do + Raw.sets (GlPix.to_raw image) ~pos:(3*(i*image_height+j)) + (if on_white (j,i) + then [|255;255;255|] + else [|255;255;0|]) + done + done; + image + + + +let ft x = x *. 0.03 + +let cw = ft (9.0 +. 4.5) +let cl = ft 39.0 +let sw = ft 9.0 +let sl = ft 21.0 +let lw = 0.015 +let wlw = 0.02 + +let square (x1, y1) (x2, y2) = + List.iter ~f:GlDraw.vertex2 + [ x1, y1; + x2, y1; + x2, y2; + x1, y2 ] + +let collide ~pos ~vel ~plane ~func = + let between (a,b,x) = + let (a,b) = if a > b then (b,a) else (a,b) in + (x > a) && (x < b) in + let (xpos,ypos,zpos) = pos in + let (dx,dy,dz) = vel in + if dx = 0.0 then (xpos, ypos +. dy, zpos +. dz) else + let ((x1,y1,z1),(x2,y2,z2)) = plane in + let y = if dy = 0.0 then ypos else (dy /. dx) *. (x1 -. xpos) +. ypos in + let z = if dz = 0.0 then zpos else (dz /. dx) *. (x1 -. xpos) +. zpos in + if between (y1, y2, y) && between (z1, z2, z) && between (xpos, xpos +. dx, x1) + then begin func (); (x1, y, z) end + else (xpos +. dx, ypos +. dy, zpos +. dz) + + + +class ball () = object (self) + val mutable x = 0.0 + val mutable y = 0.0 + val mutable z = 0.2 + val mutable target_x = 0.0 + val mutable target_y = 0.0 + val mutable velocity = 0.0 + val mutable angle_z = 0.0 + val mutable vel_z = 0.0 + val mutable vel_y = 0.0 + val mutable vel_x = 0.0 + val mutable moving = false + + val image = make_image2 () + + + method set_vel v = velocity <- v /. 36.0; + + method set_velz v = angle_z <- v + + method reset = () + + method draw = + Gl.disable `blend; + GlDraw.color (1.0, 1.0, 0.0); + GlMat.push (); + GlMat.translate ~x ~y ~z (); + GluQuadric.sphere ~radius:0.01 ~slices:8 ~stacks:8 (); + GlMat.pop () + + method drawtexture = + let q = GluQuadric.create () in + + GlMat.push (); + Gl.enable `texture_2d; + GlTex.image2d image; + List.iter ~f:(GlTex.parameter ~target:`texture_2d) + [ `wrap_s `repeat; + `wrap_t `repeat; + `mag_filter `nearest; + `min_filter `nearest ]; + GlMat.translate ~x ~y ~z (); + GluQuadric.texture q true; + GluQuadric.sphere ~radius:0.01 ~slices:16 ~stacks:8 ~quad:q (); + Gl.disable `texture_2d; + GlMat.pop () + + + method draw_shadow = + Gl.disable `blend; + GlDraw.color (0.0, 0.0, 0.0); + GlMat.push (); + GlMat.translate ~x ~y (); + GluQuadric.disk ~inner:0.0 ~outer:0.01 ~slices:8 ~loops:8 (); + GlMat.pop () + + method draw_target = + let (x,y) = (target_x, target_y) in + GlDraw.begins `quads; + GlDraw.color (0.0, 0.0, 1.0); + square (x -. 0.05, y +. 0.05) (x +. 0.05, y -. 0.05); + GlDraw.ends () + + + method do_tick delta = + if moving then + let (x',y',z') = collide ~pos:(x,y,z) ~vel:(-. vel_x *. delta, + vel_y *. delta, + vel_z *. delta) + ~plane:((0.0, -. cw, 0.0), (0.0, cw, 0.1)) + ~func:(function () -> + begin + vel_x <- 0.0; + vel_y <- 0.0; + vel_z <- 0.0 + end) in + let vel_z' = vel_z in + let (z',vel_z') = + if z' < 0.01 then (-. (z' -. 0.01) +. 0.01, + -. vel_z' *. 0.7) else (z',vel_z') in + let vel_z' = vel_z' -. delta *. 0.98 in + vel_z <- vel_z'; + x <- x'; + y <- y'; + z <- z' + else (); + moving + + method set_position x' y' = x <- x'; y <- y' + method set_target x' y' = target_x <- x'; target_y <- y' + method set_z z' = z <- z' /. 100. + method get_position = (x, y) + + method calc_vel = + let dx = x -. target_x + and dy = target_y -. y in + let d' = sqrt ( dx *. dx +. dy *. dy) in + let cos_z = cos(angle_z /. 180. *. 3.14) in + if cos_z = 0.0 or d' = 0.0 then () else + let dz = d' *. (tan(angle_z /. 180. *. 3.14)) in + let d = d' /. cos_z in + begin + vel_x <- velocity *. dx /. d; + vel_y <- velocity *. dy /. d; + vel_z <- velocity *. dz /. d + end + + + method switch = if moving then self#reset else self#calc_vel; + moving <- not moving; + moving +end + +class poll = object + val r = 0.008 + val y = cw +. 0.05 +. 0.008 + + method draw = + Gl.disable `blend; + GlDraw.color (0.0, 0.0, 0.0); + GlMat.push (); + GlMat.translate ~y (); + GluQuadric.cylinder ~slices:8 ~stacks:8 ~height:0.12 ~top:r ~base:r (); + GlMat.pop (); + GlMat.push (); + GlMat.translate ~y:(-. y) (); + GluQuadric.cylinder ~slices:8 ~stacks:8 ~height:0.12 ~top:r ~base:r (); + GlMat.pop () +end + + +class court ~togl = object + val court = + Togl.make_current togl; + let court = GlList.create `compile in + GlDraw.shade_model `flat; + GlDraw.begins `quads; + GlDraw.color (0.2, 0.7, 0.2); + square (cl, cw) (-.cl, -.cw); + + (* Lines *) + GlDraw.color (1.0, 1.0, 1.0); + square (-.cl, cw) (cl, cw -. lw); + square (-.cl, -.cw) (cl, -.cw +. lw); + square (cl, cw) (cl -. wlw, -. cw); + square (-.cl, cw) (-.cl +. wlw, -.cw); + square (-.sl, lw /. 2.) (sl, -.lw /. 2.); + square (-.cl, sw) (cl, sw -. lw); + square (-.cl, -.sw) (cl, -.sw +. lw); + square (sl, sw) (sl -. lw, -. sw); + square (-.sl, sw) (-.sl +. lw, -.sw); + GlDraw.ends (); + GlList.ends (); + court + + method draw = GlList.call court +end + +class player = object + (* position of a player *) + val mutable x = -1.0 + val mutable y = 0.5 + + + method move x' y' = + x <- -. x'; + y <- y' + + method position = (x,y) +end + +class net ~togl = object + val texture = + Togl.make_current togl; + make_image () +(* let image = make_image () in + GlTex.image2d image; + List.iter f:(GlTex.parameter target:`texture_2d) + [ `wrap_s `repeat; + `wrap_t `repeat; + `mag_filter `nearest; + `min_filter `nearest ]; *) + + method draw = + Gl.enable `blend; + GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha; + GlDraw.color (0.0, 0.0, 0.0) ~alpha:1.0; + GlTex.env (`mode `replace); + Gl.enable `texture_2d; + GlTex.image2d texture; + List.iter ~f:(GlTex.parameter ~target:`texture_2d) + [ `wrap_s `repeat; + `wrap_t `repeat; + `mag_filter `nearest; + `min_filter `nearest ]; + GlDraw.begins `quads; + GlTex.coord2(0.0, 0.0); GlDraw.vertex3(0.0, cw +. 0.05, 0.0); + GlTex.coord2(0.0, 3.0); GlDraw.vertex3(0.0, cw +. 0.05, 0.115); + GlTex.coord2(9.0, 3.0); GlDraw.vertex3(0.0, 0.0, 0.09); + GlTex.coord2(9.0, 0.0); GlDraw.vertex3(0.0, 0.0, 0.0); + + GlTex.coord2(0.0, 0.0); GlDraw.vertex3(0.0, 0.0, 0.0); + GlTex.coord2(0.0, 3.0); GlDraw.vertex3(0.0, 0.0, 0.09); + GlTex.coord2(9.0, 3.0); GlDraw.vertex3(0.0, -.cw -. 0.05, 0.115); + GlTex.coord2(9.0, 0.0); GlDraw.vertex3(0.0, -.cw -. 0.05, 0.0); + GlDraw.ends (); + Gl.disable `texture_2d; + Gl.disable `blend; + + GlDraw.color (1.0, 1.0, 1.0); + GlDraw.begins `quad_strip; + List.iter ~f:(fun (y,z) -> GlDraw.vertex ~x:0. ~y ~z ()) + [ cw +. 0.05, 0.11; + cw +. 0.05, 0.115; + 0.0, 0.085; + 0.0, 0.09; + -.cw -. 0.05, 0.11; + -.cw -. 0.05, 0.115 ]; + GlDraw.ends () +end + + +class view3d ~togl ~ball ~player ~viewtype = object + val ball : ball = ball + val player : player = player + val court = new court ~togl + val net = new net ~togl + val poll = new poll + + method draw = + Togl.make_current togl; + GlClear.color (0.5, 0.5, 1.0); + GlClear.clear [`color;`depth]; + + if viewtype () = "Top View" then + begin + GlMat.mode `projection; + GlMat.load_identity (); + GlMat.rotate ~angle:90.0 ~z:1.0 (); + GlMat.ortho ~x:(-1.2,1.2) ~y:(-1.2,1.2) ~z:(0.0,2.0); + GlMat.mode `modelview; + GlMat.load_identity (); + GluMat.look_at + ~eye:(0.0, 0.0, 2.0) ~center:(0.0, 0.0, 0.0) ~up:(0.0, 1.0, 0.0) + end + else + begin + GlMat.mode `projection; + GlMat.load_identity (); + GluMat.perspective ~fovy:40.0 ~aspect:1.0 ~z:(0.1,4.0); + GlMat.mode `modelview; + if viewtype () = "Center" then + begin + GlMat.load_identity (); + let (x,y) = player#position in + GluMat.look_at + ~eye:(x, y, 0.2) ~center:(0.0, 0.0, 0.09) ~up:(-. x, -. y, 0.0) + end + else + begin + GlMat.load_identity (); + let (x,y) = player#position in + let (x',y') = ball#get_position in + GluMat.look_at + ~eye:(x, y, 0.2) ~center:(x', y', 0.09) ~up:(x' -. x, y' -. y, 0.0) + end; + end; + + GlDraw.shade_model `flat; + + (* Ground *) + GlDraw.begins `quads; + GlDraw.color (0.5, 0.5, 0.5); + square (-5.0, 5.0) (5.0, -5.0); + GlDraw.ends (); + + court#draw; + + let (x,y) = ball#get_position + in + if x < 0.0 then + (net#draw; + ball#draw_shadow; + ball#draw) + else + (ball#draw_shadow; + ball#draw; + net#draw); + poll#draw; + + + Togl.swap_buffers togl; + Gl.flush () +end + +class view2d ~togl ~ball ~player = object + val ball : ball = ball + val player : player = player + val court = new court ~togl:togl + + method draw = + Togl.make_current togl; + GlClear.clear [`color;`depth]; + + GlMat.mode `projection; + GlMat.load_identity (); + GlMat.rotate ~angle:90.0 ~z:1.0 (); + GlMat.ortho ~x:(-1.5,1.5) ~y:(-1.5,1.5) ~z:(0.0,2.0); + GlMat.mode `modelview; + GlMat.load_identity (); + let (x,y) = player#position in + GluMat.look_at + ~eye:(0.0, 0.0, 2.0) ~center:(0.0, 0.0, 0.0) ~up:(0.0, 1.0, 0.0); + court#draw; + ball#draw; + + let (x,y) = player#position in + GlDraw.begins `quads; + GlDraw.color (1.0, 0.0, 0.0); + square (x -. 0.02, y +. 0.02) (x +. 0.02, y -. 0.02); + GlDraw.ends (); + + ball#draw_target; + + Togl.swap_buffers togl; + Gl.flush () +end + + +open Tk + +let main () = + let top = openTk () in + Wm.title_set top "Tennis Court"; + + let f0 = Frame.create top in + let court3d = + Togl.create f0 ~width:600 ~height:600 + ~rgba:true ~double:true ~depth:true + and f1 = Frame.create f0 in + let court2d = + Togl.create f1 ~width:200 ~height:200 + ~rgba:true ~double:true ~depth:true + and sx = + Scale.create f1 ~label:"Velocity" + ~min:0. ~max:200. ~orient:`Horizontal + and sz = + Scale.create f1 ~label:"Direction" + ~min: (-. 90.) ~max:90. ~orient:`Horizontal + and sht = + Scale.create f1 ~label:"Height" + ~min: 0. ~max:100. ~orient:`Horizontal + and start = + Button.create f1 ~text:"Start" + in + let viewseltv = Textvariable.create () in + Textvariable.set viewseltv "Top View"; + let viewself = Frame.create f1 in + let viewsel = List.map ["Top View"; "Center"; "Ball"] ~f: + begin fun t -> + Radiobutton.create viewself ~text: t ~value: t + ~variable: viewseltv + end + in + pack viewsel; + let viewtype = fun () -> Textvariable.get viewseltv in + + let ball = new ball () in + let player = new player in + let view3d = new view3d ~togl:court3d ~viewtype ~ball ~player + and view2d = new view2d ~togl:court2d ~ball ~player + in + Scale.configure sx ~command:(ball#set_vel); + Scale.configure sz ~command:(ball#set_velz); + Button.configure start ~command: + begin fun () -> + Button.configure start ~text:(if ball#switch then "Stop" else "Start") + end; + Togl.timer_func ~ms:20 + ~cb:(fun () -> if ball#do_tick 0.02 then (view3d#draw; view2d#draw)); + Togl.display_func court3d ~cb:(fun () -> view3d#draw); + Togl.display_func court2d ~cb:(fun () -> view2d#draw); + bind court3d ~events:[`Modified([`Button1],`Motion)] ~fields:[`MouseX;`MouseY] + ~action:(fun ev -> + let width = Togl.width court3d + and height =Togl.height court3d in + let y = -. (float ev.ev_MouseX /. float width) +. 0.5 + and x = float ev.ev_MouseY /. float height in + player#move x y; + view2d#draw; + view3d#draw); + bind court2d ~events:[`Modified([`Button1],`Motion)] ~fields:[`MouseX;`MouseY] + ~action:(fun ev -> + let width = Togl.width court2d + and height =Togl.height court2d in + let y = (float ev.ev_MouseX /. float width ) -. 0.5 + and x = (float ev.ev_MouseY /. float height) -. 0.5 in + let y = -. (y *. 3.0) + and x = -. (x *. 3.0) in + ball#set_position x y; + view2d#draw; + view3d#draw); + bind court2d ~events:[`Modified([`Button2],`Motion)] ~fields:[`MouseX;`MouseY] + ~action:(fun ev -> + let width = Togl.width court2d + and height =Togl.height court2d in + let y = (float ev.ev_MouseX /. float width ) -. 0.5 + and x = (float ev.ev_MouseY /. float height) -. 0.5 in + let y = -. (y *. 3.0) + and x = -. (x *. 3.0) in + ball#set_target x y; + print_float x; + print_float y; + print_string "\n"; + view2d#draw; + view3d#draw); + let rec viewselfn () = + begin + Textvariable.handle viewseltv ~callback:viewselfn; + view3d#draw + end in + viewselfn (); + Scale.configure sht ~command:(fun z -> ball#set_z z; view3d#draw); + pack [coe court2d; coe sx; coe sz; coe sht;coe start; coe viewself]; + pack [coe court3d; coe f1] ~side:`Left; + pack [f0] ~expand:true ~fill:`Both; + mainLoop () + +let _ = main () diff --git a/Togl/examples/tesselate.ml b/Togl/examples/tesselate.ml new file mode 100644 index 0000000..d57ba72 --- /dev/null +++ b/Togl/examples/tesselate.ml @@ -0,0 +1,26 @@ +(* $Id: tesselate.ml,v 1.1 2004-07-13 07:55:18 garrigue Exp $ *) + +open Tk + +let top = openTk() +let togl = + Togl.create top ~width:500 ~height:500 ~rgba:true ~depth:true ~double:true + +let () = + Wm.title_set top "LablGL"; + pack ~fill:`Both [togl]; + Togl.display_func togl ~cb: + begin fun () -> + GlClear.color (0.0, 0.0, 0.0); + GlClear.clear [`color]; + GlDraw.color (1.0, 1.0, 1.0); + GlMat.mode `projection; + GlMat.load_identity (); + GlMat.ortho ~x:(-1.0,2.0) ~y:(-1.0,2.0) ~z:(-1.0,2.0); + GluTess.tesselate + [[0.,0.,0.;1.,0.,0.;1.,1.,0.;0.,1.,0.]; + [0.2,0.2,0.;0.2,0.8,0.;0.8,0.8,0.;0.8,0.2,0.]]; + Gl.flush (); + Togl.swap_buffers togl + end; + mainLoop() diff --git a/Togl/examples/texturesurf.ml b/Togl/examples/texturesurf.ml new file mode 100644 index 0000000..f5e3752 --- /dev/null +++ b/Togl/examples/texturesurf.ml @@ -0,0 +1,101 @@ +(* $Id: texturesurf.ml,v 1.13 2001-05-08 01:58:26 garrigue Exp $ *) + +open StdLabels + +let texpts = + [|[|0.0; 0.0; 0.0; 1.0|]; + [|1.0; 0.0; 1.0; 1.0|]|] + +let ctrlpoints = + [|[|-1.5; -1.5; 4.9; -0.5; -1.5; 2.0; 0.5; -1.5; -1.0; 1.5; -1.5; 2.0|]; + [|-1.5; -0.5; 1.0; -0.5; -0.5; 3.0; 0.5; -0.5; 0.0; 1.5; -0.5; -1.0|]; + [|-1.5; 0.5; 4.0; -0.5; 0.5; 0.0; 0.5; 0.5; 3.0; 1.5; 0.5; 4.0|]; + [|-1.5; 1.5; -2.0; -0.5; 1.5; -2.0; 0.5; 1.5; 0.0; 1.5; 1.5; -1.0|]|] + +let image_width = 64 +and image_height = 64 + +let pi = acos (-1.0) + +let display togl = + GlClear.clear [`color;`depth]; + GlDraw.color (1.0,1.0,1.0); + GlMap.eval_mesh2 ~mode:`fill ~range1:(0,20) ~range2:(0,20); + Gl.flush (); + Togl.swap_buffers togl + +let make_image () = + let image = + GlPix.create `ubyte ~height:image_height ~width:image_width ~format:`rgb in + let raw = GlPix.to_raw image + and pos = GlPix.raw_pos image in + for i = 0 to image_width - 1 do + let ti = 2.0 *. pi *. float i /. float image_width in + for j = 0 to image_height - 1 do + let tj = 2.0 *. pi *. float j /. float image_height in + Raw.sets raw ~pos:(pos ~x:j ~y:i) + (Array.map ~f:(fun x -> truncate (127.0 *. (1.0 +. x))) + [|sin ti; cos (2.0 *. ti); cos (ti +. tj)|]); + done; + done; + image + +let myinit () = + let ctrlpoints = Raw.of_matrix ~kind:`double ctrlpoints + and texpts = Raw.of_matrix ~kind:`double texpts in + GlMap.map2 ~target:`vertex_3 + (0.0, 1.0) ~order:4 (0.0, 1.0) ~order:4 ctrlpoints; + GlMap.map2 ~target:`texture_coord_2 + (0.0,1.0) ~order:2 (0.0,1.0) ~order:2 texpts; + Gl.enable `map2_texture_coord_2; + Gl.enable `map2_vertex_3; + GlMap.grid2 ~n1:20 ~range1:(0.0,1.0) ~n2:20 ~range2:(0.0,1.0); + let image = make_image () in + GlTex.env (`mode `decal); + List.iter ~f:(GlTex.parameter ~target:`texture_2d) + [ `wrap_s `repeat; + `wrap_t `repeat; + `mag_filter `nearest; + `min_filter `nearest ]; + GlTex.image2d image; + List.iter ~f:Gl.enable [`texture_2d;`depth_test;`normalize]; + GlDraw.shade_model `flat + +let my_reshape togl = + let h = Togl.height togl and w = Togl.width togl in + GlDraw.viewport ~x:0 ~y:0 ~w ~h; + GlMat.mode `projection; + GlMat.load_identity (); + let r = float h /. float w in + if w <= h then + GlMat.ortho ~x:(-4.0, 4.0) ~y:(-4.0 *. r, 4.0 *. r) ~z:(-4.0, 4.0) + else + GlMat.ortho ~x:(-4.0 /. r, 4.0 /. r) ~y:(-4.0, 4.0) ~z:(-4.0, 4.0); + GlMat.mode `modelview; + GlMat.load_identity (); + GlMat.rotate ~angle:85. ~x:1. ~y:1. ~z:1. () + +open Tk + +let main () = + let top = openTk () in + let togl = + Togl.create top ~rgba:true ~depth:true ~width:300 ~height:300 ~double:true + in + Wm.title_set top "Texture Surf"; + myinit (); + Togl.reshape_func togl ~cb:(fun () -> my_reshape togl); + Togl.display_func togl ~cb:(fun () -> display togl); + bind top ~events:[`KeyPress] ~fields:[`KeySymString] + ~action:(fun ev -> + match ev.ev_KeySymString with + "Up" -> GlMat.rotate ~angle:(-5.) ~z:1.0 (); display togl + | "Down" -> GlMat.rotate ~angle:(5.) ~z:1.0 (); display togl + | "Left" -> GlMat.rotate ~angle:(5.) ~x:1.0 (); display togl + | "Right" -> GlMat.rotate ~angle:(-5.) ~x:1.0 (); display togl + | "Escape" -> destroy top; exit 0 + | _ -> ()); + pack [togl] ~expand:true ~fill:`Both; + mainLoop () + +let _ = main () diff --git a/Togl/src/.cvsignore b/Togl/src/.cvsignore new file mode 100644 index 0000000..b0631c8 --- /dev/null +++ b/Togl/src/.cvsignore @@ -0,0 +1 @@ +lablgl lablgltop *_tags.c *_tags.h dll* *.lib diff --git a/Togl/src/.depend b/Togl/src/.depend new file mode 100644 index 0000000..55e54c8 --- /dev/null +++ b/Togl/src/.depend @@ -0,0 +1,2 @@ +togl.cmo: togl.cmi +togl.cmx: togl.cmi diff --git a/Togl/src/Makefile b/Togl/src/Makefile new file mode 100644 index 0000000..547813f --- /dev/null +++ b/Togl/src/Makefile @@ -0,0 +1,91 @@ +# Include shared parts +TOPDIR = ../.. +include $(TOPDIR)/Makefile.common + +# Composite options +INCLUDES = -I$(SRCDIR) -I$(TOGLDIR) \ + $(TKINCLUDES) -I. $(GLINCLUDES) $(XINCLUDES) +LIBS = $(TKLIBS) $(GLLIBS) $(XLIBS) +LIBDIRS = +ifeq (TOGL_WS,TOGL_X11) +COPTS += -DUSE_TCL_STUBS -DUSE_TK_STUBS +endif +OCAMLINC=-I +labltk -I $(SRCDIR) + +# Files +TOGLOBJS = ml_togl$(XO) $(TOGLDIR)/togl$(XO) + +# Extra rules +.cmx.opt: $(TOPDIR)/src/lablgl.cmxa togl.cmxa + $(OPTLINK) -o $@ $(OCAMLINC) -ccopt -L. \ + unix.cmxa labltk.cmxa ../../lablgl.cmxa togl.cmxa $< + +all: lablgltop$(XE) lablgl$(XB) + +opt: togl.cmxa + +libtogl.a: togl.cma +togl.cma: togl.cmo $(TOGLOBJS) $(CONFIG) + $(LIBRARIAN) -o togl togl.cmo $(TOGLOBJS) $(GLLIBS) $(TKLIBS) $(XLIBS) +togl.cmxa: togl.cmx $(TOGLOBJS) $(CONFIG) + $(LIBRARIAN) -o togl togl.cmx $(TOGLOBJS) $(GLLIBS) $(TKLIBS) $(XLIBS) + +$(TOGLDIR)/togl$(XO): $(TOGLDIR)/togl.c $(TOPDIR)/Makefile.config + cd $(TOGLDIR) && \ + $(CAMLC) -verbose -c -ccopt "-D$(TOGL_WS) $(COPTS) $(INCLUDES)" togl.c + +lablgltop$(XE): ../../src/lablgl.cma togl.cma + ocamlmktop $(CUSTOMTOP) -I . $(OCAMLINC) -o $@ \ + labltk.cma lablgl.cma togl.cma + +lablgl: $(CONFIG) Makefile libtogl$(XA) + $(MAKE) INSTALLDIR="$(INSTALLDIR)" real-$@ + +real-lablgl: + @echo generate lablgl + echo "#!/bin/sh" > lablgl + echo "# toplevel with lablGL and Togl" >> lablgl + if test -f dlltogl$(XS); then \ + echo 'exec ocaml -I +labltk -I "$(INSTALLDIR)" lablgl.cma labltk.cma togl.cma $$*' >> lablgl; \ + else echo 'exec "$(INSTALLDIR)/lablgltop" -I +labltk -I "$(INSTALLDIR)" $$*' >> lablgl; fi + chmod 755 lablgl + +togl_tags.c: togl_tags.var + $(VAR2SWITCH) TOGL_ < togl_tags.var > $@ + +preinstall: + cp togl.mli togl.ml libtogl$(XA) "$(INSTALLDIR)" + cd "$(INSTALLDIR)" && $(RANLIB) libtogl$(XA) + @if test -f dlltogl$(XS); then $(MAKE) installdll; \ + else $(MAKE) installtop; fi + cp lablgl$(XB) "$(BINDIR)" + +install: + @if test -f lablgltop$(XE); then $(MAKE) toglinstall; fi + +toglinstall: preinstall + cp togl.cmi togl.cma $(INSTTOP) "$(INSTALLDIR)" + @if test -f togl.cmxa; then $(MAKE) toglinstallopt; fi + +installdll: + cp dlltogl$(XS) "$(DLLDIR)" + +installtop: + cp lablgltop$(XE) "$(INSTALLDIR)" + +toglinstallopt: + cp togl.cmxa togl$(XA) togl.cmx "$(INSTALLDIR)" + cd "$(INSTALLDIR)" && $(RANLIB) togl$(XA) + +clean: + rm -f *.cm* *.o *.obj *.so *.lib *.a *.dll *.exe *.opt *_tags.c \ + *_tags.h *~ lablgltop$(EX) lablgl + rm -f $(TOGLDIR)/Makefile $(TOGLDIR)/*.o $(TOGLDIR)/*.obj + +depend: + ocamldep -pp camlp4o *.ml *.mli > .depend + +#dependencies +ml_tk$(XO): $(TOPDIR)/src/ml_gl.h tk_tags.h tk_tags.c +ml_togl$(XO) : $(TOPDIR)/src/ml_gl.h togl_tags.h togl_tags.c +include .depend diff --git a/Togl/src/Togl/LICENSE b/Togl/src/Togl/LICENSE new file mode 100644 index 0000000..e9badb7 --- /dev/null +++ b/Togl/src/Togl/LICENSE @@ -0,0 +1,27 @@ +This software is copyrighted by Brian Paul (brian@mesa3d.org) +and Benjamin Bederson (bederson@cs.umd.edu). The following +terms apply to all files associated with the software unless explicitly +disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. diff --git a/Togl/src/Togl/Togl.html b/Togl/src/Togl/Togl.html new file mode 100644 index 0000000..53de3e5 --- /dev/null +++ b/Togl/src/Togl/Togl.html @@ -0,0 +1,1081 @@ + + + + + + + Togl + + + + +
+

Togl — a Tk OpenGL widget

+

Copyright (C) 1996-2002 Brian Paul and Ben Bederson

+
+ + +
+

Contents

+ + + + +
+

Introduction

+ + Togl is a Tk widget for OpenGL rendering. + Togl was originally based on OGLTK, written by Benjamin Bederson at + the University of New Mexico. + Togl adds the new features: + +
    +
  • color-index mode support including color allocation functions +
  • support for requesting stencil, accumulation, alpha buffers, etc +
  • multiple OpenGL drawing widgets +
  • OpenGL extension testing from Tcl +
  • simple, portable font support +
  • overlay plane support +
+ +

+ Togl allows one to create and manage a special Tk/OpenGL widget + with Tcl and render into it with a C program. That is, + a typical Togl program will have Tcl code for managing the user interface + and a C program for computations and OpenGL rendering. + +

+ Togl is copyrighted by + Brian Paul + (brian_e_paul@yahoo.com) and + Benjamin Bederson + (bederson@cs.umd.edu). + See the LICENSE file for details. + +

+ The + Togl project and + home page are + hosted by SourceForge. + + +
+

Prerequisites

+ +

+ You should have + Tcl and Tk + installed on your computer. Togl works with Tcl/Tk + version 8.0 and up. The Mac OS X version requires version 8.4. + +

+ You must also have + OpenGL or + Mesa + (a free alternative to OpenGL) installed on your computer. + +

+ One should be familiar with Tcl, Tk, OpenGL, and C programming to use Togl + effectively. + + +
+

Getting Togl

+ +

+ The current version of Togl is 1.7. + Togl can be downloaded from + + SourceForge. + + +
+

Mailing list

+ +

+ See the + Togl project at SourceForge for mailing list information. + + +
+

Using Togl With Your Application

+ +

+ There are basically two ways of using Togl with your application: +

    +
  • + Link or "compile in" Togl with your executable or shared library. In this + case you must call Togl_Init() from your C code to initialize Togl. This + is the way the included Togl examples are built. + +
  • + Install the Togl shared library and pkgIndex.tcl file + (using make install) and then load it into wish using + package require Togl. + Then, before creating the Togl widget, call functions in your application + code (also a compiled into a shared library and loaded into wish) + to setup the Togl widget for the OpenGL rendering. + Create the blank Togl widget, + and then you're managing redraws and buffer swapping from the Tcl level. +
+ Since Togl is compiled into a shared library using the Tcl/Tk stubs-interface, + the same binary can be used with any version of Tck/Tk from 8.06 and up. + See README.stubs for more info. + +

Unix/X11 usage

+ +

+ Unix/X systems only need the togl.c, togl.h + and the public Tcl/Tk include files. + +

Windows 95/NT/2000/XP usage

+ +

+ Windows platforms need tkWinInt.h + and other internal Tk header files. So you need a Tcl/Tk + source distribution in addition to the Togl distribution + (or copy over the various include files). +

+ Here's the minimal way to build Togl with Tcl/Tk + using the gcc that is distributed + as part of the cygwin tools + (Microsoft's compilers work too): + 

+VER=8.4.12
+SRCDIR=`pwd`
+
+cd $SRCDIR/tcl$VER/win
+env 'CC=gcc -mno-cygwin' ./configure --enable-threads
+make libtclstub84.a
+
+cd $SRCDIR/tk$VER/win
+env 'CC=gcc -mno-cygwin' ./configure --enable-threads
+make libtkstub84.a
+
+cd $SRCDIR/Togl
+env 'CC=gcc -mno-cygwin' ./configure --with-tcl=../tcl$VER/win --with-tk=../tk$VER/win
+
+make
+
+ The resulting Togl17.dll and pkgIndex.tcl + should be installed into your Tcl distribution just like any other package. + +

Mac OS X usage

+ +

+ These special instructions are for building the Aqua version of Togl. + Mac OS X needs tkMacOSXInt.h + and other internal Tk header files. Unfortunately, the Tcl and Tk + frameworks that Apple distributes are missing the internal headers. + So you need a Tcl/Tk source distribution in addition to the Togl + distribution (or copy over the various include files). + You would probably want a newer version of Tcl and Tk anyway + because each minor revision of 8.4 has many Aqua bug fixes. +

+ Here's one way to build Tcl, Tk, and Togl on Mac OS X (assuming they + are all in the same directory) to install in your home directory: + 

+VER=8.4.12
+
+mkdir -p ~/bin
+make -C tcl$VER/macosx install PREFIX="${HOME}" INSTALL_PATH="${HOME}/Library/Frameworks"
+make -C tk$VER/macosx install PREFIX="${HOME}" INSTALL_PATH="${HOME}/Library/Frameworks"
+
+(cd Togl; ./configure --prefix="${HOME}")
+make -C Togl install
+
+ + +
+

C Togl Functions

+ +

+ These are the Togl functions one may call from a C program. + +

+ + #include "togl.h" + +
+ +

+ For portability, you should include the togl.h header + before any other OpenGL header so that various + Windows 95/NT/2000/XP stuff falls into place. + + +

Setup and Initialization Functions

+ +
+
int Togl_Init(Tcl_Interp *interp) +
+ Initializes the Togl module. This is typically called from the + Tk_Main() function + or via Tcl's package require command. +
+ +
+
void Togl_CreateFunc(Togl_Callback *proc) +
+ void Togl_DisplayFunc(Togl_Callback *proc) +
+ void Togl_ReshapeFunc(Togl_Callback *proc) +
+ void Togl_DestroyFunc(Togl_Callback *proc) + +
+ Register C functions to be called by Tcl/Tk when a widget is realized, + must be redrawn, is resized, or is destroyed respectively. +

+ Each C callback must be of the form: +

+	void callback(Togl *togl)
+	{
+	   ...your code...
+	}
+
+
+ +
+
void Togl_TimerFunc(Togl_Callback *proc) +
+ Register a C timer callback function which will be called every + n milliseconds. The interval n is specified + by the -time option to the Togl Tcl command. +

+ The C callback must be of the form: +

+	void my_timer_callback(Togl *togl)
+	{
+	   ...your code...
+	}
+
+
+ +
+
void Togl_ResetDefaultCallbacks(void) +
+ Reset all default callback pointers to NULL. +
+ +
+
void Togl_CreateCommand(char *cmd_name, Togl_CmdProc *cmd_proc) +
+ Used to create a new Togl sub-command. The C function which implements + the command must be of the form: +

+

+	int callback(Togl *togl, int argc, char *argv[])
+	{
+	   ...your code...
+	   return TCL_OK or TCL_ERROR;
+	}
+
+
+ +

Drawing-related Commands

+ +
+
void Togl_PostRedisplay(Togl *togl) +
+ Signals that the widget should be redrawn. When Tk is next idle the + user's C render callback will be invoked. This is typically called + from within a Togl sub-command which was registered with + Togl_CreateCommand(). +
+ +
+
void Togl_SwapBuffers(const Togl *togl) +
+ Swaps the front and back color buffers for a double-buffered widget. + glFlush() is executed if the window is single-buffered. This is + typically called in the rendering function which was registered with + Togl_DisplayFunc(). +
+ +
+
void Togl_MakeCurrent(const Togl *togl) +
+ Sets the current rendering context to the given widget. This is done + automatically before the Togl callback functions are called. So the + call is only needed if you have multiple widgets with separate OpenGL + contexts. If the argument is NULL, then the rendering context is cleared + and subsequent OpenGL commands will fail. +
+ +

Query Functions

+ +
+
char *Togl_Ident(const Togl *togl) +
+ Returns a pointer to the identification string associated with a Togl + widget or NULL if there's no identifier string. +
+ +
+
int Togl_Width(const Togl *togl) +
+ Returns the width of the given Togl widget. Typically called in the + function registered with Togl_ReshapeFunc(). +
+ +
+
int Togl_Height(const Togl *togl) +
+ Returns the height of the given Togl widget. Typically called in the + function registered with Togl_ReshapeFunc(). +
+ +
+
Tcl_Interp *Togl_Interp(const Togl *togl) +
+ Returns the Tcl interpreter associated with the given Togl widget. +
+
+
+ Tk_Window Togl_TkWin(const Togl *togl) +
+ Returns the Tk window associated with the given Togl widget. +
+ +

Color Index Mode Functions

+ +

+ These functions are only used for color index mode. + +

+
unsigned long Togl_AllocColor(Togl *togl, float red, float green, float blue) +
+ Allocate a color from a read-only colormap. Given a color specified + by red, green, and blue return a colormap index (aka pixel value) + whose entry most closely matches the red, green, blue color. Red, + green, and blue are values in [0,1]. This function is only used in + color index mode when the -privatecmap option is false. +
+ +
+
void Togl_FreeColor(Togl *togl, unsigned long index) +
+ Free a color in a read-only colormap. Index is a value which was + returned by the Togl_AllocColor() function. This function is only + used in color index mode when the -privatecmap option + is false. +
+ +
+
void Togl_SetColor(Togl *togl, + int index, float red, float green, float blue) +
+ Load the colormap entry specified by index with the given red, green + and blue values. Red, green, and blue are values in [0,1]. This + function is only used in color index mode when the + -privatecmap option is true. +
+ + +

Font Functions

+ +
+
GLuint Togl_LoadBitmapFont(Togl *togl, + const char *fontname) +
+ Load the named font as a set of glBitmap display lists. + fontname may be one of + +
    +
  • TOGL_BITMAP_8_BY_13 +
  • TOGL_BITMAP_9_BY_15 +
  • TOGL_BITMAP_TIMES_ROMAN_10 +
  • TOGL_BITMAP_TIMES_ROMAN_24 +
  • TOGL_BITMAP_HELVETICA_10 +
  • TOGL_BITMAP_HELVETICA_12 +
  • TOGL_BITMAP_HELVETICA_18 + +
  • or any X11 font name +
+ Zero is returned if this function fails. +
+ After Togl_LoadBitmapFont() has been called, returning fontbase, + you can render a string s with: +
+ + glListBase(fontbase); +
+ glCallLists(strlen(s), GL_BYTE, s); + +
+ To maximize the portability of your application it is best to use one + of the predefined TOGL_BITMAP_* fonts. +
+ +
+
void Togl_UnloadBitmapFont(Togl *togl, GLuint fontbase) + +
+ Destroys the bitmap display lists created by by Togl_LoadBitmapFont(). +
+ +

Client Data Functions

+ +
+
void Togl_SetClientData(Togl *togl, ClientData clientData) +
+ clientData is a pointer to an arbitrary user data structure. + Each Togl struct has such a pointer. + This function sets the Togl widget's client data pointer. +
+ +
+
ClientData Togl_GetClientData(const Togl *togl) +
+ clientData is a pointer to an arbitrary user data structure. + Each Togl struct has such a pointer. + This function returns the Togl widget's client data pointer. +
+ +
+
void Togl_ClientData(ClientData clientData) +
+ clientData is a pointer to an arbitrary user data structure. + Set default client data pointer for subsequent new Togl widgets. + Default value is NULL. +
+ + +

Overlay Functions

+ +

+ These functions are modelled after GLUT's overlay sub-API. + +

+
void Togl_UseLayer(Togl *togl, int layer) +
+ Select the layer into which subsequent OpenGL rendering will be + directed. layer may be either TOGL_OVERLAY or + TOGL_NORMAL. +
+ +
+
void Togl_ShowOverlay(Togl *togl) +
+ Display the overlay planes, if any. +
+ +
+
void Togl_HideOverlay(Togl *togl) +
+ Hide the overlay planes, if any. +
+ +
+
void Togl_PostOverlayRedisplay(Togl *togl) +
+ Signal that the overlay planes should be redraw. + When Tk is next idle the user's C overlay display callback will be invoked. + This is typically called from within a Togl sub-command which was + registered with Togl_CreateCommand(). +
+ +
+
void Togl_OverlayDisplayFunc(Togl_Callback *proc) +
+ Registers the C callback function which should be called to redraw the + overlay planes. This is the function which will be called in + response to Togl_PostOverlayRedisplay(). + The callback must be of the form: +

+

+	void RedrawOverlay(Togl *togl)
+	{
+	   ...your code...
+	}
+
+
+ +
+
int Togl_ExistsOverlay(Togl *togl) +
+ Returns 1 if overlay planes exist, 0 otherwise. +
+ +
+
int Togl_GetOverlayTransparentValue(const Togl *togl) +
+ Returns the color index of the overlay's transparent pixel value. +
+ +
+
int Togl_IsMappedOverlay(const Togl *togl) +
+ Returns 1 if the overlay planes are currently displayed, 0 otherwise. +
+ +
+
unsigned long Togl_AllocColorOverlay(const Togl *togl, + float red, float green, float blue) +
+ Allocate a color in the overlay planes. Red, green, and blue are + values in [0,1]. Return the color index or -1 if the allocation + fails. +
+ +
+
void Togl_FreeColorOverlay(const Togl *togl, unsigned long index) +
+ Free a color which was allocated with Togl_AllocColorOverlay(). +
+ + +

X11-only Functions

+ +

+ These functions are only implemented on systems using the X Window System. + We recommend that you avoid using these functions in your application since + they are not portable to other operating/window systems + (use Togl_TkWin() and normal Tk functions instead). +

+ +

+
Display *Togl_Display(const Togl *togl) +
+ Returns the X Display of a Togl widget. +
+ +
+
Screen *Togl_Screen(const Togl *togl) +
+ Returns the X Screen of a Togl widget. +
+ +
+
int Togl_ScreenNumber(const Togl *togl) +
+ Returns the X screen number of a Togl widget. +
+ +
+
Colormap Togl_Colormap(const Togl *togl) +
+ Returns the X Colormap used by a Togl widget. +
+ + +

Postscript Output

+

+ +

+
int Togl_DumpToEpsFile(const Togl *togl, + const char *filename, int rgbFlag, void (*user_redraw)()) +
+ Generate an encapsulated Postscript file of the image in a Togl widget. + filename is the name of the file to generate. + If rgbFlag is non-zero then an RGB image file is written, + else a grayscale image file is written. + user_redraw is a pointer to the function which will render the + desired image. This will typically be the same as the function passed + to Togl_DisplayFunc(). +
+ + +
+

Tcl Togl commands

+ +

+ These are the Togl commands one may call from a Tcl program. + +

+
togl pathName [options] +
+ Creates a new togl widget with name pathName and + an optional list of configuration options. Options include: +

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Option Default Comments
-width 400 + Width of widget in pixels.
-height 400 + Height of widget in pixels.
 
-ident "" + A user identification string. This is used match widgets + for the -sharecontext + and the -sharelist options (see below). + This is also useful in your callback functions + to determine which Togl widget is the caller. +
 
-rgba true + If true, use RGB(A) mode, otherwise use Color Index mode.
-redsize 1 + Minimum number of bits in red component.
-greensize 1 + Minimum number of bits in green component.
-bluesize 1 + Minimum number of bits in blue component.
-alpha 1 + If true and -rgba is true, request an alpha channel.
-alphasize 1 + Minimum number of bits in alpha component.
 
-double false + If true, request a double-buffered window, otherwise + request a single-buffered window.
 
-depth false + If true, request a depth buffer.
-depthsize 1 + Minimum number of bits in depth buffer.
 
-accum false + If true, request an accumulation buffer.
-accumredsize 1 + Minimum number of bits in accumulation buffer red component.
-accumgreensize 1 + Minimum number of bits in accumulation buffer green component.
-accumbluesize 1 + Minimum number of bits in accumulation buffer blue component.
-accumalphasize 1 + Minimum number of bits in accumulation buffer alpha component.
 
-stencil false + If true, request a stencil buffer.
-stencilsize 1 + Minimum number of bits in stencil component.
 
-auxbuffers 0 + Desired number of auxiliary buffers.
 
-privatecmap false + Only applicable in color index mode. + If false, use a shared read-only colormap. + If true, use a private read/write colormap. +
 
-overlay false + If true, request overlay planes.
 
-stereo false + If true, request a stereo-capable window.
-oldstereo false + On SGI workstations only: if true, request divided-screen stereo. +
 
-time 1 + Specifies the interval, in milliseconds, for + calling the C timer callback function which + was registered with Togl_TimerFunc.
 
-sharelist "" + Name of an existing Togl widget with which to + share display lists. +
-sharecontext "" + Name of an existing Togl widget with which to + share the OpenGL context. NOTE: most other + attributes such as double buffering, RGBA vs CI, + ancillary buffer specs, etc are then ignored. +
 
-indirect false + If present, request an indirect rendering context. + A direct rendering context is normally requested. + Only significant on Unix/X11. +
 
-cursor "" + Set the cursor in the widget window.
 
-pixelformat 0 + Set the pixel format to the (platform-dependent) given value.
+

+ + +
+
pathName configure +
+ Returns all configuration records for the named togl widget. +
+ +
+
pathName configure -option +
+ Returns configuration information for the specifed option + which may be one of: +
+
-width +
+ Returns the width configuration of the widget in the form: +
+ -width width Width W w +
+ where W is the default width in pixels + and w is the current width in pixels +
+
+
-height +
+ Returns the height configuration of the widget in the form: +
+ -height height Height H h +
+ where H is the default height in pixels + and h is the current height in pixels +
+
+
-extensions +
+ Returns a list of OpenGL extensions available. For example: + GL_EXT_polygon_offset GL_EXT_vertex_array +
+
+ +
+
pathName configure -option value +
+ Reconfigure a Togl widget. option may be any one of the + options listed in the togl command above. +
+ +
+
pathName render +
+ Causes the render callback function to be called for pathName. +
+ +
+
pathName swapbuffers +
+ Causes front/back buffers to be swapped if in double buffer mode. + And flushs the OpenGL command buffer if in single buffer mode. + (So this is appropriate to call after every frame is drawn.) +
+ +
+
pathName makecurrent +
+ Make the widget specified by pathName and its OpenGL context + the current ones. +
+ + +
+

Demo Programs

+ +

+ There are six demo programs: + +

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
double.tcl— compares single vs double buffering with two Togl widgets
texture.tcl— lets you play with texture mapping options
index.tcl— demo of using color index mode
overlay.tcl— example of using overlay planes (requires overlay hardware)
stereo.tcl— stereo example
gears.tcl— spinning gears demo
+
+ +

+ To compile the demos, edit the Makefile to suit your system, then + type make demos. + The demos are compiled into shared libraries, + that can are loaded into the Tcl interpreter as Tcl/Tk-extensions. + Demos are started by running the corrsponding Tcl script. + To run a demo just type ./double.tcl or ./texture.tcl etc. + + +
+

Stereo Rendering

+ +

+ Quad-buffered stereo-in-a-window is supported. Quad-buffer stereo + is only available on workstation-class graphics cards + (3Dlabs Wildcat series, + ATI FireGL series, + NVidia Quadro series, + and SGI workstations). + Legacy support for divided-screen stereo on SGI workstations is + available via the -oldstereo option. + Developers for SGI workstations might also like the + + autostereo package to automatically switch the display + in and out of stereo (other systems already do it automatically). +

+ Full-screen stereo that gaming graphics cards support (ATI Radeon, + NVidia GeForce) is not supported. + +
+

Common Questions and Problems

+ +

+ If you have something to add to this section please let us know. + +

Bad Match X errors on Sun systems

+

+ There's a bug in Sun's XmuLookupStandardColormap X library function. + If you compile togl.c with the SOLARIS_BUG symbol defined (-DSOLARIS_BUG) + this function call will be omitted. + + +
+

Reporting Bugs

+ +

+ There is a bug database on the + Togl Project Page. + You may also discuss bugs on the mailing list. +

+ When reporting bugs please provide as much information as possible. + Also, it's very helpful to us if you can provide an example program + which demonstrates the problem. + + +
+

Version History

+ +

Version 1.0 — March, 1996

+
    +
  • Initial version +
+ +

Version 1.1 (never officially released)

+
    +
  • Added Togl_LoadBitmapFont function +
  • Fixed a few bugs +
+ +

Version 1.2 — November, 1996

+
    +
  • added swapbuffers and makecurrent Tcl commands +
  • More bug fixes +
  • Upgraded to suport Tcl 7.6 and Tk 4.2 +
  • Added stereo and overlay plane support +
  • Added Togl_Get/SetClientData() functions +
  • Added Togl_DestroyFunc() +
+ +

Version 1.3 — May 2, 1997

+
    +
  • fixed a bug in Togl_Configure() +
  • fixed a compilation problem in using Tcl_PkgProvide() with Tcl < 7.4 +
  • new overlay functions: Togl_ExistsOverlay, Togl_GetOverlayTransparentValue, + Togl_IsMappedOverlay, Togl_AllocColorOverlay, Togl_FreeColorOverlay +
  • added X11 functions: Togl_Display, Togl_Screen, Togl_ScreenNumber, + Togl_Colormap +
  • added Togl_DumpToEpsFile function +
  • fixed a C++ compilation problem +
  • more robust overlay code +
  • added timers (Togl_TimerFunc) from Peter Dern and Elmar Gerwalin +
+ +

Version 1.4 — September 17, 1997

+
    +
  • Ported to Windows NT (Robert Casto) +
  • Updated for Tcl/Tk 8.0 +
  • Added many config flags (-redsize, -depthsize, etc) (Matthias Ott) +
  • Added Togl_Set*Func() functions to reassign callback functions (Matthias Ott) +
  • Added Togl_ResetDefaultCallbacks() and Togl_ClientData() functions (Greg Couch) +
+ +

Version 1.5 — September 18, 1998

+
    +
  • Fixed a few Unix and Windows compilation bugs +
  • Added Ben Evan's SGI stereo functions +
  • Multiple expose events now reduced to one redraw +
  • Destroying Togl widgets caused problems, patched by Adrian J. Chung +
  • Added Togl_TkWin() function +
  • Updated for Tcl/Tk 8.0p2 +
  • Added gears demo from Philip Quaife +
  • Added -sharelist and -sharecontext config flags +
  • Fixed a few overlay update bugs +
  • Added -indirect config flag +
+ +

Version 1.6 — May 7, 2003

+
    +
  • Added Togl_SetTimerFunc function +
  • Updated for Tcl/Tk 8.0.5 and 8.1 +
  • Context sharing added for Windows +
  • Macintosh support (by Paul Thiessen) +
  • Tcl/Tk stubs support — see README.tcl (by Jonas Beskow) +
+ +

Version 1.7 — Jan 2006

+
    +
  • Added Mac OS X support +
  • Enabled asking for quad-buffered stereo pixel formats on all platforms + (use -oldstereo on SGIs for splitscreen stereo — C API changed too) +
  • Configuring the cursor is no longer slow +
  • Added -pixelformat config flag +
  • Added setgrid support (unfortunately many window managers can't cope with 1x1 pixel grid) +
  • Only free context when last reference is gone +
  • Switched to TEA-based configure (instead of editting make files) +
+ +

Version 2.0 — ??? 2006

+ + +
+

Future plans

+
    +
  • add callback command options for create/display/reshape/destroy +
  • add vertical sync control +
  • multisampling support (can be worked-around by passing in a pixelformat) +
  • replace EPS support with TK photo image support +
  • simplify C API by requiring callback command options +
  • stubify C API +
  • Use Tcl object interface for callbacks +
  • allow (require?) private colormap to given with TK photo image +
+ + +
+

Contributors

+ +

+ Several people have contributed new features to Togl. Among them are: + +

    +
  • Ramon Ramsan — overlay plane support +
  • Miguel A. De Riera Pasenau — more overlay functions, X11 functions + and EPS output +
  • Peter Dern and Elmar Gerwalin — Togl_TimerFunc and related code +
  • Robert Casto — Windows NT port +
  • Geza Groma — Windows 95/NT patches +
  • Ben Evans — SGI stereo support +
  • Paul Thiessen — Macintosh support +
  • Jonas Beskow — Tcl/Tk stubs support +
  • Paul Kienzle — TEA debugging and patches +
  • Greg Couch — version 1.7 +
+ + Many others have contributed bug fixes. Thanks for your contributions! + +
+
+ Last edited on 25 October 2005 by Greg Couch. + + + diff --git a/Togl/src/Togl/ben.rgb b/Togl/src/Togl/ben.rgb new file mode 100644 index 0000000..4eb067a Binary files /dev/null and b/Togl/src/Togl/ben.rgb differ diff --git a/Togl/src/Togl/double.c b/Togl/src/Togl/double.c new file mode 100644 index 0000000..ba07257 --- /dev/null +++ b/Togl/src/Togl/double.c @@ -0,0 +1,280 @@ +/* $Id: double.c,v 1.14 2005/04/23 07:49:13 gregcouch Exp $ */ + +/* + * Togl - a Tk OpenGL widget + * Copyright (C) 1996-1997 Brian Paul and Ben Bederson + * See the LICENSE file for copyright details. + */ + +#include "togl.h" +#include +#include + +/* + * The following variable is a special hack that is needed in order for + * Sun shared libraries to be used for Tcl. + */ +#ifdef SUN +extern int matherr(); +int *tclDummyMathPtr = (int *) matherr; +#endif + +static GLuint FontBase; +static float xAngle = 0.0, yAngle = 0.0, zAngle = 0.0; +static GLfloat CornerX, CornerY, CornerZ; /* where to print strings */ + + +/* + * Togl widget create callback. This is called by Tcl/Tk when the widget has + * been realized. Here's where one may do some one-time context setup or + * initializations. + */ +void +create_cb(Togl *togl) +{ + + FontBase = Togl_LoadBitmapFont(togl, TOGL_BITMAP_8_BY_13); + if (!FontBase) { + printf("Couldn't load font!\n"); + exit(1); + } +} + + +/* + * Togl widget reshape callback. This is called by Tcl/Tk when the widget + * has been resized. Typically, we call glViewport and perhaps setup the + * projection matrix. + */ +void +reshape_cb(Togl *togl) +{ + int width = Togl_Width(togl); + int height = Togl_Height(togl); + float aspect = (float) width / (float) height; + + glViewport(0, 0, width, height); + + /* Set up projection transform */ + glMatrixMode(GL_PROJECTION); + glLoadIdentity(); + glFrustum(-aspect, aspect, -1.0, 1.0, 1.0, 10.0); + + CornerX = -aspect; + CornerY = -1.0; + CornerZ = -1.1; + + /* Change back to model view transform for rendering */ + glMatrixMode(GL_MODELVIEW); +} + + + +static void +print_string(const char *s) +{ + glCallLists(strlen(s), GL_UNSIGNED_BYTE, s); +} + + +/* + * Togl widget display callback. This is called by Tcl/Tk when the widget's + * contents have to be redrawn. Typically, we clear the color and depth + * buffers, render our objects, then swap the front/back color buffers. + */ +void +display_cb(Togl *togl) +{ + static GLuint cubeList = 0; + const char *ident; + + glClear(GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT); + + glLoadIdentity(); /* Reset modelview matrix to the identity + * matrix */ + glTranslatef(0.0, 0.0, -3.0); /* Move the camera back three units */ + glRotatef(xAngle, 1.0, 0.0, 0.0); /* Rotate by X, Y, and Z angles */ + glRotatef(yAngle, 0.0, 1.0, 0.0); + glRotatef(zAngle, 0.0, 0.0, 1.0); + + glEnable(GL_DEPTH_TEST); + + if (!cubeList) { + cubeList = glGenLists(1); + glNewList(cubeList, GL_COMPILE); + + /* Front face */ + glBegin(GL_QUADS); + glColor3f(0.0, 0.7, 0.1); /* Green */ + glVertex3f(-1.0, 1.0, 1.0); + glVertex3f(1.0, 1.0, 1.0); + glVertex3f(1.0, -1.0, 1.0); + glVertex3f(-1.0, -1.0, 1.0); + /* Back face */ + glColor3f(0.9, 1.0, 0.0); /* Yellow */ + glVertex3f(-1.0, 1.0, -1.0); + glVertex3f(1.0, 1.0, -1.0); + glVertex3f(1.0, -1.0, -1.0); + glVertex3f(-1.0, -1.0, -1.0); + /* Top side face */ + glColor3f(0.2, 0.2, 1.0); /* Blue */ + glVertex3f(-1.0, 1.0, 1.0); + glVertex3f(1.0, 1.0, 1.0); + glVertex3f(1.0, 1.0, -1.0); + glVertex3f(-1.0, 1.0, -1.0); + /* Bottom side face */ + glColor3f(0.7, 0.0, 0.1); /* Red */ + glVertex3f(-1.0, -1.0, 1.0); + glVertex3f(1.0, -1.0, 1.0); + glVertex3f(1.0, -1.0, -1.0); + glVertex3f(-1.0, -1.0, -1.0); + glEnd(); + + glEndList(); + + } + glCallList(cubeList); + + glDisable(GL_DEPTH_TEST); + glLoadIdentity(); + glColor3f(1.0, 1.0, 1.0); + glRasterPos3f(CornerX, CornerY, CornerZ); + glListBase(FontBase); + ident = Togl_Ident(togl); + if (strcmp(ident, "Single") == 0) { + print_string("Single buffered"); + } else { + print_string("Double buffered"); + } + Togl_SwapBuffers(togl); +} + + + + +int +setXrot_cb(Togl *togl, int argc, CONST84 char *argv[]) +{ + Tcl_Interp *interp = Togl_Interp(togl); + + /* error checking */ + if (argc != 3) { + Tcl_SetResult(interp, + "wrong # args: should be \"pathName setXrot ?angle?\"", + TCL_STATIC); + return TCL_ERROR; + } + + xAngle = atof(argv[2]); + + /* printf( "before %f ", xAngle ); */ + + if (xAngle < 0.0) { + xAngle += 360.0; + } else if (xAngle > 360.0) { + xAngle -= 360.0; + } + + /* printf( "after %f \n", xAngle ); */ + + Togl_PostRedisplay(togl); + + /* Let result string equal value */ + strcpy(interp->result, argv[2]); + return TCL_OK; +} + + + +int +setYrot_cb(Togl *togl, int argc, CONST84 char *argv[]) +{ + Tcl_Interp *interp = Togl_Interp(togl); + + /* error checking */ + if (argc != 3) { + Tcl_SetResult(interp, + "wrong # args: should be \"pathName setYrot ?angle?\"", + TCL_STATIC); + return TCL_ERROR; + } + + yAngle = atof(argv[2]); + + if (yAngle < 0.0) { + yAngle += 360.0; + } else if (yAngle > 360.0) { + yAngle -= 360.0; + } + + Togl_PostRedisplay(togl); + + /* Let result string equal value */ + strcpy(interp->result, argv[2]); + return TCL_OK; +} + +int +getXrot_cb(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[]) +{ + sprintf(interp->result, "%d", (int) xAngle); + return TCL_OK; +} + +int +getYrot_cb(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[]) +{ + sprintf(interp->result, "%d", (int) yAngle); + return TCL_OK; +} + +/* + * Called by Tk_Main() to let me initialize the modules (Togl) I will need. + */ +TOGL_EXTERN int +Double_Init(Tcl_Interp *interp) +{ +#ifdef USE_TCL_STUBS + if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif +#ifdef USE_TK_STUBS + if (Tk_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif + + if (Togl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } +#ifdef macintosh + Togl_MacSetupMainInterp(interp); +#endif + + /* + * Specify the C callback functions for widget creation, display, + * and reshape. + */ + Togl_CreateFunc(create_cb); + Togl_DisplayFunc(display_cb); + Togl_ReshapeFunc(reshape_cb); + + /* + * Make a new Togl widget command so the Tcl code can set a C variable. + */ + + Togl_CreateCommand("setXrot", setXrot_cb); + Togl_CreateCommand("setYrot", setYrot_cb); + + /* + * Call Tcl_CreateCommand for application-specific commands, if + * they weren't already created by the init procedures called above. + */ + + Tcl_CreateCommand(interp, "getXrot", (Tcl_CmdProc *) getXrot_cb, + (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "getYrot", (Tcl_CmdProc *) getYrot_cb, + (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} diff --git a/Togl/src/Togl/double.tcl b/Togl/src/Togl/double.tcl new file mode 100644 index 0000000..88987f7 --- /dev/null +++ b/Togl/src/Togl/double.tcl @@ -0,0 +1,103 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# $Id: double.tcl,v 1.5 2001/12/20 13:59:31 beskow Exp $ + +# Togl - a Tk OpenGL widget +# Copyright (C) 1996 Brian Paul and Ben Bederson +# See the LICENSE file for copyright details. + + +# $Log: double.tcl,v $ +# Revision 1.5 2001/12/20 13:59:31 beskow +# Improved error-handling in togl.c in case of window creation failure +# Added pkgIndex target to makefile +# Updated documentation to reflect stubs-interface (Togl.html + new README.stubs) +# Added tk8.4a3 headers +# Removed obsolete Tk internal headers +# +# Revision 1.4 2001/01/29 18:11:53 brianp +# Jonas Beskow's changes to use Tcl/Tk stub interface +# +# Revision 1.3 1998/03/12 03:52:31 brianp +# now sharing display lists between the widgets +# +# Revision 1.2 1996/10/23 23:31:56 brianp +# added -ident options to togl calls +# +# Revision 1.1 1996/10/23 23:17:22 brianp +# Initial revision +# + + +# An Tk/OpenGL widget demo with two windows, one single buffered and the +# other double buffered. + +load [file dirname [info script]]/double[info sharedlibextension] + +proc setup {} { + wm title . "Single vs Double Buffering" + + frame .f1 + + # create first Togl widget + togl .f1.o1 -width 200 -height 200 -rgba true -double false -depth true -ident Single + + # create second Togl widget, share display lists with first widget + togl .f1.o2 -width 200 -height 200 -rgba true -double true -depth true -ident Double -sharelist Single + + scale .sx -label {X Axis} -from 0 -to 360 -command {setAngle x} -orient horizontal + scale .sy -label {Y Axis} -from 0 -to 360 -command {setAngle y} -orient horizontal + button .btn -text Quit -command exit + + bind .f1.o1 { + motion_event [lindex [%W config -width] 4] \ + [lindex [%W config -height] 4] \ + %x %y + } + + bind .f1.o2 { + motion_event [lindex [%W config -width] 4] \ + [lindex [%W config -height] 4] \ + %x %y + } + + pack .f1.o1 .f1.o2 -side left -padx 3 -pady 3 -fill both -expand t + pack .f1 -fill both -expand t + pack .sx -fill x + pack .sy -fill x + pack .btn -fill x +} + + + +# This is called when mouse button 1 is pressed and moved in either of +# the OpenGL windows. +proc motion_event { width height x y } { + .f1.o1 setXrot [expr 360.0 * $y / $height] + .f1.o2 setXrot [expr 360.0 * $y / $height] + .f1.o1 setYrot [expr 360.0 * ($width - $x) / $width] + .f1.o2 setYrot [expr 360.0 * ($width - $x) / $width] + +# .sx set [expr 360.0 * $y / $height] +# .sy set [expr 360.0 * ($width - $x) / $width] + + .sx set [getXrot] + .sy set [getYrot] +} + +# This is called when a slider is changed. +proc setAngle {axis value} { + global xAngle yAngle zAngle + + switch -exact $axis { + x {.f1.o1 setXrot $value + .f1.o2 setXrot $value} + y {.f1.o1 setYrot $value + .f1.o2 setYrot $value} + } +} + +# Execution starts here! +setup diff --git a/Togl/src/Togl/gears.c b/Togl/src/Togl/gears.c new file mode 100644 index 0000000..9999a72 --- /dev/null +++ b/Togl/src/Togl/gears.c @@ -0,0 +1,402 @@ +/* gears.c */ + +/* + * 3-D gear wheels. This program is in the public domain. + * + * Brian Paul + * + * + * Modified to work under Togl as a widget for TK 1997 + * + * Philip Quaife + * + */ + +#include "togl.h" +#include +#include +#include + +#ifndef M_PI +# define M_PI 3.14159265 +#endif + +struct WHIRLYGIZMO +{ + GLint Gear1, Gear2, Gear3; + GLfloat Rotx, Roty, Rotz; + GLfloat Angle; + int Height, Width; +}; + +/* + * 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: inner_radius - radius of hole at center + * outer_radius - radius at center of teeth + * width - width of gear + * teeth - number of teeth + * tooth_depth - depth of tooth + */ +static void +gear(GLfloat inner_radius, GLfloat outer_radius, GLfloat width, + GLint teeth, GLfloat tooth_depth) +{ + GLint i; + GLfloat r0, r1, r2; + GLfloat angle, da; + GLfloat u, v, len; + + r0 = inner_radius; + r1 = outer_radius - tooth_depth / 2.0; + r2 = outer_radius + tooth_depth / 2.0; + + da = 2.0 * M_PI / teeth / 4.0; + + glShadeModel(GL_FLAT); + + glNormal3f(0.0, 0.0, 1.0); + + /* draw front face */ + glBegin(GL_QUAD_STRIP); + for (i = 0; i <= teeth; i++) { + angle = i * 2.0 * M_PI / teeth; + glVertex3f(r0 * cos(angle), r0 * sin(angle), width * 0.5); + glVertex3f(r1 * cos(angle), r1 * sin(angle), width * 0.5); + glVertex3f(r0 * cos(angle), r0 * sin(angle), width * 0.5); + glVertex3f(r1 * cos(angle + 3 * da), r1 * sin(angle + 3 * da), + width * 0.5); + } + glEnd(); + + /* draw front sides of teeth */ + glBegin(GL_QUADS); + da = 2.0 * M_PI / teeth / 4.0; + for (i = 0; i < teeth; i++) { + angle = i * 2.0 * M_PI / teeth; + + glVertex3f(r1 * cos(angle), r1 * sin(angle), width * 0.5); + glVertex3f(r2 * cos(angle + da), r2 * sin(angle + da), width * 0.5); + glVertex3f(r2 * cos(angle + 2 * da), r2 * sin(angle + 2 * da), + width * 0.5); + glVertex3f(r1 * cos(angle + 3 * da), r1 * sin(angle + 3 * da), + width * 0.5); + } + glEnd(); + + + glNormal3f(0.0, 0.0, -1.0); + + /* draw back face */ + glBegin(GL_QUAD_STRIP); + for (i = 0; i <= teeth; i++) { + angle = i * 2.0 * M_PI / teeth; + glVertex3f(r1 * cos(angle), r1 * sin(angle), -width * 0.5); + glVertex3f(r0 * cos(angle), r0 * sin(angle), -width * 0.5); + glVertex3f(r1 * cos(angle + 3 * da), r1 * sin(angle + 3 * da), + -width * 0.5); + glVertex3f(r0 * cos(angle), r0 * sin(angle), -width * 0.5); + } + glEnd(); + + /* draw back sides of teeth */ + glBegin(GL_QUADS); + da = 2.0 * M_PI / teeth / 4.0; + for (i = 0; i < teeth; i++) { + angle = i * 2.0 * M_PI / teeth; + + glVertex3f(r1 * cos(angle + 3 * da), r1 * sin(angle + 3 * da), + -width * 0.5); + glVertex3f(r2 * cos(angle + 2 * da), r2 * sin(angle + 2 * da), + -width * 0.5); + glVertex3f(r2 * cos(angle + da), r2 * sin(angle + da), -width * 0.5); + glVertex3f(r1 * cos(angle), r1 * sin(angle), -width * 0.5); + } + glEnd(); + + + /* draw outward faces of teeth */ + glBegin(GL_QUAD_STRIP); + for (i = 0; i < teeth; i++) { + angle = i * 2.0 * M_PI / teeth; + + glVertex3f(r1 * cos(angle), r1 * sin(angle), width * 0.5); + glVertex3f(r1 * cos(angle), r1 * sin(angle), -width * 0.5); + u = r2 * cos(angle + da) - r1 * cos(angle); + v = r2 * sin(angle + da) - r1 * sin(angle); + len = sqrt(u * u + v * v); + u /= len; + v /= len; + glNormal3f(v, -u, 0.0); + glVertex3f(r2 * cos(angle + da), r2 * sin(angle + da), width * 0.5); + glVertex3f(r2 * cos(angle + da), r2 * sin(angle + da), -width * 0.5); + glNormal3f(cos(angle), sin(angle), 0.0); + glVertex3f(r2 * cos(angle + 2 * da), r2 * sin(angle + 2 * da), + width * 0.5); + glVertex3f(r2 * cos(angle + 2 * da), r2 * sin(angle + 2 * da), + -width * 0.5); + u = r1 * cos(angle + 3 * da) - r2 * cos(angle + 2 * da); + v = r1 * sin(angle + 3 * da) - r2 * sin(angle + 2 * da); + glNormal3f(v, -u, 0.0); + glVertex3f(r1 * cos(angle + 3 * da), r1 * sin(angle + 3 * da), + width * 0.5); + glVertex3f(r1 * cos(angle + 3 * da), r1 * sin(angle + 3 * da), + -width * 0.5); + glNormal3f(cos(angle), sin(angle), 0.0); + } + + glVertex3f(r1 * cos(0), r1 * sin(0), width * 0.5); + glVertex3f(r1 * cos(0), r1 * sin(0), -width * 0.5); + + glEnd(); + + + glShadeModel(GL_SMOOTH); + + /* draw inside radius cylinder */ + glBegin(GL_QUAD_STRIP); + for (i = 0; i <= teeth; i++) { + angle = i * 2.0 * M_PI / teeth; + glNormal3f(-cos(angle), -sin(angle), 0.0); + glVertex3f(r0 * cos(angle), r0 * sin(angle), -width * 0.5); + glVertex3f(r0 * cos(angle), r0 * sin(angle), width * 0.5); + } + glEnd(); + +} + +/* + * static GLfloat view_rotx=20.0, view_roty=30.0, view_rotz=0.0; static GLint + * gear1, gear2, gear3; static GLfloat angle = 0.0; */ +static GLuint limit; +static GLuint count = 1; + +static GLubyte polycolor[4] = { 255, 255, 255, 255 }; + +static void +draw(Togl *togl) +{ + struct WHIRLYGIZMO *Wg; + + glClear(GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT); + + Wg = Togl_GetClientData(togl); + glDisable(GL_TEXTURE_2D); + glPushMatrix(); + glRotatef(Wg->Rotx, 1.0, 0.0, 0.0); + glRotatef(Wg->Roty, 0.0, 1.0, 0.0); + glRotatef(Wg->Rotz, 0.0, 0.0, 1.0); + + glPushMatrix(); + glTranslatef(-3.0, -2.0, 0.0); + glRotatef(Wg->Angle, 0.0, 0.0, 1.0); + glEnable(GL_DEPTH_TEST); + glCallList(Wg->Gear1); + glEnable(GL_DEPTH_TEST); + glPopMatrix(); + + glPushMatrix(); + glTranslatef(3.1, -2.0, 0.0); + glRotatef(-2.0 * Wg->Angle - 9.0, 0.0, 0.0, 1.0); + glCallList(Wg->Gear2); + glPopMatrix(); + + glPushMatrix(); + glTranslatef(-3.1, 4.2, 0.0); + glRotatef(-2.0 * Wg->Angle - 25.0, 0.0, 0.0, 1.0); + glCallList(Wg->Gear3); + glPopMatrix(); + + glPopMatrix(); + + Togl_SwapBuffers(togl); + +} + + +static void +zap(Togl *togl) +{ + struct WHIRLYGIZMO *Wg; + + Wg = Togl_GetClientData(togl); + free(Wg); +} + + +static void +idle(Togl *togl) +{ + struct WHIRLYGIZMO *Wg; + + Wg = Togl_GetClientData(togl); + Wg->Angle += 2.0; + Togl_PostRedisplay(togl); +} + + +/* change view angle, exit upon ESC */ +/* + * static GLenum key(int k, GLenum mask) { switch (k) { case TK_UP: view_rotx + * += 5.0; return GL_TRUE; case TK_DOWN: view_rotx -= 5.0; return GL_TRUE; case + * TK_LEFT: view_roty += 5.0; return GL_TRUE; case TK_RIGHT: view_roty -= 5.0; + * return GL_TRUE; case TK_z: view_rotz += 5.0; return GL_TRUE; case TK_Z: + * view_rotz -= 5.0; return GL_TRUE; } return GL_FALSE; } */ + +/* new window size or exposure */ +static void +reshape(Togl *togl) +{ + int width, height; + + width = Togl_Width(togl); + height = Togl_Height(togl); + glViewport(0, 0, (GLint) width, (GLint) height); + glMatrixMode(GL_PROJECTION); + glLoadIdentity(); + if (width > height) { + GLfloat w = (GLfloat) width / (GLfloat) height; + + glFrustum(-w, w, -1.0, 1.0, 5.0, 60.0); + } else { + GLfloat h = (GLfloat) height / (GLfloat) width; + + glFrustum(-1.0, 1.0, -h, h, 5.0, 60.0); + } + + glMatrixMode(GL_MODELVIEW); + glLoadIdentity(); + glTranslatef(0.0, 0.0, -40.0); + glClear(GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT); + +} + + +static void +init(Togl *togl) +{ + struct WHIRLYGIZMO *Wg; + + static GLfloat red[4] = { 0.8, 0.1, 0.0, 1.0 }; + static GLfloat green[4] = { 0.0, 0.8, 0.2, 1.0 }; + static GLfloat blue[4] = { 0.2, 0.2, 1.0, 1.0 }; + static GLfloat pos[4] = { 5.0, 5.0, 10.0, 0.0 }; + glLightfv(GL_LIGHT0, GL_POSITION, pos); + glEnable(GL_CULL_FACE); + glEnable(GL_LIGHTING); + glEnable(GL_LIGHT0); + glEnable(GL_DEPTH_TEST); + /* make the gears */ + Wg = malloc(sizeof (*Wg)); + if (!Wg) { + Tcl_SetResult(Togl_Interp(togl), + "\"Cannot allocate client data for widget\"", TCL_STATIC); + } + Wg->Gear1 = glGenLists(1); + glNewList(Wg->Gear1, GL_COMPILE); + glMaterialfv(GL_FRONT, GL_AMBIENT_AND_DIFFUSE, red); + gear(1.0, 4.0, 1.0, 20, 0.7); + glEndList(); + + Wg->Gear2 = glGenLists(1); + glNewList(Wg->Gear2, GL_COMPILE); + glMaterialfv(GL_FRONT, GL_AMBIENT_AND_DIFFUSE, green); + gear(0.5, 2.0, 2.0, 10, 0.7); + glEndList(); + + Wg->Gear3 = glGenLists(1); + glNewList(Wg->Gear3, GL_COMPILE); + glMaterialfv(GL_FRONT, GL_AMBIENT_AND_DIFFUSE, blue); + gear(1.3, 2.0, 0.5, 10, 0.7); + glEndList(); + + glEnable(GL_NORMALIZE); + Wg->Height = Togl_Height(togl); + Wg->Width = Togl_Width(togl); + Wg->Angle = 0.0; + Wg->Rotx = 0.0; + Wg->Roty = 0.0; + Wg->Rotz = 0.0; + Togl_SetClientData(togl, (ClientData) Wg); +} + +int +position(Togl *togl, int argc, CONST84 char *argv[]) +{ + struct WHIRLYGIZMO *Wg; + Tcl_Interp *interp = Togl_Interp(togl); + char Result[100]; + + Wg = Togl_GetClientData(togl); + /* error checking */ + if (argc != 2) { + Tcl_SetResult(interp, + "wrong # args: should be \"pathName \"", TCL_STATIC); + return TCL_ERROR; + } + + /* Let result string equal value */ + sprintf(Result, "%g %g", Wg->Roty, Wg->Rotx); + + Tcl_SetResult(interp, Result, TCL_VOLATILE); + return TCL_OK; +} + +int +rotate(Togl *togl, int argc, CONST84 char *argv[]) +{ + struct WHIRLYGIZMO *Wg; + Tcl_Interp *interp = Togl_Interp(togl); + + Wg = Togl_GetClientData(togl); + /* error checking */ + if (argc != 4) { + Tcl_SetResult(interp, + "wrong # args: should be \"pathName xrot yrot\"", TCL_STATIC); + return TCL_ERROR; + } + + Wg->Roty = atof(argv[2]); + Wg->Rotx = atof(argv[3]); + Togl_PostRedisplay(togl); + + /* Let result string equal value */ + strcpy(interp->result, argv[2]); + return TCL_OK; +} + +TOGL_EXTERN int +Gears_Init(Tcl_Interp *interp) +{ + /* + * Initialize Tcl, Tk, and the Togl widget module. + */ +#ifdef USE_TCL_STUBS + if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif +#ifdef USE_TK_STUBS + if (Tk_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif + + if (Togl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Specify the C callback functions for widget creation, display, + * and reshape. + */ + Togl_CreateFunc(init); + Togl_DestroyFunc(zap); + Togl_DisplayFunc(draw); + Togl_ReshapeFunc(reshape); + Togl_TimerFunc(idle); + Togl_CreateCommand("rotate", rotate); + Togl_CreateCommand("position", position); + return TCL_OK; +} diff --git a/Togl/src/Togl/gears.tcl b/Togl/src/Togl/gears.tcl new file mode 100755 index 0000000..ddb2729 --- /dev/null +++ b/Togl/src/Togl/gears.tcl @@ -0,0 +1,76 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# Togl - a Tk OpenGL widget +# Copyright (C) 1996-1997 Brian Paul and Ben Bederson +# See the LICENSE file for copyright details. + + +# +# Test Togl using GL Gears Demo +# +# Copyright (C) 1997 Philip Quaife +# + +load [file dirname [info script]]/gears[info sharedlibextension] + +proc setup {} { + global startx starty xangle0 yangle0 xangle yangle RotCnt + global vTime + set RotCnt 1 + set xangle 0.0 + set yangle 0.0 + set vTime 100 + wm title . "Rotating Gear Widget Test" + + label .t -text "Click and drag to rotate image" + pack .t -side top -padx 2 -pady 10 + frame .f + pack .f -side top + button .f.n1 -text " Add " -command AutoRot + button .f.r1 -text "Remove" -command DelRot + button .f.b1 -text " Quit " -command exit + entry .f.t -width 4 -textvariable vTime + pack .f.n1 .f.t .f.r1 .f.b1 -side left -anchor w -padx 5 + newRot .w0 10 + +} +proc AutoRot {} { + global RotCnt vTime + newRot .w$RotCnt $vTime + set RotCnt [expr $RotCnt + 1] +} + +proc DelRot {} { + global RotCnt vTime + if { $RotCnt != 0 } { + set RotCnt [expr $RotCnt - 1] + destroy .w$RotCnt + } +} + +proc newRot {win {tick 100} } { + togl $win -width 200 -height 200 -rgba true -double true -depth true -privatecmap false -time $tick + bind $win {RotStart %x %y %W} + bind $win {RotMove %x %y %W} + pack $win -expand true -fill both +} + +proc RotStart {x y W } { + global startx starty xangle0 yangle0 xangle yangle + set startx $x + set starty $y + set vPos [$W position] + set xangle0 [lindex $vPos 0] + set yangle0 [lindex $vPos 1] + } + +proc RotMove {x y W} { + global startx starty xangle0 yangle0 xangle yangle + set xangle [expr $xangle0 + ($x - $startx) ] + set yangle [expr $yangle0 + ($y - $starty) ] + $W rotate $xangle $yangle + } + +setup diff --git a/Togl/src/Togl/image.c b/Togl/src/Togl/image.c new file mode 100644 index 0000000..a4027ce --- /dev/null +++ b/Togl/src/Togl/image.c @@ -0,0 +1,249 @@ +/* + * SGI rgb file reader borrowed from gltk library + */ + +#include "togl.h" /* added by GG to include windows.h */ +#include +#include +#include +#include "image.h" + +#ifndef SEEK_SET +# define SEEK_SET 0 +#endif + + +static void +tkQuit(void) +{ + exit(0); +} + + +/******************************************************************************/ + +typedef struct _rawImageRec +{ + unsigned short imagic; + unsigned short type; + unsigned short dim; + unsigned short sizeX, sizeY, sizeZ; + unsigned long min, max; + unsigned long wasteBytes; + char name[80]; + unsigned long colorMap; + FILE *file; + unsigned char *tmp, *tmpR, *tmpG, *tmpB, *tmpA; + unsigned long rleEnd; + GLuint *rowStart; + GLint *rowSize; +} rawImageRec; + + +/******************************************************************************/ + +static void +ConvertShort(unsigned short *array, long length) +{ + unsigned long b1, b2; + unsigned char *ptr; + + ptr = (unsigned char *) array; + while (length--) { + b1 = *ptr++; + b2 = *ptr++; + *array++ = (b1 << 8) | (b2); + } +} + +static void +ConvertLong(GLuint *array, long length) +{ + unsigned long b1, b2, b3, b4; + unsigned char *ptr; + + ptr = (unsigned char *) array; + while (length--) { + b1 = *ptr++; + b2 = *ptr++; + b3 = *ptr++; + b4 = *ptr++; + *array++ = (b1 << 24) | (b2 << 16) | (b3 << 8) | (b4); + } +} + +static rawImageRec * +RawImageOpen(char *fileName) +{ + union + { + int testWord; + char testByte[4]; + } endianTest; + rawImageRec *raw; + GLenum swapFlag; + int x; + + endianTest.testWord = 1; + if (endianTest.testByte[0] == 1) { + swapFlag = GL_TRUE; + } else { + swapFlag = GL_FALSE; + } + + raw = (rawImageRec *) malloc(sizeof (rawImageRec)); + if (raw == NULL) { + fprintf(stderr, "Out of memory!\n"); + tkQuit(); + } + if ((raw->file = fopen(fileName, "rb")) == NULL) { + perror(fileName); + tkQuit(); + } + + fread(raw, 1, 12, raw->file); + + if (swapFlag) { + ConvertShort(&raw->imagic, 6); + } + + raw->tmp = (unsigned char *) malloc(raw->sizeX * 256); + raw->tmpR = (unsigned char *) malloc(raw->sizeX * 256); + raw->tmpG = (unsigned char *) malloc(raw->sizeX * 256); + raw->tmpB = (unsigned char *) malloc(raw->sizeX * 256); + raw->tmpA = (unsigned char *) malloc(raw->sizeX * 256); + if (raw->tmp == NULL || raw->tmpR == NULL || raw->tmpG == NULL || + raw->tmpB == NULL || raw->tmpA == NULL) { + fprintf(stderr, "Out of memory!\n"); + tkQuit(); + } + + if ((raw->type & 0xFF00) == 0x0100) { + x = raw->sizeY * raw->sizeZ * sizeof (GLuint); + raw->rowStart = (GLuint *) malloc(x); + raw->rowSize = (GLint *) malloc(x); + if (raw->rowStart == NULL || raw->rowSize == NULL) { + fprintf(stderr, "Out of memory!\n"); + tkQuit(); + } + raw->rleEnd = 512 + (2 * x); + fseek(raw->file, 512, SEEK_SET); + fread(raw->rowStart, 1, x, raw->file); + fread(raw->rowSize, 1, x, raw->file); + if (swapFlag) { + ConvertLong(raw->rowStart, x / sizeof (GLuint)); + ConvertLong((GLuint *) raw->rowSize, x / sizeof (GLint)); + } + } + return raw; +} + +static void +RawImageClose(rawImageRec * raw) +{ + + fclose(raw->file); + free(raw->tmp); + free(raw->tmpR); + free(raw->tmpG); + free(raw->tmpB); + free(raw->tmpA); + free(raw); +} + +static void +RawImageGetRow(rawImageRec * raw, unsigned char *buf, int y, int z) +{ + unsigned char *iPtr, *oPtr, pixel; + int count; + + if ((raw->type & 0xFF00) == 0x0100) { + fseek(raw->file, raw->rowStart[y + z * raw->sizeY], SEEK_SET); + fread(raw->tmp, 1, (unsigned int) raw->rowSize[y + z * raw->sizeY], + raw->file); + + iPtr = raw->tmp; + oPtr = buf; + while (1) { + pixel = *iPtr++; + count = (int) (pixel & 0x7F); + if (!count) { + return; + } + if (pixel & 0x80) { + while (count--) { + *oPtr++ = *iPtr++; + } + } else { + pixel = *iPtr++; + while (count--) { + *oPtr++ = pixel; + } + } + } + } else { + fseek(raw->file, 512 + (y * raw->sizeX) + (z * raw->sizeX * raw->sizeY), + SEEK_SET); + fread(buf, 1, raw->sizeX, raw->file); + } +} + +static void +RawImageGetData(rawImageRec * raw, TK_RGBImageRec * final) +{ + unsigned char *ptr; + int i, j; + + final->data = + (unsigned char *) malloc((raw->sizeX + 1) * (raw->sizeY + 1) * 4); + if (final->data == NULL) { + fprintf(stderr, "Out of memory!\n"); + tkQuit(); + } + + ptr = final->data; + for (i = 0; i < (int) (raw->sizeY); i++) { + RawImageGetRow(raw, raw->tmpR, i, 0); + RawImageGetRow(raw, raw->tmpG, i, 1); + RawImageGetRow(raw, raw->tmpB, i, 2); + if (raw->sizeZ == 4) { + /* 4 components */ + RawImageGetRow(raw, raw->tmpA, i, 3); + for (j = 0; j < (int) (raw->sizeX); j++) { + *ptr++ = *(raw->tmpR + j); + *ptr++ = *(raw->tmpG + j); + *ptr++ = *(raw->tmpB + j); + *ptr++ = *(raw->tmpA + j); + } + } else { + /* 3 components */ + for (j = 0; j < (int) (raw->sizeX); j++) { + *ptr++ = *(raw->tmpR + j); + *ptr++ = *(raw->tmpG + j); + *ptr++ = *(raw->tmpB + j); + } + } + } +} + +TK_RGBImageRec * +tkRGBImageLoad(char *fileName) +{ + rawImageRec *raw; + TK_RGBImageRec *final; + + raw = RawImageOpen(fileName); + final = (TK_RGBImageRec *) malloc(sizeof (TK_RGBImageRec)); + if (final == NULL) { + fprintf(stderr, "Out of memory!\n"); + tkQuit(); + } + final->sizeX = raw->sizeX; + final->sizeY = raw->sizeY; + final->sizeZ = raw->sizeZ; + RawImageGetData(raw, final); + RawImageClose(raw); + return final; +} + +/******************************************************************************/ diff --git a/Togl/src/Togl/image.h b/Togl/src/Togl/image.h new file mode 100644 index 0000000..47babb7 --- /dev/null +++ b/Togl/src/Togl/image.h @@ -0,0 +1,14 @@ +/* image.h */ + +#ifndef IMAGE_H +# define IMAGE_H + +typedef struct _TK_RGBImageRec +{ + int sizeX, sizeY, sizeZ; + unsigned char *data; +} TK_RGBImageRec; + +extern TK_RGBImageRec *tkRGBImageLoad(char *fileName); + +#endif diff --git a/Togl/src/Togl/index.c b/Togl/src/Togl/index.c new file mode 100644 index 0000000..8e26e26 --- /dev/null +++ b/Togl/src/Togl/index.c @@ -0,0 +1,184 @@ +/* $Id: index.c,v 1.10 2005/04/23 07:49:13 gregcouch Exp $ */ + +/* + * Togl - a Tk OpenGL widget + * Copyright (C) 1996-1997 Brian Paul and Ben Bederson + * See the LICENSE file for copyright details. + */ + + +/* + * An example Togl program using color-index mode. + */ + + +#include "togl.h" +#include +#include + + +/* + * The following variable is a special hack that is needed in order for + * Sun shared libraries to be used for Tcl. + */ +#ifdef SUN +extern int matherr(); +int *tclDummyMathPtr = (int *) matherr; +#endif + + +/* Our color indexes: */ +static unsigned long black, red, green, blue; + +/* Rotation angle */ +static float Angle = 0.0; + + +/* + * Togl widget create callback. This is called by Tcl/Tk when the widget has + * been realized. Here's where one may do some one-time context setup or + * initializations. + */ +void +create_cb(Togl *togl) +{ + /* allocate color indexes */ + black = Togl_AllocColor(togl, 0.0, 0.0, 0.0); + red = Togl_AllocColor(togl, 1.0, 0.0, 0.0); + green = Togl_AllocColor(togl, 0.0, 1.0, 0.0); + blue = Togl_AllocColor(togl, 0.0, 0.0, 1.0); + + /* If we were using a private read/write colormap we'd setup our color + * table with something like this: */ + /* + * black = 1; Togl_SetColor( togl, black, 0.0, 0.0, 0.0 ); red = 2; + * Togl_SetColor( togl, red, 1.0, 0.0, 0.0 ); green = 3; Togl_SetColor( + * togl, green, 0.0, 1.0, 0.0 ); blue = 4; Togl_SetColor( togl, blue, 0.0, + * 0.0, 1.0 ); */ + + glShadeModel(GL_FLAT); + glDisable(GL_DITHER); +} + + +/* + * Togl widget reshape callback. This is called by Tcl/Tk when the widget + * has been resized. Typically, we call glViewport and perhaps setup the + * projection matrix. + */ +void +reshape_cb(Togl *togl) +{ + int width = Togl_Width(togl); + int height = Togl_Height(togl); + float aspect = (float) width / (float) height; + + glViewport(0, 0, width, height); + + /* Set up projection transform */ + glMatrixMode(GL_PROJECTION); + glLoadIdentity(); + glOrtho(-aspect, aspect, -1.0, 1.0, -1.0, 1.0); + + /* Change back to model view transform for rendering */ + glMatrixMode(GL_MODELVIEW); +} + + +/* + * Togl widget display callback. This is called by Tcl/Tk when the widget's + * contents have to be redrawn. Typically, we clear the color and depth + * buffers, render our objects, then swap the front/back color buffers. + */ +void +display_cb(Togl *togl) +{ + glClearIndex(black); + glClear(GL_COLOR_BUFFER_BIT); + + glPushMatrix(); + glTranslatef(0.3, -0.3, 0.0); + glRotatef(Angle, 0.0, 0.0, 1.0); + glIndexi(red); + glBegin(GL_TRIANGLES); + glVertex2f(-0.5, -0.3); + glVertex2f(0.5, -0.3); + glVertex2f(0.0, 0.6); + glEnd(); + glPopMatrix(); + + glPushMatrix(); + glRotatef(Angle, 0.0, 0.0, 1.0); + glIndexi(green); + glBegin(GL_TRIANGLES); + glVertex2f(-0.5, -0.3); + glVertex2f(0.5, -0.3); + glVertex2f(0.0, 0.6); + glEnd(); + glPopMatrix(); + + glPushMatrix(); + glTranslatef(-0.3, 0.3, 0.0); + glRotatef(Angle, 0.0, 0.0, 1.0); + glIndexi(blue); + glBegin(GL_TRIANGLES); + glVertex2f(-0.5, -0.3); + glVertex2f(0.5, -0.3); + glVertex2f(0.0, 0.6); + glEnd(); + glPopMatrix(); + + glFlush(); + Togl_SwapBuffers(togl); +} + + +void +timer_cb(Togl *togl) +{ + Angle += 5.0; + Togl_PostRedisplay(togl); +} + + +TOGL_EXTERN int +Index_Init(Tcl_Interp *interp) +{ + /* + * Initialize Tcl, Tk, and the Togl widget module. + */ +#ifdef USE_TCL_STUBS + if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif +#ifdef USE_TK_STUBS + if (Tk_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif + + if (Togl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Specify the C callback functions for widget creation, display, + * and reshape. + */ + Togl_CreateFunc(create_cb); + Togl_DisplayFunc(display_cb); + Togl_ReshapeFunc(reshape_cb); + Togl_TimerFunc(timer_cb); + + /* + * Make a new Togl widget command so the Tcl code can set a C variable. + */ + /* NONE */ + + /* + * Call Tcl_CreateCommand for application-specific commands, if + * they weren't already created by the init procedures called above. + */ + return TCL_OK; +} diff --git a/Togl/src/Togl/index.tcl b/Togl/src/Togl/index.tcl new file mode 100644 index 0000000..ce6b7a7 --- /dev/null +++ b/Togl/src/Togl/index.tcl @@ -0,0 +1,51 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# $Id: index.tcl,v 1.5 2001/12/20 13:59:31 beskow Exp $ + +# Togl - a Tk OpenGL widget +# Copyright (C) 1996 Brian Paul and Ben Bederson +# See the LICENSE file for copyright details. + + +# $Log: index.tcl,v $ +# Revision 1.5 2001/12/20 13:59:31 beskow +# Improved error-handling in togl.c in case of window creation failure +# Added pkgIndex target to makefile +# Updated documentation to reflect stubs-interface (Togl.html + new README.stubs) +# Added tk8.4a3 headers +# Removed obsolete Tk internal headers +# +# Revision 1.4 2001/01/29 18:11:53 brianp +# Jonas Beskow's changes to use Tcl/Tk stub interface +# +# Revision 1.3 1998/01/24 14:05:50 brianp +# added quit button (Ben Bederson) +# +# Revision 1.2 1997/04/11 01:37:34 brianp +# added a timer to rotate the triangles +# +# Revision 1.1 1996/10/23 23:18:11 brianp +# Initial revision +# + + +# A Tk/OpenGL widget demo using color-index mode. + +load [file dirname [info script]]/index[info sharedlibextension] + +proc setup {} { + wm title . "Color index demo" + + togl .win -width 200 -height 200 -rgba false -double true -privatecmap false -time 10 + button .btn -text Quit -command exit + + pack .win -expand true -fill both + pack .btn -expand true -fill both +} + + + +# Execution starts here! +setup diff --git a/Togl/src/Togl/overlay.c b/Togl/src/Togl/overlay.c new file mode 100644 index 0000000..c4f403f --- /dev/null +++ b/Togl/src/Togl/overlay.c @@ -0,0 +1,194 @@ +/* $Id: overlay.c,v 1.7 2005/04/23 07:49:13 gregcouch Exp $ */ + +/* + * Togl - a Tk OpenGL widget + * Copyright (C) 1996-1997 Brian Paul and Ben Bederson + * See the LICENSE file for copyright details. + */ + + +/* + * An example Togl program using an overlay. + */ + + +#include "togl.h" +#include +#include + + +/* + * The following variable is a special hack that is needed in order for + * Sun shared libraries to be used for Tcl. + */ +#ifdef SUN +extern int matherr(); +int *tclDummyMathPtr = (int *) matherr; +#endif + + +/* Overlay color indexes: */ +static unsigned long Red, Green; + + +/* + * Togl widget create callback. This is called by Tcl/Tk when the widget has + * been realized. Here's where one may do some one-time context setup or + * initializations. + */ +void +create_cb(Togl *togl) +{ + /* allocate overlay color indexes */ + Red = Togl_AllocColorOverlay(togl, 1.0, 0.0, 0.0); + Green = Togl_AllocColorOverlay(togl, 0.0, 1.0, 0.0); + + /* in this demo we always show the overlay */ + if (Togl_ExistsOverlay(togl)) { + Togl_ShowOverlay(togl); + printf("Red and green lines are in the overlay\n"); + } else { + printf("Sorry, this display doesn't support overlays\n"); + } +} + + +/* + * Togl widget reshape callback. This is called by Tcl/Tk when the widget + * has been resized. Typically, we call glViewport and perhaps setup the + * projection matrix. + */ +void +reshape_cb(Togl *togl) +{ + int width = Togl_Width(togl); + int height = Togl_Height(togl); + float aspect = (float) width / (float) height; + + /* Set up viewing for normal plane's context */ + glViewport(0, 0, width, height); + glMatrixMode(GL_PROJECTION); + glLoadIdentity(); + glOrtho(-aspect, aspect, -1.0, 1.0, -1.0, 1.0); + glMatrixMode(GL_MODELVIEW); + + /* Set up viewing for overlay plane's context */ + if (Togl_ExistsOverlay(togl)) { + Togl_UseLayer(togl, TOGL_OVERLAY); + glViewport(0, 0, width, height); + glMatrixMode(GL_PROJECTION); + glLoadIdentity(); + glOrtho(-1.0, 1.0, -1.0, 1.0, -1.0, 1.0); + glMatrixMode(GL_MODELVIEW); + Togl_UseLayer(togl, TOGL_NORMAL); + } +} + + +/* + * Togl widget overlay display callback. This is called by Tcl/Tk when the + * overlay has to be redrawn. + */ +void +overlay_display_cb(Togl *togl) +{ + glClear(GL_COLOR_BUFFER_BIT); + + glIndexi(Red); + glBegin(GL_LINES); + glVertex2f(-1.0, -1.0); + glVertex2f(1.0, 1.0); + glVertex2f(-1.0, 1.0); + glVertex2f(1.0, -1.0); + glEnd(); + + glIndexi(Green); + glBegin(GL_LINE_LOOP); + glVertex2f(-0.5, -0.5); + glVertex2f(0.5, -0.5); + glVertex2f(0.5, 0.5); + glVertex2f(-0.5, 0.5); + glEnd(); + glFlush(); +} + + +/* + * Togl widget display callback. This is called by Tcl/Tk when the widget's + * contents have to be redrawn. Typically, we clear the color and depth + * buffers, render our objects, then swap the front/back color buffers. + */ +void +display_cb(Togl *togl) +{ + glClear(GL_COLOR_BUFFER_BIT); + + glLoadIdentity(); + + glBegin(GL_TRIANGLES); + + glColor3f(1.0, 0.0, 1.0); + glVertex2f(-0.5, -0.3); + glVertex2f(0.5, -0.3); + glVertex2f(0.0, 0.6); + + glColor3f(1.0, 1.0, 0.0); + glVertex2f(-0.5 + 0.2, -0.3 - 0.2); + glVertex2f(0.5 + 0.2, -0.3 - 0.2); + glVertex2f(0.0 + 0.2, 0.6 - 0.2); + + glColor3f(0.0, 1.0, 1.0); + glVertex2f(-0.5 + 0.4, -0.3 - 0.4); + glVertex2f(0.5 + 0.4, -0.3 - 0.4); + glVertex2f(0.0 + 0.4, 0.6 - 0.4); + + glEnd(); + + glFlush(); +} + + +/* + * Called by Tk_Main() to let me initialize the modules (Togl) I will need. + */ +TOGL_EXTERN int +Overlay_Init(Tcl_Interp *interp) +{ + /* + * Initialize Tcl, Tk, and the Togl widget module. + */ +#ifdef USE_TCL_STUBS + if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif +#ifdef USE_TK_STUBS + if (Tk_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif + if (Togl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Specify the C callback functions for widget creation, display, + * and reshape. + */ + Togl_CreateFunc(create_cb); + Togl_DisplayFunc(display_cb); + Togl_ReshapeFunc(reshape_cb); + + Togl_OverlayDisplayFunc(overlay_display_cb); + + /* + * Make a new Togl widget command so the Tcl code can set a C variable. + */ + /* NONE */ + + /* + * Call Tcl_CreateCommand for application-specific commands, if + * they weren't already created by the init procedures called above. + */ + return TCL_OK; +} diff --git a/Togl/src/Togl/overlay.tcl b/Togl/src/Togl/overlay.tcl new file mode 100644 index 0000000..0be48bc --- /dev/null +++ b/Togl/src/Togl/overlay.tcl @@ -0,0 +1,49 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# $Id: overlay.tcl,v 1.4 2001/12/20 13:59:31 beskow Exp $ + +# Togl - a Tk OpenGL widget +# Copyright (C) 1996 Brian Paul and Ben Bederson +# See the LICENSE file for copyright details. + + +# $Log: overlay.tcl,v $ +# Revision 1.4 2001/12/20 13:59:31 beskow +# Improved error-handling in togl.c in case of window creation failure +# Added pkgIndex target to makefile +# Updated documentation to reflect stubs-interface (Togl.html + new README.stubs) +# Added tk8.4a3 headers +# Removed obsolete Tk internal headers +# +# Revision 1.3 2001/01/29 18:11:53 brianp +# Jonas Beskow's changes to use Tcl/Tk stub interface +# +# Revision 1.2 1998/01/24 14:05:50 brianp +# added quit button (Ben Bederson) +# +# Revision 1.1 1997/03/07 01:26:38 brianp +# Initial revision +# +# + + +# A Tk/OpenGL widget demo using an overlay. + +load [file dirname [info script]]/overlay[info sharedlibextension] + +proc setup {} { + wm title . "Overlay demo" + + togl .win -width 200 -height 200 -rgba true -double false -overlay true + button .btn -text Quit -command exit + + pack .win -expand true -fill both + pack .btn -expand true -fill both +} + + + +# Execution starts here! +setup diff --git a/Togl/src/Togl/stereo.c b/Togl/src/Togl/stereo.c new file mode 100644 index 0000000..0a33f1e --- /dev/null +++ b/Togl/src/Togl/stereo.c @@ -0,0 +1,352 @@ +/* $Id: stereo.c,v 1.6 2005/04/23 07:49:13 gregcouch Exp $ */ + +/* + * Togl - a Tk OpenGL widget + * Copyright (C) 1996-1997 Brian Paul and Ben Bederson + * See the LICENSE file for copyright details. + */ + +#include "togl.h" +#include +#include + +/* + * The following variable is a special hack that is needed in order for + * Sun shared libraries to be used for Tcl. + */ +#ifdef SUN +extern int matherr(); +int *tclDummyMathPtr = (int *) matherr; +#endif + + +static GLuint FontBase; +static float xAngle = 0.0, yAngle = 0.0, zAngle = 0.0; +static GLfloat CornerX, CornerY, CornerZ; /* where to print strings */ +static GLfloat scale = 1.0; + + + +/* + * Togl widget create callback. This is called by Tcl/Tk when the widget has + * been realized. Here's where one may do some one-time context setup or + * initializations. + */ +void +create_cb(Togl *togl) +{ + FontBase = Togl_LoadBitmapFont(togl, TOGL_BITMAP_8_BY_13); + if (!FontBase) { + printf("Couldn't load font!\n"); + exit(1); + } +} + + +/* + * Togl widget reshape callback. This is called by Tcl/Tk when the widget + * has been resized. Typically, we call glViewport and perhaps setup the + * projection matrix. + */ +void +reshape_cb(Togl *togl) +{ + int width = Togl_Width(togl); + int height = Togl_Height(togl); + float aspect = (float) width / (float) height; + + glViewport(0, 0, width, height); + + /* Set up projection transform */ + glMatrixMode(GL_PROJECTION); + glLoadIdentity(); + glFrustum(-aspect, aspect, -1.0, 1.0, 1.0, 10.0); + + CornerX = -aspect; + CornerY = -1.0; + CornerZ = -1.1; + + /* Change back to model view transform for rendering */ + glMatrixMode(GL_MODELVIEW); +} + + + +static void +print_string(const char *s) +{ + glCallLists(strlen(s), GL_UNSIGNED_BYTE, s); +} + + +/* + * Togl widget display callback. This is called by Tcl/Tk when the widget's + * contents have to be redrawn. Typically, we clear the color and depth + * buffers, render our objects, then swap the front/back color buffers. + */ +void +display_cb(Togl *togl) +{ + const char *ident; + GLfloat eyeDist = 2.0; + GLfloat eyeOffset = 0.05; + + glClear(GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT); + + glLoadIdentity(); /* Reset modelview matrix to the identity + * matrix */ + glTranslatef(0.0, 0.0, -3.0); /* Move the camera back three units */ + glScalef(scale, scale, scale); /* Zoom in and out */ + glRotatef(xAngle, 1.0, 0.0, 0.0); /* Rotate by X, Y, and Z angles */ + glRotatef(yAngle, 0.0, 1.0, 0.0); + glRotatef(zAngle, 0.0, 0.0, 1.0); + + glEnable(GL_DEPTH_TEST); + + /* stereo right eye */ + glMatrixMode(GL_PROJECTION); + glLoadIdentity(); + Togl_StereoFrustum(-1, 1, -1, 1, 1, 10, eyeDist, eyeOffset); + glMatrixMode(GL_MODELVIEW); +#ifdef OLD_STEREO + Togl_OldStereoDrawBuffer(GL_BACK_RIGHT); + Togl_OldStereoClear(GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT); +#else + glDrawBuffer(GL_BACK_RIGHT); + glClear(GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT); +#endif + + /* Front face */ + glBegin(GL_QUADS); + glColor3f(0.0, 0.7, 0.1); /* Green */ + glVertex3f(-1.0, 1.0, 1.0); + glVertex3f(1.0, 1.0, 1.0); + glVertex3f(1.0, -1.0, 1.0); + glVertex3f(-1.0, -1.0, 1.0); + /* Back face */ + glColor3f(0.9, 1.0, 0.0); /* Yellow */ + glVertex3f(-1.0, 1.0, -1.0); + glVertex3f(1.0, 1.0, -1.0); + glVertex3f(1.0, -1.0, -1.0); + glVertex3f(-1.0, -1.0, -1.0); + /* Top side face */ + glColor3f(0.2, 0.2, 1.0); /* Blue */ + glVertex3f(-1.0, 1.0, 1.0); + glVertex3f(1.0, 1.0, 1.0); + glVertex3f(1.0, 1.0, -1.0); + glVertex3f(-1.0, 1.0, -1.0); + /* Bottom side face */ + glColor3f(0.7, 0.0, 0.1); /* Red */ + glVertex3f(-1.0, -1.0, 1.0); + glVertex3f(1.0, -1.0, 1.0); + glVertex3f(1.0, -1.0, -1.0); + glVertex3f(-1.0, -1.0, -1.0); + glEnd(); + + /* stereo left eye */ + glMatrixMode(GL_PROJECTION); + glLoadIdentity(); + Togl_StereoFrustum(-1, 1, -1, 1, 1, 10, eyeDist, -eyeOffset); + glMatrixMode(GL_MODELVIEW); + +#ifdef OLD_STEREO + Togl_OldStereoDrawBuffer(GL_BACK_LEFT); + Togl_OldStereoClear(GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT); +#else + glDrawBuffer(GL_BACK_LEFT); + glClear(GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT); +#endif + + /* Front face */ + glBegin(GL_QUADS); + glColor3f(0.0, 0.7, 0.1); /* Green */ + glVertex3f(-1.0, 1.0, 1.0); + glVertex3f(1.0, 1.0, 1.0); + glVertex3f(1.0, -1.0, 1.0); + glVertex3f(-1.0, -1.0, 1.0); + /* Back face */ + glColor3f(0.9, 1.0, 0.0); /* Yellow */ + glVertex3f(-1.0, 1.0, -1.0); + glVertex3f(1.0, 1.0, -1.0); + glVertex3f(1.0, -1.0, -1.0); + glVertex3f(-1.0, -1.0, -1.0); + /* Top side face */ + glColor3f(0.2, 0.2, 1.0); /* Blue */ + glVertex3f(-1.0, 1.0, 1.0); + glVertex3f(1.0, 1.0, 1.0); + glVertex3f(1.0, 1.0, -1.0); + glVertex3f(-1.0, 1.0, -1.0); + /* Bottom side face */ + glColor3f(0.7, 0.0, 0.1); /* Red */ + glVertex3f(-1.0, -1.0, 1.0); + glVertex3f(1.0, -1.0, 1.0); + glVertex3f(1.0, -1.0, -1.0); + glVertex3f(-1.0, -1.0, -1.0); + glEnd(); + + + glDisable(GL_DEPTH_TEST); + glLoadIdentity(); + glColor3f(1.0, 1.0, 1.0); + glRasterPos3f(CornerX, CornerY, CornerZ); + glListBase(FontBase); + /* ident = Togl_Ident( togl ); if (strcmp(ident,"Single")==0) { + * print_string( "Single buffered" ); } else { print_string( "Double + * buffered" ); } */ + print_string(Togl_Ident(togl)); + Togl_SwapBuffers(togl); +} + + +int +setXrot_cb(Togl *togl, int argc, CONST84 char *argv[]) +{ + Tcl_Interp *interp = Togl_Interp(togl); + + /* error checking */ + if (argc != 3) { + Tcl_SetResult(interp, + "wrong # args: should be \"pathName setXrot ?angle?\"", + TCL_STATIC); + return TCL_ERROR; + } + + xAngle = atof(argv[2]); + + /* printf( "before %f ", xAngle ); */ + + if (xAngle < 0.0) { + xAngle += 360.0; + } else if (xAngle > 360.0) { + xAngle -= 360.0; + } + + /* printf( "after %f \n", xAngle ); */ + + Togl_PostRedisplay(togl); + + /* Let result string equal value */ + strcpy(interp->result, argv[2]); + return TCL_OK; +} + + +int +setYrot_cb(Togl *togl, int argc, CONST84 char *argv[]) +{ + Tcl_Interp *interp = Togl_Interp(togl); + + /* error checking */ + if (argc != 3) { + Tcl_SetResult(interp, + "wrong # args: should be \"pathName setYrot ?angle?\"", + TCL_STATIC); + return TCL_ERROR; + } + + yAngle = atof(argv[2]); + + if (yAngle < 0.0) { + yAngle += 360.0; + } else if (yAngle > 360.0) { + yAngle -= 360.0; + } + + Togl_PostRedisplay(togl); + + /* Let result string equal value */ + strcpy(interp->result, argv[2]); + return TCL_OK; +} + + +int +getXrot_cb(ClientData clientData, Tcl_Interp *interp, + int argc, CONST84 char *argv[]) +{ + sprintf(interp->result, "%d", (int) xAngle); + return TCL_OK; +} + + +int +getYrot_cb(ClientData clientData, Tcl_Interp *interp, + int argc, CONST84 char *argv[]) +{ + sprintf(interp->result, "%d", (int) yAngle); + return TCL_OK; +} + + +int +scale_cb(Togl *togl, int argc, CONST84 char *argv[]) +{ + Tcl_Interp *interp = Togl_Interp(togl); + + /* error checking */ + if (argc != 3) { + Tcl_SetResult(interp, + "wrong # args: should be \"pathName scale ?value?\"", + TCL_STATIC); + return TCL_ERROR; + } + + scale = atof(argv[2]); + + Togl_PostRedisplay(togl); + + /* Let result string equal value */ + strcpy(interp->result, argv[2]); + return TCL_OK; +} + + +TOGL_EXTERN int +Stereo_Init(Tcl_Interp *interp) +{ + /* + * Initialize Tcl, Tk, and the Togl widget module. + */ +#ifdef USE_TCL_STUBS + if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif +#ifdef USE_TK_STUBS + if (Tk_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif + + if (Togl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Specify the C callback functions for widget creation, display, + * and reshape. + */ + Togl_CreateFunc(create_cb); + Togl_DisplayFunc(display_cb); + Togl_ReshapeFunc(reshape_cb); + + /* + * Make a new Togl widget command so the Tcl code can set a C variable. + */ + + Togl_CreateCommand("setXrot", setXrot_cb); + Togl_CreateCommand("setYrot", setYrot_cb); + Togl_CreateCommand("scale", scale_cb); + + /* + * Call Tcl_CreateCommand for application-specific commands, if + * they weren't already created by the init procedures called above. + */ + + Tcl_CreateCommand(interp, "getXrot", getXrot_cb, (ClientData) NULL, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "getYrot", getYrot_cb, (ClientData) NULL, + (Tcl_CmdDeleteProc *) NULL); + + return TCL_OK; +} diff --git a/Togl/src/Togl/stereo.tcl b/Togl/src/Togl/stereo.tcl new file mode 100644 index 0000000..ea5fc89 --- /dev/null +++ b/Togl/src/Togl/stereo.tcl @@ -0,0 +1,108 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# $Id: stereo.tcl,v 1.4 2004/12/21 05:28:39 gregcouch Exp $ + +# Togl - a Tk OpenGL widget +# Copyright (C) 1996 Brian Paul and Ben Bederson +# See the LICENSE file for copyright details. + + +# $Log: stereo.tcl,v $ +# Revision 1.4 2004/12/21 05:28:39 gregcouch +# Apply outstanding patches and Mac OS X support. +# +# Revision 1.3 2001/12/20 13:59:31 beskow +# Improved error-handling in togl.c in case of window creation failure +# Added pkgIndex target to makefile +# Updated documentation to reflect stubs-interface (Togl.html + new README.stubs) +# Added tk8.4a3 headers +# Removed obsolete Tk internal headers +# +# Revision 1.2 2001/01/29 18:11:53 brianp +# Jonas Beskow's changes to use Tcl/Tk stub interface +# +# Revision 1.1 1997/10/01 02:53:12 brianp +# Initial revision +# +# +# Revision 1.1 1997/9/28 18:54:46 Ben Evans +# Initial revision. Based on double.tcl +# + + +# An Tk/OpenGL widget demo with two windows, one single buffered and the +# other double buffered. + +load [file dirname [info script]]/stereo[info sharedlibextension] + +proc setup {} { + global scale + set scale 1.0 + wm title . "Full Screen Stereo Buffering" + + frame .f1 + togl .f1.o1 -width 200 -height 200 -rgba true -stereo true -double true -depth true -ident "stereo buffer" + + scale .sx -label {X Axis} -from 0 -to 360 -command {setAngle x} -orient horizontal + scale .sy -label {Y Axis} -from 0 -to 360 -command {setAngle y} -orient horizontal + button .btn -text Quit -command exit + + bind .f1.o1 { + motion_event [lindex [%W config -width] 4] \ + [lindex [%W config -height] 4] \ + %x %y + } + + bind .f1.o1 { + set startx %x + set starty %y + set scale0 $scale + } + + bind .f1.o1 { + set q [ expr ($starty - %y) / 400.0 ] + set scale [expr $scale0 * exp($q)] + .f1.o1 scale $scale + } + + pack .f1.o1 -side left -padx 3 -pady 3 -fill both -expand t + pack .f1 -fill both -expand t + pack .sx -fill x + pack .sy -fill x + pack .btn -fill x + + if {[string first $::tcl_platform(os) IRIX] != -1} { + puts "use /usr/gfx/setmon -n 60 to reset display and /usr/gfx/setmon -n STR_RECT to put in display in stereo mode" + } + +} + + + +# This is called when mouse button 1 is pressed and moved in either of +# the OpenGL windows. +proc motion_event { width height x y } { + .f1.o1 setXrot [expr 360.0 * $y / $height] + .f1.o1 setYrot [expr 360.0 * ($width - $x) / $width] + +# .sx set [expr 360.0 * $y / $height] +# .sy set [expr 360.0 * ($width - $x) / $width] + + .sx set [getXrot] + .sy set [getYrot] +} + +# This is called when a slider is changed. +proc setAngle {axis value} { + global xAngle yAngle zAngle + + switch -exact $axis { + x {.f1.o1 setXrot $value} + y {.f1.o1 setYrot $value} + } +} + +# Execution starts here! +setup diff --git a/Togl/src/Togl/texture.c b/Togl/src/Togl/texture.c new file mode 100644 index 0000000..6a6f39f --- /dev/null +++ b/Togl/src/Togl/texture.c @@ -0,0 +1,608 @@ +/* $Id: texture.c,v 1.10 2005/04/23 07:49:14 gregcouch Exp $ */ + +/* + * Togl - a Tk OpenGL widget + * Copyright (C) 1996-1997 Brian Paul and Ben Bederson + * See the LICENSE file for copyright details. + */ + + +/* + * An example Togl program demonstrating texture mapping + */ + + +#include "togl.h" +#include +#include +#if defined(TOGL_AGL) || defined(TOGL_AGL_CLASSIC) +# include +#else +# include +#endif +#include "image.h" + + +/* + * The following variable is a special hack that is needed in order for + * Sun shared libraries to be used for Tcl. + */ +#ifdef SUN +extern int matherr(); +int *tclDummyMathPtr = (int *) matherr; +#endif + +#define CHECKER 0 +#define FACE 1 +#define TREE 2 + + +static GLenum minfilter = GL_NEAREST_MIPMAP_LINEAR; +static GLenum magfilter = GL_LINEAR; +static GLenum swrap = GL_REPEAT; +static GLenum twrap = GL_REPEAT; +static GLenum envmode = GL_MODULATE; +static GLubyte polycolor[4] = { 255, 255, 255, 255 }; +static int image = CHECKER; +static GLfloat coord_scale = 1.0; +static GLfloat xrot = 0.0; +static GLfloat yrot = 0.0; +static GLfloat scale = 1.0; + +static GLint width, height; + +static GLboolean blend = GL_FALSE; + + +/* + * Load a texture image. n is one of CHECKER, FACE or TREE. + */ +void +texture_image(int n) +{ + if (n == CHECKER) { +#define WIDTH 64 +#define HEIGHT 64 + GLubyte teximage[WIDTH * HEIGHT][4]; + int i, j; + + for (i = 0; i < HEIGHT; i++) { + for (j = 0; j < WIDTH; j++) { + GLubyte value; + + value = ((i / 4 + j / 4) % 2) ? 0xff : 0x00; + teximage[i * WIDTH + j][0] = value; + teximage[i * WIDTH + j][1] = value; + teximage[i * WIDTH + j][2] = value; + teximage[i * WIDTH + j][3] = value; + } + } + + glEnable(GL_TEXTURE_2D); + gluBuild2DMipmaps(GL_TEXTURE_2D, 4, WIDTH, HEIGHT, + GL_RGBA, GL_UNSIGNED_BYTE, teximage); + blend = GL_FALSE; + +#undef WIDTH +#undef HEIGHT + } else if (n == FACE) { + TK_RGBImageRec *img = tkRGBImageLoad("ben.rgb"); + + if (img) { + glEnable(GL_TEXTURE_2D); + glPixelStorei(GL_UNPACK_ALIGNMENT, 1); + gluBuild2DMipmaps(GL_TEXTURE_2D, img->sizeZ, img->sizeX, img->sizeY, + img->sizeZ == 3 ? GL_RGB : GL_RGBA, + GL_UNSIGNED_BYTE, img->data); + + blend = GL_TRUE; + } + } else if (n == TREE) { + TK_RGBImageRec *img = tkRGBImageLoad("tree2.rgba"); + + if (img) { + glEnable(GL_TEXTURE_2D); + glPixelStorei(GL_UNPACK_ALIGNMENT, 1); + gluBuild2DMipmaps(GL_TEXTURE_2D, img->sizeZ, img->sizeX, img->sizeY, + img->sizeZ == 3 ? GL_RGB : GL_RGBA, + GL_UNSIGNED_BYTE, img->data); + + blend = GL_TRUE; + } + } else { + abort(); + } +} + + +/* + * Togl widget create callback. This is called by Tcl/Tk when the widget has + * been realized. Here's where one may do some one-time context setup or + * initializations. + */ +void +create_cb(Togl *togl) +{ + glEnable(GL_DEPTH_TEST); /* Enable depth buffering */ + + texture_image(CHECKER); + + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, magfilter); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, minfilter); +} + + +/* + * Togl widget reshape callback. This is called by Tcl/Tk when the widget + * has been resized. Typically, we call glViewport and perhaps setup the + * projection matrix. + */ +void +reshape_cb(Togl *togl) +{ + width = Togl_Width(togl); + height = Togl_Height(togl); + + glViewport(0, 0, width, height); + +} + + +static void +check_error(char *where) +{ + GLenum error; + + while (1) { + error = glGetError(); + if (error == GL_NO_ERROR) { + break; + } + printf("OpenGL error near %s: %s\n", where, gluErrorString(error)); + } +} + + + +/* + * Togl widget display callback. This is called by Tcl/Tk when the widget's + * contents have to be redrawn. Typically, we clear the color and depth + * buffers, render our objects, then swap the front/back color buffers. + */ +void +display_cb(Togl *togl) +{ + float aspect = (float) width / (float) height; + + check_error("begin display\n"); + + glClear(GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT); + + /* Draw background image */ + glMatrixMode(GL_PROJECTION); + glLoadIdentity(); + glMatrixMode(GL_MODELVIEW); + glLoadIdentity(); + + glDisable(GL_TEXTURE_2D); + glDisable(GL_DEPTH_TEST); + glBegin(GL_POLYGON); + glColor3f(0.0, 0.0, 0.3); + glVertex2f(-1.0, -1.0); + glColor3f(0.0, 0.0, 0.3); + glVertex2f(1.0, -1.0); + glColor3f(0.0, 0.0, 0.9); + glVertex2f(1.0, 1.0); + glColor3f(0.0, 0.0, 0.9); + glVertex2f(-1.0, 1.0); + glEnd(); + + /* draw textured object */ + glMatrixMode(GL_PROJECTION); + glLoadIdentity(); + glFrustum(-aspect, aspect, -1.0, 1.0, 2.0, 10.0); + glMatrixMode(GL_MODELVIEW); + glLoadIdentity(); + glTranslatef(0.0, 0.0, -5.0); + glScalef(scale, scale, scale); + glRotatef(yrot, 0.0, 1.0, 0.0); + glRotatef(xrot, 1.0, 0.0, 0.0); + + glEnable(GL_DEPTH_TEST); + glEnable(GL_TEXTURE_2D); + glColor4ubv(polycolor); + + if (blend) { + glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); + glEnable(GL_BLEND); + } + + glBegin(GL_POLYGON); + glTexCoord2f(0.0, 0.0); + glVertex2f(-1.0, -1.0); + glTexCoord2f(coord_scale, 0.0); + glVertex2f(1.0, -1.0); + glTexCoord2f(coord_scale, coord_scale); + glVertex2f(1.0, 1.0); + glTexCoord2f(0.0, coord_scale); + glVertex2f(-1.0, 1.0); + glEnd(); + + glDisable(GL_BLEND); + + Togl_SwapBuffers(togl); +} + + +/* + * Called when a magnification filter radio button is pressed. + */ +int +magfilter_cb(Togl *togl, int argc, CONST84 char *argv[]) +{ + Tcl_Interp *interp = Togl_Interp(togl); + + if (strcmp(argv[2], "GL_NEAREST") == 0) { + magfilter = GL_NEAREST; + } else if (strcmp(argv[2], "GL_LINEAR") == 0) { + magfilter = GL_LINEAR; + } else { + Tcl_SetResult(interp, "unknown magnification filter type", TCL_STATIC); + return TCL_ERROR; + } + + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, magfilter); + Togl_PostRedisplay(togl); + + return TCL_OK; +} + + +/* + * Called when a minification filter radio button is pressed. + */ +int +minfilter_cb(Togl *togl, int argc, CONST84 char *argv[]) +{ + Tcl_Interp *interp = Togl_Interp(togl); + + if (strcmp(argv[2], "GL_NEAREST") == 0) { + minfilter = GL_NEAREST; + } else if (strcmp(argv[2], "GL_LINEAR") == 0) { + minfilter = GL_LINEAR; + } else if (strcmp(argv[2], "GL_NEAREST_MIPMAP_NEAREST") == 0) { + minfilter = GL_NEAREST_MIPMAP_NEAREST; + } else if (strcmp(argv[2], "GL_LINEAR_MIPMAP_NEAREST") == 0) { + minfilter = GL_LINEAR_MIPMAP_NEAREST; + } else if (strcmp(argv[2], "GL_NEAREST_MIPMAP_LINEAR") == 0) { + minfilter = GL_NEAREST_MIPMAP_LINEAR; + } else if (strcmp(argv[2], "GL_LINEAR_MIPMAP_LINEAR") == 0) { + minfilter = GL_LINEAR_MIPMAP_LINEAR; + } else { + Tcl_SetResult(interp, "unknown minification filter type", TCL_STATIC); + return TCL_ERROR; + } + + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, minfilter); + Togl_PostRedisplay(togl); + + return TCL_OK; +} + + +int +xrot_cb(Togl *togl, int argc, CONST84 char *argv[]) +{ + Tcl_Interp *interp = Togl_Interp(togl); + + /* error checking */ + if (argc != 3) { + Tcl_SetResult(interp, + "wrong # args: should be \"pathName setXrot ?angle?\"", + TCL_STATIC); + return TCL_ERROR; + } + + xrot = atof(argv[2]); + + Togl_PostRedisplay(togl); + + /* Let result string equal value */ + strcpy(interp->result, argv[2]); + return TCL_OK; +} + + +int +yrot_cb(Togl *togl, int argc, CONST84 char *argv[]) +{ + Tcl_Interp *interp = Togl_Interp(togl); + + /* error checking */ + if (argc != 3) { + Tcl_SetResult(interp, + "wrong # args: should be \"pathName setYrot ?angle?\"", + TCL_STATIC); + return TCL_ERROR; + } + + yrot = atof(argv[2]); + + Togl_PostRedisplay(togl); + + /* Let result string equal value */ + strcpy(interp->result, argv[2]); + return TCL_OK; +} + + +int +scale_cb(Togl *togl, int argc, CONST84 char *argv[]) +{ + Tcl_Interp *interp = Togl_Interp(togl); + + /* error checking */ + if (argc != 3) { + Tcl_SetResult(interp, + "wrong # args: should be \"pathName scale ?value?\"", + TCL_STATIC); + return TCL_ERROR; + } + + scale = atof(argv[2]); + + Togl_PostRedisplay(togl); + + /* Let result string equal value */ + strcpy(interp->result, argv[2]); + return TCL_OK; +} + + +/* + * Called when S texture coordinate wrapping is changed. + */ +int +swrap_cb(Togl *togl, int argc, CONST84 char *argv[]) +{ + Tcl_Interp *interp = Togl_Interp(togl); + + /* error checking */ + if (argc != 3) { + Tcl_SetResult(interp, + "wrong # args: should be \"pathName swrap ?mode?\"", + TCL_STATIC); + return TCL_ERROR; + } + + if (strcmp(argv[2], "GL_CLAMP") == 0) { + swrap = GL_CLAMP; + } else if (strcmp(argv[2], "GL_REPEAT") == 0) { + swrap = GL_REPEAT; + } else { + Tcl_SetResult(interp, "unknown wrap value", TCL_STATIC); + return TCL_ERROR; + } + + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, swrap); + Togl_PostRedisplay(togl); + + /* Let result string equal value */ + strcpy(interp->result, argv[2]); + return TCL_OK; +} + + +/* + * Called when T texture coordinate wrapping is changed. + */ +int +twrap_cb(Togl *togl, int argc, CONST84 char *argv[]) +{ + Tcl_Interp *interp = Togl_Interp(togl); + + /* error checking */ + if (argc != 3) { + Tcl_SetResult(interp, + "wrong # args: should be \"pathName twrap ?mode?\"", + TCL_STATIC); + return TCL_ERROR; + } + + if (strcmp(argv[2], "GL_CLAMP") == 0) { + twrap = GL_CLAMP; + } else if (strcmp(argv[2], "GL_REPEAT") == 0) { + twrap = GL_REPEAT; + } else { + Tcl_SetResult(interp, "unknown wrap value", TCL_STATIC); + return TCL_ERROR; + } + + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, twrap); + Togl_PostRedisplay(togl); + + /* Let result string equal value */ + strcpy(interp->result, argv[2]); + return TCL_OK; +} + + +/* + * Called when the texture environment mode is changed. + */ +int +envmode_cb(Togl *togl, int argc, CONST84 char *argv[]) +{ + Tcl_Interp *interp = Togl_Interp(togl); + + /* error checking */ + if (argc != 3) { + Tcl_SetResult(interp, + "wrong # args: should be \"pathName envmode ?mode?\"", + TCL_STATIC); + return TCL_ERROR; + } + + if (strcmp(argv[2], "GL_MODULATE") == 0) { + envmode = GL_MODULATE; + } else if (strcmp(argv[2], "GL_DECAL") == 0) { + envmode = GL_DECAL; + } else if (strcmp(argv[2], "GL_BLEND") == 0) { + envmode = GL_BLEND; + } else { + Tcl_SetResult(interp, "unknown texture env mode", TCL_STATIC); + return TCL_ERROR; + } + + glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, envmode); + Togl_PostRedisplay(togl); + + /* Let result string equal value */ + strcpy(interp->result, argv[2]); + return TCL_OK; +} + + +/* + * Called when the polygon color is changed. + */ +int +polycolor_cb(Togl *togl, int argc, CONST84 char *argv[]) +{ + Tcl_Interp *interp = Togl_Interp(togl); + + /* error checking */ + if (argc != 5) { + Tcl_SetResult(interp, + "wrong # args: should be \"pathName polycolor ?r? ?g? ?b?\"", + TCL_STATIC); + return TCL_ERROR; + } + + polycolor[0] = atoi(argv[2]); + polycolor[1] = atoi(argv[3]); + polycolor[2] = atoi(argv[4]); + + Togl_PostRedisplay(togl); + + /* Let result string equal value */ + strcpy(interp->result, argv[2]); + return TCL_OK; +} + + +/* + * Called when the texture image is to be changed + */ +int +image_cb(Togl *togl, int argc, CONST84 char *argv[]) +{ + Tcl_Interp *interp = Togl_Interp(togl); + + /* error checking */ + if (argc != 3) { + Tcl_SetResult(interp, + "wrong # args: should be \"pathName image ?name?\"", + TCL_STATIC); + return TCL_ERROR; + } + + if (strcmp(argv[2], "CHECKER") == 0) { + texture_image(CHECKER); + } else if (strcmp(argv[2], "FACE") == 0) { + texture_image(FACE); + } else if (strcmp(argv[2], "TREE") == 0) { + texture_image(TREE); + } else { + Tcl_SetResult(interp, "unknown texture image", TCL_STATIC); + return TCL_ERROR; + } + + Togl_PostRedisplay(togl); + + /* Let result string equal value */ + strcpy(interp->result, argv[2]); + return TCL_OK; +} + + +/* + * Called when the texture coordinate scale is changed. + */ +int +coord_scale_cb(Togl *togl, int argc, CONST84 char *argv[]) +{ + Tcl_Interp *interp = Togl_Interp(togl); + float s; + + /* error checking */ + if (argc != 3) { + Tcl_SetResult(interp, + "wrong # args: should be \"pathName coord_scale ?scale?\"", + TCL_STATIC); + return TCL_ERROR; + } + + s = atof(argv[2]); + if (s > 0.0 && s < 10.0) { + coord_scale = s; + Togl_PostRedisplay(togl); + } + + /* Let result string equal value */ + strcpy(interp->result, argv[2]); + return TCL_OK; +} + + +TOGL_EXTERN int +Texture_Init(Tcl_Interp *interp) +{ + /* + * Initialize Tcl, Tk, and the Togl widget module. + */ +#ifdef USE_TCL_STUBS + if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif +#ifdef USE_TK_STUBS + if (Tk_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif + + if (Togl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Specify the C callback functions for widget creation, display, + * and reshape. + */ + Togl_CreateFunc(create_cb); + Togl_DisplayFunc(display_cb); + Togl_ReshapeFunc(reshape_cb); + + /* + * Make a new Togl widget command so the Tcl code can set a C variable. + */ + Togl_CreateCommand("min_filter", minfilter_cb); + Togl_CreateCommand("mag_filter", magfilter_cb); + Togl_CreateCommand("xrot", xrot_cb); + Togl_CreateCommand("yrot", yrot_cb); + Togl_CreateCommand("scale", scale_cb); + Togl_CreateCommand("swrap", swrap_cb); + Togl_CreateCommand("twrap", twrap_cb); + Togl_CreateCommand("envmode", envmode_cb); + Togl_CreateCommand("polycolor", polycolor_cb); + Togl_CreateCommand("image", image_cb); + Togl_CreateCommand("coord_scale", coord_scale_cb); + + /* + * Call Tcl_CreateCommand for application-specific commands, if + * they weren't already created by the init procedures called above. + */ + + return TCL_OK; +} diff --git a/Togl/src/Togl/texture.tcl b/Togl/src/Togl/texture.tcl new file mode 100644 index 0000000..6333c06 --- /dev/null +++ b/Togl/src/Togl/texture.tcl @@ -0,0 +1,283 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# $Id: texture.tcl,v 1.5 2001/12/20 13:59:31 beskow Exp $ + +# Togl - a Tk OpenGL widget +# Copyright (C) 1996 Brian Paul and Ben Bederson +# See the LICENSE file for copyright details. + + +# $Log: texture.tcl,v $ +# Revision 1.5 2001/12/20 13:59:31 beskow +# Improved error-handling in togl.c in case of window creation failure +# Added pkgIndex target to makefile +# Updated documentation to reflect stubs-interface (Togl.html + new README.stubs) +# Added tk8.4a3 headers +# Removed obsolete Tk internal headers +# +# Revision 1.4 2001/01/29 18:11:53 brianp +# Jonas Beskow's changes to use Tcl/Tk stub interface +# +# Revision 1.3 1998/01/24 14:05:50 brianp +# added quit button (Ben Bederson) +# +# Revision 1.2 1997/09/30 23:54:46 brianp +# new layout +# +# Revision 1.1 1996/10/23 23:18:36 brianp +# Initial revision +# + + +# Togl texture map demo + +load [file dirname [info script]]/texture[info sharedlibextension] + + +# Called magnification filter changes +proc new_magfilter {} { + global magfilter + .f1.view mag_filter $magfilter +} + + +# Called minification filter changes +proc new_minfilter {} { + global minfilter + .f1.view min_filter $minfilter +} + + +# Called when texture image radio button changes +proc new_image {} { + global teximage + .f1.view image $teximage +} + + +# Called when texture S wrap button changes +proc new_swrap {} { + global swrap + .f1.view swrap $swrap +} + + +# Called when texture T wrap button changes +proc new_twrap {} { + global twrap + .f1.view twrap $twrap +} + + +# Called when texture environment radio button selected +proc new_env {} { + global envmode + .f1.view envmode $envmode +} + + +# Called when polygon color sliders change +proc new_color { foo } { + global poly_red poly_green poly_blue + .f1.view polycolor $poly_red $poly_green $poly_blue +} + + +proc new_coord_scale { name element op } { + global coord_scale + .f1.view coord_scale $coord_scale +} + + + + +# Make the widgets +proc setup {} { + global magfilter + global minfilter + global teximage + global swrap + global twrap + global envmode + global poly_red + global poly_green + global poly_blue + global coord_scale + global startx starty # location of mouse when button pressed + global xangle yangle + global xangle0 yangle0 + global scale scale0 + + wm title . "Texture Map Options" + + ### Two frames: top half and bottom half + frame .f1 + frame .f2 + + ### The OpenGL window + togl .f1.view -width 250 -height 250 -rgba true -double true -depth true + + + ### Filter radio buttons + frame .f1.filter -relief ridge -borderwidth 3 + + frame .f1.filter.mag -relief ridge -borderwidth 2 + + label .f1.filter.mag.label -text "Magnification Filter" -anchor w + radiobutton .f1.filter.mag.nearest -text GL_NEAREST -anchor w -variable magfilter -value GL_NEAREST -command new_magfilter + radiobutton .f1.filter.mag.linear -text GL_LINEAR -anchor w -variable magfilter -value GL_LINEAR -command new_magfilter + + frame .f1.filter.min -relief ridge -borderwidth 2 + + label .f1.filter.min.label -text "Minification Filter" -anchor w + radiobutton .f1.filter.min.nearest -text GL_NEAREST -anchor w -variable minfilter -value GL_NEAREST -command new_minfilter + radiobutton .f1.filter.min.linear -text GL_LINEAR -anchor w -variable minfilter -value GL_LINEAR -command new_minfilter + radiobutton .f1.filter.min.nearest_mipmap_nearest -text GL_NEAREST_MIPMAP_NEAREST -anchor w -variable minfilter -value GL_NEAREST_MIPMAP_NEAREST -command new_minfilter + radiobutton .f1.filter.min.linear_mipmap_nearest -text GL_LINEAR_MIPMAP_NEAREST -anchor w -variable minfilter -value GL_LINEAR_MIPMAP_NEAREST -command new_minfilter + radiobutton .f1.filter.min.nearest_mipmap_linear -text GL_NEAREST_MIPMAP_LINEAR -anchor w -variable minfilter -value GL_NEAREST_MIPMAP_LINEAR -command new_minfilter + radiobutton .f1.filter.min.linear_mipmap_linear -text GL_LINEAR_MIPMAP_LINEAR -anchor w -variable minfilter -value GL_LINEAR_MIPMAP_LINEAR -command new_minfilter + + pack .f1.filter.mag -fill x + pack .f1.filter.mag.label -fill x + pack .f1.filter.mag.nearest -side top -fill x + pack .f1.filter.mag.linear -side top -fill x + + pack .f1.filter.min -fill both -expand true + pack .f1.filter.min.label -side top -fill x + pack .f1.filter.min.nearest -side top -fill x + pack .f1.filter.min.linear -side top -fill x + pack .f1.filter.min.nearest_mipmap_nearest -side top -fill x + pack .f1.filter.min.linear_mipmap_nearest -side top -fill x + pack .f1.filter.min.nearest_mipmap_linear -side top -fill x + pack .f1.filter.min.linear_mipmap_linear -side top -fill x + + + ### Texture coordinate scale and wrapping + frame .f2.coord -relief ridge -borderwidth 3 + frame .f2.coord.scale -relief ridge -borderwidth 2 + label .f2.coord.scale.label -text "Max Texture Coord" -anchor w + entry .f2.coord.scale.entry -textvariable coord_scale + trace variable coord_scale w new_coord_scale + + frame .f2.coord.s -relief ridge -borderwidth 2 + label .f2.coord.s.label -text "GL_TEXTURE_WRAP_S" -anchor w + radiobutton .f2.coord.s.repeat -text "GL_REPEAT" -anchor w -variable swrap -value GL_REPEAT -command new_swrap + radiobutton .f2.coord.s.clamp -text "GL_CLAMP" -anchor w -variable swrap -value GL_CLAMP -command new_swrap + + frame .f2.coord.t -relief ridge -borderwidth 2 + label .f2.coord.t.label -text "GL_TEXTURE_WRAP_T" -anchor w + radiobutton .f2.coord.t.repeat -text "GL_REPEAT" -anchor w -variable twrap -value GL_REPEAT -command new_twrap + radiobutton .f2.coord.t.clamp -text "GL_CLAMP" -anchor w -variable twrap -value GL_CLAMP -command new_twrap + + pack .f2.coord.scale -fill both -expand true + pack .f2.coord.scale.label -side top -fill x + pack .f2.coord.scale.entry -side top -fill x + + pack .f2.coord.s -fill x + pack .f2.coord.s.label -side top -fill x + pack .f2.coord.s.repeat -side top -fill x + pack .f2.coord.s.clamp -side top -fill x + + pack .f2.coord.t -fill x + pack .f2.coord.t.label -side top -fill x + pack .f2.coord.t.repeat -side top -fill x + pack .f2.coord.t.clamp -side top -fill x + + + ### Texture image radio buttons (just happens to fit into the coord frame) + frame .f2.env -relief ridge -borderwidth 3 + frame .f2.env.image -relief ridge -borderwidth 2 + label .f2.env.image.label -text "Texture Image" -anchor w + radiobutton .f2.env.image.checker -text "Checker" -anchor w -variable teximage -value CHECKER -command new_image + radiobutton .f2.env.image.tree -text "Tree" -anchor w -variable teximage -value TREE -command new_image + radiobutton .f2.env.image.face -text "Face" -anchor w -variable teximage -value FACE -command new_image + pack .f2.env.image -fill x + pack .f2.env.image.label -side top -fill x + pack .f2.env.image.checker -side top -fill x + pack .f2.env.image.tree -side top -fill x + pack .f2.env.image.face -side top -fill x + + + ### Texture Environment + label .f2.env.label -text "GL_TEXTURE_ENV_MODE" -anchor w + radiobutton .f2.env.modulate -text "GL_MODULATE" -anchor w -variable envmode -value GL_MODULATE -command new_env + radiobutton .f2.env.decal -text "GL_DECAL" -anchor w -variable envmode -value GL_DECAL -command new_env + radiobutton .f2.env.blend -text "GL_BLEND" -anchor w -variable envmode -value GL_BLEND -command new_env + pack .f2.env.label -fill x + pack .f2.env.modulate -side top -fill x + pack .f2.env.decal -side top -fill x + pack .f2.env.blend -side top -fill x + + ### Polygon color + frame .f2.color -relief ridge -borderwidth 3 + label .f2.color.label -text "Polygon color" -anchor w + scale .f2.color.red -label Red -from 0 -to 255 -orient horizontal -variable poly_red -command new_color + scale .f2.color.green -label Green -from 0 -to 255 -orient horizontal -variable poly_green -command new_color + scale .f2.color.blue -label Blue -from 0 -to 255 -orient horizontal -variable poly_blue -command new_color + pack .f2.color.label -fill x + pack .f2.color.red -side top -fill x + pack .f2.color.green -side top -fill x + pack .f2.color.blue -side top -fill x + + + ### Main widgets + pack .f1.view -side left -fill both -expand true + pack .f1.filter -side left -fill y + pack .f1 -side top -fill both -expand true + + pack .f2.coord .f2.env -side left -fill both + pack .f2.color -fill x + pack .f2 -side top -fill x + + button .btn -text Quit -command exit + pack .btn -expand true -fill both + + bind .f1.view { + set startx %x + set starty %y + set xangle0 $xangle + set yangle0 $yangle + } + + bind .f1.view { + set xangle [expr $xangle0 + (%x - $startx) / 3.0 ] + set yangle [expr $yangle0 + (%y - $starty) / 3.0 ] + .f1.view yrot $xangle + .f1.view xrot $yangle + } + + bind .f1.view { + set startx %x + set starty %y + set scale0 $scale + } + + bind .f1.view { + set q [ expr ($starty - %y) / 400.0 ] + set scale [expr $scale0 * exp($q)] + .f1.view scale $scale + } + + # set default values: + set minfilter GL_NEAREST_MIPMAP_LINEAR + set magfilter GL_LINEAR + set swrap GL_REPEAT + set twrap GL_REPEAT + set envmode GL_MODULATE + set teximage CHECKER + set poly_red 255 + set poly_green 255 + set poly_blue 255 + set coord_scale 1.0 + + set xangle 0.0 + set yangle 0.0 + set scale 1.0 +} + + +# Execution starts here! +setup + diff --git a/Togl/src/Togl/tkFont.h b/Togl/src/Togl/tkFont.h new file mode 100644 index 0000000..ef6336c --- /dev/null +++ b/Togl/src/Togl/tkFont.h @@ -0,0 +1,226 @@ +/* + * tkFont.h -- + * + * Declarations for interfaces between the generic and platform-specific + * parts of the font package. This information is not visible outside of + * the font package. + * + * Copyright (c) 1996-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef _TKFONT +#define _TKFONT + +#ifdef BUILD_tk +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT +#endif + +/* + * The following structure keeps track of the attributes of a font. It can be + * used to keep track of either the desired attributes or the actual + * attributes gotten when the font was instantiated. + */ + +struct TkFontAttributes { + Tk_Uid family; /* Font family, or NULL to represent plaform- + * specific default system font. */ + int size; /* Pointsize of font, 0 for default size, or + * negative number meaning pixel size. */ + int weight; /* Weight flag; see below for def'n. */ + int slant; /* Slant flag; see below for def'n. */ + int underline; /* Non-zero for underline font. */ + int overstrike; /* Non-zero for overstrike font. */ +}; + +/* + * Possible values for the "weight" field in a TkFontAttributes structure. + * Weight is a subjective term and depends on what the company that created + * the font considers bold. + */ + +#define TK_FW_NORMAL 0 +#define TK_FW_BOLD 1 + +#define TK_FW_UNKNOWN -1 /* Unknown weight. This value is used for + * error checking and is never actually stored + * in the weight field. */ + +/* + * Possible values for the "slant" field in a TkFontAttributes structure. + */ + +#define TK_FS_ROMAN 0 +#define TK_FS_ITALIC 1 +#define TK_FS_OBLIQUE 2 /* This value is only used when parsing X font + * names to determine the closest match. It is + * only stored in the XLFDAttributes + * structure, never in the slant field of the + * TkFontAttributes. */ + +#define TK_FS_UNKNOWN -1 /* Unknown slant. This value is used for error + * checking and is never actually stored in + * the slant field. */ + +/* + * The following structure keeps track of the metrics for an instantiated + * font. The metrics are the physical properties of the font itself. + */ + +typedef struct TkFontMetrics { + int ascent; /* From baseline to top of font. */ + int descent; /* From baseline to bottom of font. */ + int maxWidth; /* Width of widest character in font. */ + int fixed; /* Non-zero if this is a fixed-width font, + * 0 otherwise. */ +} TkFontMetrics; + +/* + * The following structure is used to keep track of the generic information + * about a font. Each platform-specific font is represented by a structure + * with the following structure at its beginning, plus any platform-specific + * stuff after that. + */ + +typedef struct TkFont { + /* + * Fields used and maintained exclusively by generic code. + */ + + int resourceRefCount; /* Number of active uses of this font (each + * active use corresponds to a call to + * Tk_AllocFontFromTable or Tk_GetFont). If + * this count is 0, then this TkFont structure + * is no longer valid and it isn't present in + * a hash table: it is being kept around only + * because there are objects referring to it. + * The structure is freed when + * resourceRefCount and objRefCount are both + * 0. */ + int objRefCount; /* The number of Tcl objects that reference + * this structure. */ + Tcl_HashEntry *cacheHashPtr;/* Entry in font cache for this structure, + * used when deleting it. */ + Tcl_HashEntry *namedHashPtr;/* Pointer to hash table entry that + * corresponds to the named font that the + * tkfont was based on, or NULL if the tkfont + * was not based on a named font. */ + Screen *screen; /* The screen where this font is valid. */ + int tabWidth; /* Width of tabs in this font (pixels). */ + int underlinePos; /* Offset from baseline to origin of underline + * bar (used for drawing underlines on a + * non-underlined font). */ + int underlineHeight; /* Height of underline bar (used for drawing + * underlines on a non-underlined font). */ + + /* + * Fields used in the generic code that are filled in by + * platform-specific code. + */ + + Font fid; /* For backwards compatibility with XGCValues + * structures. Remove when TkGCValues is + * implemented. */ + TkFontAttributes fa; /* Actual font attributes obtained when the + * the font was created, as opposed to the + * desired attributes passed in to + * TkpGetFontFromAttributes(). The desired + * metrics can be determined from the string + * that was used to create this font. */ + TkFontMetrics fm; /* Font metrics determined when font was + * created. */ + struct TkFont *nextPtr; /* Points to the next TkFont structure with + * the same name. All fonts with the same name + * (but different displays) are chained + * together off a single entry in a hash + * table. */ +} TkFont; + +/* + * The following structure is used to return attributes when parsing an XLFD. + * The extra information is of interest to the Unix-specific code when + * attempting to find the closest matching font. + */ + +typedef struct TkXLFDAttributes { + Tk_Uid foundry; /* The foundry of the font. */ + int slant; /* The tristate value for the slant, which is + * significant under X. */ + int setwidth; /* The proportionate width, see below for + * definition. */ + Tk_Uid charset; /* The actual charset string. */ +} TkXLFDAttributes; + +/* + * Possible values for the "setwidth" field in a TkXLFDAttributes structure. + * The setwidth is whether characters are considered wider or narrower than + * normal. + */ + +#define TK_SW_NORMAL 0 +#define TK_SW_CONDENSE 1 +#define TK_SW_EXPAND 2 +#define TK_SW_UNKNOWN 3 /* Unknown setwidth. This value may be stored + * in the setwidth field. */ + +/* + * The following defines specify the meaning of the fields in a fully + * qualified XLFD. + */ + +#define XLFD_FOUNDRY 0 +#define XLFD_FAMILY 1 +#define XLFD_WEIGHT 2 +#define XLFD_SLANT 3 +#define XLFD_SETWIDTH 4 +#define XLFD_ADD_STYLE 5 +#define XLFD_PIXEL_SIZE 6 +#define XLFD_POINT_SIZE 7 +#define XLFD_RESOLUTION_X 8 +#define XLFD_RESOLUTION_Y 9 +#define XLFD_SPACING 10 +#define XLFD_AVERAGE_WIDTH 11 +#define XLFD_CHARSET 12 +#define XLFD_NUMFIELDS 13 /* Number of fields in XLFD. */ + +/* + * Low-level API exported by generic code to platform-specific code. + */ + +#define TkInitFontAttributes(fa) memset((fa), 0, sizeof(TkFontAttributes)); +#define TkInitXLFDAttributes(xa) memset((xa), 0, sizeof(TkXLFDAttributes)); + +MODULE_SCOPE int TkFontParseXLFD(CONST char *string, + TkFontAttributes *faPtr, TkXLFDAttributes *xaPtr); +MODULE_SCOPE char ** TkFontGetAliasList(CONST char *faceName); +MODULE_SCOPE char *** TkFontGetFallbacks(void); +MODULE_SCOPE int TkFontGetPixels(Tk_Window tkwin, int size); +MODULE_SCOPE int TkFontGetPoints(Tk_Window tkwin, int size); +MODULE_SCOPE char ** TkFontGetGlobalClass(void); +MODULE_SCOPE char ** TkFontGetSymbolClass(void); +MODULE_SCOPE int TkCreateNamedFont(Tcl_Interp *interp, Tk_Window tkwin, + CONST char *name, TkFontAttributes *faPtr); +MODULE_SCOPE int TkDeleteNamedFont(Tcl_Interp *interp, + Tk_Window tkwin, CONST char *name); +MODULE_SCOPE int TkFontGetFirstTextLayout(Tk_TextLayout layout, + Tk_Font *font, char *dst); + +/* + * Low-level API exported by platform-specific code to generic code. + */ + +MODULE_SCOPE void TkpDeleteFont(TkFont *tkFontPtr); +MODULE_SCOPE void TkpFontPkgInit(TkMainInfo *mainPtr); +MODULE_SCOPE TkFont * TkpGetFontFromAttributes(TkFont *tkFontPtr, + Tk_Window tkwin, CONST TkFontAttributes *faPtr); +MODULE_SCOPE void TkpGetFontFamilies(Tcl_Interp *interp, + Tk_Window tkwin); +MODULE_SCOPE TkFont * TkpGetNativeFont(Tk_Window tkwin, CONST char *name); + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT + +#endif /* _TKFONT */ diff --git a/Togl/src/Togl/togl.c b/Togl/src/Togl/togl.c new file mode 100644 index 0000000..0b71b99 --- /dev/null +++ b/Togl/src/Togl/togl.c @@ -0,0 +1,4034 @@ +/* $Id: togl.c,v 1.73 2005/10/26 07:40:22 gregcouch Exp $ */ + +/* vi:set sw=4: */ + +/* + * Togl - a Tk OpenGL widget + * + * Copyright (C) 1996-2002 Brian Paul and Ben Bederson + * See the LICENSE file for copyright details. + */ + +/* + * Currently we support X11, Win32 and Macintosh only + */ + +#include "togl.h" + +/* Use TCL_STUPID to cast (const char *) to (char *) where the Tcl function + * prototype argument should really be const */ +#define TCL_STUPID (char *) + +/* Use WIDGREC to cast widgRec arguments */ +#define WIDGREC (char *) + +/*** Windows headers ***/ +#if defined(TOGL_WGL) +# define WIN32_LEAN_AND_MEAN +# include +# undef WIN32_LEAN_AND_MEAN +# include + +/*** X Window System headers ***/ +#elif defined(TOGL_X11) +# include +# include +# include /* for XA_RGB_DEFAULT_MAP atom */ +# if defined(__vms) +# include /* for XmuLookupStandardColormap */ +# else +# include /* for XmuLookupStandardColormap */ +# endif +# include + +/*** Mac headers ***/ +#elif defined(TOGL_AGL_CLASSIC) +# include +# include +# include +# include + +#elif defined(TOGL_AGL) +# define Cursor QDCursor +# include +# undef Cursor +# define _TKINTXLIBDECLS /* Avoid using tkIntXlibDecls.h */ +# include "tkMacOSX.h" +# include /* usa MacDrawable */ +# include + +#else /* make sure only one platform defined */ +# error Unsupported platform, or confused platform defines... +#endif + +/*** Standard C headers ***/ +#include +#include +#include + +#ifdef TOGL_WGL +# include +#endif + +#if TK_MAJOR_VERSION < 8 +# error Sorry Togl requires Tcl/Tk ver 8.0 or higher. +#endif + +#if defined(TOGL_AGL_CLASSIC) +# if TK_MAJOR_VERSION < 8 || (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION < 3) +# error Sorry Mac classic version requires Tcl/Tk ver 8.3.0 or higher. +# endif +#endif /* TOGL_AGL_CLASSIC */ + +#if defined(TOGL_AGL) +# if TK_MAJOR_VERSION < 8 || (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION < 4) +# error Sorry Mac Aqua version requires Tcl/Tk ver 8.4.0 or higher. +# endif +#endif /* TOGL_AGL */ + +/* workaround for bug #123153 in tcl ver8.4a2 (tcl.h) */ +#if defined(Tcl_InitHashTable) && defined(USE_TCL_STUBS) +# undef Tcl_InitHashTable +# define Tcl_InitHashTable (tclStubsPtr->tcl_InitHashTable) +#endif +#if TK_MAJOR_VERSION > 8 || (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 4) +# define HAVE_TK_SETCLASSPROCS +/* pointer to Tk_SetClassProcs function in the stub table */ + +static void (*SetClassProcsPtr) + _ANSI_ARGS_((Tk_Window, Tk_ClassProcs *, ClientData)); +#endif + +/* + * Copy of TkClassProcs declarations form tkInt.h + * (this is needed for Tcl ver =< 8.4a3) + */ + +typedef Window (TkClassCreateProc) _ANSI_ARGS_((Tk_Window tkwin, + Window parent, ClientData instanceData)); +typedef void (TkClassGeometryProc) _ANSI_ARGS_((ClientData instanceData)); +typedef void (TkClassModalProc) _ANSI_ARGS_((Tk_Window tkwin, + XEvent *eventPtr)); +typedef struct TkClassProcs +{ + TkClassCreateProc *createProc; + TkClassGeometryProc *geometryProc; + TkClassModalProc *modalProc; +} TkClassProcs; + + +/* Defaults */ +#define DEFAULT_WIDTH "400" +#define DEFAULT_HEIGHT "400" +#define DEFAULT_IDENT "" +#define DEFAULT_FONTNAME "fixed" +#define DEFAULT_TIME "1" + + +#ifdef TOGL_WGL +/* Maximum size of a logical palette corresponding to a colormap in color index + * mode. */ +# define MAX_CI_COLORMAP_SIZE 4096 + +# if TOGL_USE_FONTS != 1 +/* + * copy of TkWinColormap from tkWinInt.h + */ + +typedef struct +{ + HPALETTE palette; /* Palette handle used when drawing. */ + UINT size; /* Number of entries in the palette. */ + int stale; /* 1 if palette needs to be realized, otherwise + * 0. If the palette is stale, then an idle + * handler is scheduled to realize the palette. */ + Tcl_HashTable refCounts; /* Hash table of palette entry reference counts + * indexed by pixel value. */ +} TkWinColormap; +# else +# include "tkWinInt.h" +# endif + +static LRESULT(CALLBACK *tkWinChildProc) (HWND hwnd, UINT message, + WPARAM wParam, LPARAM lParam) = NULL; + +# define TK_WIN_CHILD_CLASS_NAME "TkChild" + +#endif /* TOGL_WGL */ + + +#define MAX(a,b) (((a)>(b))?(a):(b)) + +#define TCL_ERR(interp, string) \ + do { \ + Tcl_ResetResult(interp); \ + Tcl_AppendResult(interp, string, NULL); \ + return TCL_ERROR; \ + } while (0) + +/* The constant DUMMY_WINDOW is used to signal window creation failure from the + * Togl_CreateWindow() */ +#define DUMMY_WINDOW ((Window) -1) + +#define ALL_EVENTS_MASK \ + (KeyPressMask | \ + KeyReleaseMask | \ + ButtonPressMask | \ + ButtonReleaseMask | \ + EnterWindowMask | \ + LeaveWindowMask | \ + PointerMotionMask | \ + ExposureMask | \ + VisibilityChangeMask | \ + FocusChangeMask | \ + PropertyChangeMask | \ + ColormapChangeMask) + +struct Togl +{ + Togl *Next; /* next in linked list */ + +#if defined(TOGL_WGL) + HDC tglGLHdc; /* Device context of device that OpenGL calls + * will be drawn on */ + HGLRC tglGLHglrc; /* OpenGL rendering context to be made current */ + int CiColormapSize; /* (Maximum) size of colormap in color index + * mode */ +#elif defined(TOGL_X11) + GLXContext GlCtx; /* Normal planes GLX context */ +#elif defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + AGLContext aglCtx; +#endif /* TOGL_WGL */ + + Display *display; /* X's token for the window's display. */ + Tk_Window TkWin; /* Tk window structure */ + Tcl_Interp *Interp; /* Tcl interpreter */ + Tcl_Command widgetCmd; /* Token for togl's widget command */ +#ifndef NO_TK_CURSOR + Tk_Cursor Cursor; /* The widget's cursor */ +#endif + int Width, Height; /* Dimensions of window */ + int SetGrid; /* positive is grid size for window manager */ + int TimerInterval; /* Time interval for timer in milliseconds */ +#if (TCL_MAJOR_VERSION * 100 + TCL_MINOR_VERSION) >= 705 + Tcl_TimerToken timerHandler; /* Token for togl's timer handler */ +#else + Tk_TimerToken timerHandler; /* Token for togl's timer handler */ +#endif + Bool RgbaFlag; /* configuration flags (ala GLX parameters) */ + int RgbaRed; + int RgbaGreen; + int RgbaBlue; + Bool DoubleFlag; + Bool DepthFlag; + int DepthSize; + Bool AccumFlag; + int AccumRed; + int AccumGreen; + int AccumBlue; + int AccumAlpha; + Bool AlphaFlag; + int AlphaSize; + Bool StencilFlag; + int StencilSize; + Bool PrivateCmapFlag; + Bool OverlayFlag; + Bool StereoFlag; +#ifdef __sgi + Bool OldStereoFlag; +#endif + int AuxNumber; + Bool Indirect; + int PixelFormat; + const char *ShareList; /* name (ident) of Togl to share dlists with */ + const char *ShareContext; /* name (ident) to share OpenGL context with */ + + const char *Ident; /* User's identification string */ + ClientData Client_Data; /* Pointer to user data */ + + Bool UpdatePending; /* Should normal planes be redrawn? */ + + Togl_Callback *CreateProc; /* Callback when widget is created */ + Togl_Callback *DisplayProc; /* Callback when widget is rendered */ + Togl_Callback *ReshapeProc; /* Callback when window size changes */ + Togl_Callback *DestroyProc; /* Callback when widget is destroyed */ + Togl_Callback *TimerProc; /* Callback when widget is idle */ + + /* Overlay stuff */ +#if defined(TOGL_X11) + GLXContext OverlayCtx; /* Overlay planes OpenGL context */ +#elif defined(TOGL_WGL) + HGLRC tglGLOverlayHglrc; +#endif /* TOGL_X11 */ + + Window OverlayWindow; /* The overlay window, or 0 */ + Togl_Callback *OverlayDisplayProc; /* Overlay redraw proc */ + Bool OverlayUpdatePending; /* Should overlay be redrawn? */ + Colormap OverlayCmap; /* colormap for overlay is created */ + int OverlayTransparentPixel; /* transparent pixel */ + Bool OverlayIsMapped; + + /* for DumpToEpsFile: Added by Miguel A. de Riera Pasenau 10.01.1997 */ + XVisualInfo *VisInfo; /* Visual info of the current */ + /* context needed for DumpToEpsFile */ + GLfloat *EpsRedMap; /* Index2RGB Maps for Color index modes */ + GLfloat *EpsGreenMap; + GLfloat *EpsBlueMap; + GLint EpsMapSize; /* = Number of indices in our Togl */ +}; + + +/* NTNTNT need to change to handle Windows Data Types */ +/* + * Prototypes for functions local to this file + */ +static int Togl_Cmd(ClientData clientData, Tcl_Interp *interp, + int argc, CONST84 char **argv); +static void Togl_EventProc(ClientData clientData, XEvent *eventPtr); +static Window Togl_CreateWindow(Tk_Window, Window, ClientData); +static void Togl_WorldChanged(ClientData); + +#ifdef MESA_COLOR_HACK +static int get_free_color_cells(Display *display, int screen, + Colormap colormap); +static void free_default_color_cells(Display *display, Colormap colormap); +#endif +static void ToglCmdDeletedProc(ClientData); + + + +#if defined(__sgi) +/* SGI-only stereo */ +static void oldStereoMakeCurrent(Display *dpy, Window win, GLXContext ctx); +static void oldStereoInit(Togl *togl, int stereoEnabled); +#endif + +#if defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) +static void SetMacBufRect(Togl *togl); +#endif + + +/* + * Setup Togl widget configuration options: + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_PIXELS, TCL_STUPID "-height", "height", "Height", + DEFAULT_HEIGHT, Tk_Offset(Togl, Height), 0, NULL}, + + {TK_CONFIG_PIXELS, TCL_STUPID "-width", "width", "Width", + DEFAULT_WIDTH, Tk_Offset(Togl, Width), 0, NULL}, + + {TK_CONFIG_INT, TCL_STUPID "-setgrid", "setGrid", "SetGrid", + "0", Tk_Offset(Togl, SetGrid), 0}, + + {TK_CONFIG_BOOLEAN, TCL_STUPID "-rgba", "rgba", "Rgba", + "true", Tk_Offset(Togl, RgbaFlag), 0, NULL}, + + {TK_CONFIG_INT, TCL_STUPID "-redsize", "redsize", "RedSize", + "1", Tk_Offset(Togl, RgbaRed), 0, NULL}, + + {TK_CONFIG_INT, TCL_STUPID "-greensize", "greensize", "GreenSize", + "1", Tk_Offset(Togl, RgbaGreen), 0, NULL}, + + {TK_CONFIG_INT, TCL_STUPID "-bluesize", "bluesize", "BlueSize", + "1", Tk_Offset(Togl, RgbaBlue), 0, NULL}, + + {TK_CONFIG_BOOLEAN, TCL_STUPID "-double", "double", "Double", + "false", Tk_Offset(Togl, DoubleFlag), 0, NULL}, + + {TK_CONFIG_BOOLEAN, TCL_STUPID "-depth", "depth", "Depth", + "false", Tk_Offset(Togl, DepthFlag), 0, NULL}, + + {TK_CONFIG_INT, TCL_STUPID "-depthsize", "depthsize", "DepthSize", + "1", Tk_Offset(Togl, DepthSize), 0, NULL}, + + {TK_CONFIG_BOOLEAN, TCL_STUPID "-accum", "accum", "Accum", + "false", Tk_Offset(Togl, AccumFlag), 0, NULL}, + + {TK_CONFIG_INT, TCL_STUPID "-accumredsize", "accumredsize", "AccumRedSize", + "1", Tk_Offset(Togl, AccumRed), 0, NULL}, + + {TK_CONFIG_INT, TCL_STUPID "-accumgreensize", "accumgreensize", + "AccumGreenSize", + "1", Tk_Offset(Togl, AccumGreen), 0, NULL}, + + {TK_CONFIG_INT, TCL_STUPID "-accumbluesize", "accumbluesize", + "AccumBlueSize", + "1", Tk_Offset(Togl, AccumBlue), 0, NULL}, + + {TK_CONFIG_INT, TCL_STUPID "-accumalphasize", "accumalphasize", + "AccumAlphaSize", + "1", Tk_Offset(Togl, AccumAlpha), 0, NULL}, + + {TK_CONFIG_BOOLEAN, TCL_STUPID "-alpha", "alpha", "Alpha", + "false", Tk_Offset(Togl, AlphaFlag), 0, NULL}, + + {TK_CONFIG_INT, TCL_STUPID "-alphasize", "alphasize", "AlphaSize", + "1", Tk_Offset(Togl, AlphaSize), 0, NULL}, + + {TK_CONFIG_BOOLEAN, TCL_STUPID "-stencil", "stencil", "Stencil", + "false", Tk_Offset(Togl, StencilFlag), 0, NULL}, + + {TK_CONFIG_INT, TCL_STUPID "-stencilsize", "stencilsize", "StencilSize", + "1", Tk_Offset(Togl, StencilSize), 0, NULL}, + + {TK_CONFIG_INT, TCL_STUPID "-auxbuffers", "auxbuffers", "AuxBuffers", + "0", Tk_Offset(Togl, AuxNumber), 0, NULL}, + + {TK_CONFIG_BOOLEAN, TCL_STUPID "-privatecmap", "privateCmap", "PrivateCmap", + "false", Tk_Offset(Togl, PrivateCmapFlag), 0, NULL}, + + {TK_CONFIG_BOOLEAN, TCL_STUPID "-overlay", "overlay", "Overlay", + "false", Tk_Offset(Togl, OverlayFlag), 0, NULL}, + + {TK_CONFIG_BOOLEAN, TCL_STUPID "-stereo", "stereo", "Stereo", + "false", Tk_Offset(Togl, StereoFlag), 0, NULL}, + +#ifdef __sgi + {TK_CONFIG_BOOLEAN, TCL_STUPID "-oldstereo", "oldstereo", "OldStereo", + "false", Tk_Offset(Togl, OldStereoFlag), 0, NULL}, +#endif + +#ifndef NO_TK_CURSOR + {TK_CONFIG_ACTIVE_CURSOR, TCL_STUPID "-cursor", "cursor", "Cursor", + "", Tk_Offset(Togl, Cursor), TK_CONFIG_NULL_OK}, +#endif + + {TK_CONFIG_INT, TCL_STUPID "-time", "time", "Time", + DEFAULT_TIME, Tk_Offset(Togl, TimerInterval), 0, NULL}, + + {TK_CONFIG_STRING, TCL_STUPID "-sharelist", "sharelist", "ShareList", + NULL, Tk_Offset(Togl, ShareList), 0, NULL}, + + {TK_CONFIG_STRING, TCL_STUPID "-sharecontext", "sharecontext", + "ShareContext", NULL, Tk_Offset(Togl, ShareContext), 0, NULL}, + + {TK_CONFIG_STRING, TCL_STUPID "-ident", "ident", "Ident", + DEFAULT_IDENT, Tk_Offset(Togl, Ident), 0, NULL}, + + {TK_CONFIG_BOOLEAN, TCL_STUPID "-indirect", "indirect", "Indirect", + "false", Tk_Offset(Togl, Indirect), 0, NULL}, + + {TK_CONFIG_INT, TCL_STUPID "-pixelformat", "pixelFormat", "PixelFormat", + "0", Tk_Offset(Togl, PixelFormat), 0, NULL}, + + {TK_CONFIG_END, NULL, NULL, NULL, NULL, 0, 0, NULL} +}; + + +/* + * Default callback pointers. When a new Togl widget is created it + * will be assigned these initial callbacks. + */ +static Togl_Callback *DefaultCreateProc = NULL; +static Togl_Callback *DefaultDisplayProc = NULL; +static Togl_Callback *DefaultReshapeProc = NULL; +static Togl_Callback *DefaultDestroyProc = NULL; +static Togl_Callback *DefaultOverlayDisplayProc = NULL; +static Togl_Callback *DefaultTimerProc = NULL; +static ClientData DefaultClientData = NULL; +static Tcl_HashTable CommandTable; + +/* + * Head of linked list of all Togl widgets + */ +static Togl *ToglHead = NULL; + +/* + * Add given togl widget to linked list. + */ +static void +AddToList(Togl *t) +{ + t->Next = ToglHead; + ToglHead = t; +} + +/* + * Remove given togl widget from linked list. + */ +static void +RemoveFromList(Togl *t) +{ + Togl *prev = NULL; + Togl *pos = ToglHead; + + while (pos) { + if (pos == t) { + if (prev) { + prev->Next = pos->Next; + } else { + ToglHead = pos->Next; + } + return; + } + prev = pos; + pos = pos->Next; + } +} + +/* + * Return pointer to togl widget given a user identifier string. + */ +static Togl * +FindTogl(const char *ident) +{ + Togl *t = ToglHead; + + while (t) { + if (strcmp(t->Ident, ident) == 0) + return t; + t = t->Next; + } + return NULL; +} + + +#if defined(TOGL_X11) +/* + * Return pointer to another togl widget with same OpenGL context. + */ +static Togl * +FindToglWithSameContext(Togl *togl) +{ + Togl *t; + + for (t = ToglHead; t != NULL; t = t->Next) { + if (t == togl) + continue; +# if defined(TOGL_WGL) + if (t->tglGLHglrc == togl->tglGLHglrc) +# elif defined(TOGL_X11) + if (t->GlCtx == togl->GlCtx) +# elif defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + if (t->aglCtx == togl->aglCtx) +# endif + return t; + } + return NULL; +} +#endif + +#ifdef USE_OVERLAY +/* + * Return pointer to another togl widget with same OpenGL overlay context. + */ +static Togl * +FindToglWithSameOverlayContext(Togl *togl) +{ + Togl *t; + + for (t = ToglHead; t != NULL; t = t->Next) { + if (t == togl) + continue; +# if defined(TOGL_X11) + if (t->OverlayCtx == togl->OverlayCtx) +# elif defined(TOGL_WGL) + if (t->tglGLOverlayHglrc == togl->tglGLOverlayHglrc) +# endif + return t; + } + return NULL; +} +#endif + +#if defined(TOGL_X11) +/* + * Return an X colormap to use for OpenGL RGB-mode rendering. + * Input: dpy - the X display + * scrnum - the X screen number + * visinfo - the XVisualInfo as returned by glXChooseVisual() + * Return: an X Colormap or 0 if there's a _serious_ error. + */ +static Colormap +get_rgb_colormap(Display *dpy, + int scrnum, const XVisualInfo *visinfo, Tk_Window tkwin) +{ + Atom hp_cr_maps; + Status status; + int numCmaps; + int i; + XStandardColormap *standardCmaps; + Window root = XRootWindow(dpy, scrnum); + Bool using_mesa; + + /* + * First check if visinfo's visual matches the default/root visual. + */ + if (visinfo->visual == Tk_Visual(tkwin)) { + /* use the default/root colormap */ + Colormap cmap; + + cmap = Tk_Colormap(tkwin); +# ifdef MESA_COLOR_HACK + (void) get_free_color_cells(dpy, scrnum, cmap); +# endif + return cmap; + } + + /* + * Check if we're using Mesa. + */ + if (strstr(glXQueryServerString(dpy, scrnum, GLX_VERSION), "Mesa")) { + using_mesa = True; + } else { + using_mesa = False; + } + + /* + * Next, if we're using Mesa and displaying on an HP with the "Color + * Recovery" feature and the visual is 8-bit TrueColor, search for a + * special colormap initialized for dithering. Mesa will know how to + * dither using this colormap. + */ + if (using_mesa) { + hp_cr_maps = XInternAtom(dpy, "_HP_RGB_SMOOTH_MAP_LIST", True); + if (hp_cr_maps +# ifdef __cplusplus + && visinfo->visual->c_class == TrueColor +# else + && visinfo->visual->class == TrueColor +# endif + && visinfo->depth == 8) { + status = XGetRGBColormaps(dpy, root, &standardCmaps, + &numCmaps, hp_cr_maps); + if (status) { + for (i = 0; i < numCmaps; i++) { + if (standardCmaps[i].visualid == visinfo->visual->visualid) { + Colormap cmap = standardCmaps[i].colormap; + + (void) XFree(standardCmaps); + return cmap; + } + } + (void) XFree(standardCmaps); + } + } + } + + /* + * Next, try to find a standard X colormap. + */ +# if !HP && !SUN +# ifndef SOLARIS_BUG + status = XmuLookupStandardColormap(dpy, visinfo->screen, + visinfo->visualid, visinfo->depth, XA_RGB_DEFAULT_MAP, + /* replace */ False, /* retain */ True); + if (status == 1) { + status = XGetRGBColormaps(dpy, root, &standardCmaps, + &numCmaps, XA_RGB_DEFAULT_MAP); + if (status == 1) { + for (i = 0; i < numCmaps; i++) { + if (standardCmaps[i].visualid == visinfo->visualid) { + Colormap cmap = standardCmaps[i].colormap; + + (void) XFree(standardCmaps); + return cmap; + } + } + (void) XFree(standardCmaps); + } + } +# endif +# endif + + /* + * If we get here, give up and just allocate a new colormap. + */ + return XCreateColormap(dpy, root, visinfo->visual, AllocNone); +} +#elif defined(TOGL_WGL) + +/* Code to create RGB palette is taken from the GENGL sample program of Win32 + * SDK */ + +static unsigned char threeto8[8] = { + 0, 0111 >> 1, 0222 >> 1, 0333 >> 1, 0444 >> 1, 0555 >> 1, 0666 >> 1, 0377 +}; + +static unsigned char twoto8[4] = { + 0, 0x55, 0xaa, 0xff +}; + +static unsigned char oneto8[2] = { + 0, 255 +}; + +static int defaultOverride[13] = { + 0, 3, 24, 27, 64, 67, 88, 173, 181, 236, 247, 164, 91 +}; + +static PALETTEENTRY defaultPalEntry[20] = { + {0, 0, 0, 0}, + {0x80, 0, 0, 0}, + {0, 0x80, 0, 0}, + {0x80, 0x80, 0, 0}, + {0, 0, 0x80, 0}, + {0x80, 0, 0x80, 0}, + {0, 0x80, 0x80, 0}, + {0xC0, 0xC0, 0xC0, 0}, + + {192, 220, 192, 0}, + {166, 202, 240, 0}, + {255, 251, 240, 0}, + {160, 160, 164, 0}, + + {0x80, 0x80, 0x80, 0}, + {0xFF, 0, 0, 0}, + {0, 0xFF, 0, 0}, + {0xFF, 0xFF, 0, 0}, + {0, 0, 0xFF, 0}, + {0xFF, 0, 0xFF, 0}, + {0, 0xFF, 0xFF, 0}, + {0xFF, 0xFF, 0xFF, 0} +}; + +static unsigned char +ComponentFromIndex(int i, UINT nbits, UINT shift) +{ + unsigned char val; + + val = (unsigned char) (i >> shift); + switch (nbits) { + + case 1: + val &= 0x1; + return oneto8[val]; + + case 2: + val &= 0x3; + return twoto8[val]; + + case 3: + val &= 0x7; + return threeto8[val]; + + default: + return 0; + } +} + +static Colormap +Win32CreateRgbColormap(PIXELFORMATDESCRIPTOR pfd) +{ + TkWinColormap *cmap = (TkWinColormap *) ckalloc(sizeof (TkWinColormap)); + LOGPALETTE *pPal; + int n, i; + + n = 1 << pfd.cColorBits; + pPal = (PLOGPALETTE) LocalAlloc(LMEM_FIXED, sizeof (LOGPALETTE) + + n * sizeof (PALETTEENTRY)); + pPal->palVersion = 0x300; + pPal->palNumEntries = n; + for (i = 0; i < n; i++) { + pPal->palPalEntry[i].peRed = + ComponentFromIndex(i, pfd.cRedBits, pfd.cRedShift); + pPal->palPalEntry[i].peGreen = + ComponentFromIndex(i, pfd.cGreenBits, pfd.cGreenShift); + pPal->palPalEntry[i].peBlue = + ComponentFromIndex(i, pfd.cBlueBits, pfd.cBlueShift); + pPal->palPalEntry[i].peFlags = 0; + } + + /* fix up the palette to include the default GDI palette */ + if ((pfd.cColorBits == 8) + && (pfd.cRedBits == 3) && (pfd.cRedShift == 0) + && (pfd.cGreenBits == 3) && (pfd.cGreenShift == 3) + && (pfd.cBlueBits == 2) && (pfd.cBlueShift == 6)) { + for (i = 1; i <= 12; i++) + pPal->palPalEntry[defaultOverride[i]] = defaultPalEntry[i]; + } + + cmap->palette = CreatePalette(pPal); + LocalFree(pPal); + cmap->size = n; + cmap->stale = 0; + + /* Since this is a private colormap of a fix size, we do not need a valid + * hash table, but a dummy one */ + + Tcl_InitHashTable(&cmap->refCounts, TCL_ONE_WORD_KEYS); + return (Colormap) cmap; +} + +static Colormap +Win32CreateCiColormap(Togl *togl) +{ + /* Create a colormap with size of togl->CiColormapSize and set all entries + * to black */ + + LOGPALETTE logPalette; + TkWinColormap *cmap = (TkWinColormap *) ckalloc(sizeof (TkWinColormap)); + + logPalette.palVersion = 0x300; + logPalette.palNumEntries = 1; + logPalette.palPalEntry[0].peRed = 0; + logPalette.palPalEntry[0].peGreen = 0; + logPalette.palPalEntry[0].peBlue = 0; + logPalette.palPalEntry[0].peFlags = 0; + + cmap->palette = CreatePalette(&logPalette); + cmap->size = togl->CiColormapSize; + ResizePalette(cmap->palette, cmap->size); /* sets new entries to black */ + cmap->stale = 0; + + /* Since this is a private colormap of a fix size, we do not need a valid + * hash table, but a dummy one */ + + Tcl_InitHashTable(&cmap->refCounts, TCL_ONE_WORD_KEYS); + return (Colormap) cmap; +} +#endif /* TOGL_X11 */ + + + +/* + * Togl_Init + * + * Called upon system startup to create Togl command. + */ +int +Togl_Init(Tcl_Interp *interp) +{ + int major, minor, patchLevel, releaseType; + +#ifdef USE_TCL_STUBS + if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif +#ifdef USE_TK_STUBS + if (Tk_InitStubs(interp, TCL_STUPID "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif + + /* Skip all this on Tcl/Tk 8.0 or older. Seems to work */ +#if TCL_MAJOR_VERSION * 100 + TCL_MINOR_VERSION > 800 + Tcl_GetVersion(&major, &minor, &patchLevel, &releaseType); + +# ifdef HAVE_TK_SETCLASSPROCS + if (major > 8 + || (major == 8 + && (minor > 4 + || (minor == 4 && (releaseType > 0 + || patchLevel >= 2))))) { +# ifdef USE_TK_STUBS + SetClassProcsPtr = tkStubsPtr->tk_SetClassProcs; +# else + SetClassProcsPtr = Tk_SetClassProcs; +# endif + } else { + SetClassProcsPtr = NULL; + } +# else + if (major > 8 + || (major == 8 + && (minor > 4 + || (minor == 4 && (releaseType > 0 + || patchLevel >= 2))))) { + TCL_ERR(interp, + "Sorry, this instance of Togl was not compiled to work with Tcl/Tk 8.4a2 or higher."); + } +# endif + +#endif + + if (Tcl_PkgProvide(interp, "Togl", TOGL_VERSION) != TCL_OK) { + return TCL_ERROR; + } + + if (Tcl_CreateCommand(interp, "togl", Togl_Cmd, + (ClientData) Tk_MainWindow(interp), NULL) == NULL) + return TCL_ERROR; + + Tcl_InitHashTable(&CommandTable, TCL_STRING_KEYS); + + return TCL_OK; +} + + +/* + * Register a C function to be called when an Togl widget is realized. + */ +void +Togl_CreateFunc(Togl_Callback *proc) +{ + DefaultCreateProc = proc; +} + + +/* + * Register a C function to be called when an Togl widget must be redrawn. + */ +void +Togl_DisplayFunc(Togl_Callback *proc) +{ + DefaultDisplayProc = proc; +} + + +/* + * Register a C function to be called when an Togl widget is resized. + */ +void +Togl_ReshapeFunc(Togl_Callback *proc) +{ + DefaultReshapeProc = proc; +} + + +/* + * Register a C function to be called when an Togl widget is destroyed. + */ +void +Togl_DestroyFunc(Togl_Callback *proc) +{ + DefaultDestroyProc = proc; +} + + +/* + * Register a C function to be called from TimerEventHandler. + */ +void +Togl_TimerFunc(Togl_Callback *proc) +{ + DefaultTimerProc = proc; +} + + +/* + * Reset default callback pointers to NULL. + */ +void +Togl_ResetDefaultCallbacks(void) +{ + DefaultCreateProc = NULL; + DefaultDisplayProc = NULL; + DefaultReshapeProc = NULL; + DefaultDestroyProc = NULL; + DefaultOverlayDisplayProc = NULL; + DefaultTimerProc = NULL; + DefaultClientData = NULL; +} + + +/* + * Chnage the create callback for a specific Togl widget. + */ +void +Togl_SetCreateFunc(Togl *togl, Togl_Callback *proc) +{ + togl->CreateProc = proc; +} + + +/* + * Change the display/redraw callback for a specific Togl widget. + */ +void +Togl_SetDisplayFunc(Togl *togl, Togl_Callback *proc) +{ + togl->DisplayProc = proc; +} + + +/* + * Change the reshape callback for a specific Togl widget. + */ +void +Togl_SetReshapeFunc(Togl *togl, Togl_Callback *proc) +{ + togl->ReshapeProc = proc; +} + + +/* + * Change the destroy callback for a specific Togl widget. + */ +void +Togl_SetDestroyFunc(Togl *togl, Togl_Callback *proc) +{ + togl->DestroyProc = proc; +} + + +/* + * Togl_Timer + * + * Gets called from Tk_CreateTimerHandler. + */ +static void +Togl_Timer(ClientData clientData) +{ + Togl *togl = (Togl *) clientData; + + if (togl->TimerProc) { + togl->TimerProc(togl); + + /* Re-register this callback since Tcl/Tk timers are "one-shot". That + * is, after the timer callback is called it not normally called again. + * * * * * * * * * That's not the behavior we want for Togl. */ +#if (TK_MAJOR_VERSION * 100 + TK_MINOR_VERSION) >= 401 + togl->timerHandler = + Tcl_CreateTimerHandler(togl->TimerInterval, Togl_Timer, + (ClientData) togl); +#else + togl->timerHandler = + Tk_CreateTimerHandler(togl->TimeInterval, Togl_Timer, + (ClientData) togl); +#endif + } +} + + +/* + * Change the timer callback for a specific Togl widget. + * Pass NULL to disable the callback. + */ +void +Togl_SetTimerFunc(Togl *togl, Togl_Callback *proc) +{ + togl->TimerProc = proc; + if (proc) { +#if (TK_MAJOR_VERSION * 100 + TK_MINOR_VERSION) >= 401 + togl->timerHandler = + Tcl_CreateTimerHandler(togl->TimerInterval, Togl_Timer, + (ClientData) togl); +#else + togl->timerHandler = + Tk_CreateTimerHandler(togl->TimeInterval, Togl_Timer, + (ClientData) togl); +#endif + } +} + + + +/* + * Togl_CreateCommand + * + * Declares a new C sub-command of Togl callable from Tcl. + * Every time the sub-command is called from Tcl, the + * C routine will be called with all the arguments from Tcl. + */ +void +Togl_CreateCommand(char *cmd_name, Togl_CmdProc *cmd_proc) +{ + int new_item; + Tcl_HashEntry *entry; + + entry = Tcl_CreateHashEntry(&CommandTable, cmd_name, &new_item); + Tcl_SetHashValue(entry, cmd_proc); +} + + +/* + * Togl_MakeCurrent + * + * Bind the OpenGL rendering context to the specified + * Togl widget. + */ +void +Togl_MakeCurrent(const Togl *togl) +{ +#if defined(TOGL_WGL) + int res = wglMakeCurrent(togl->tglGLHdc, togl->tglGLHglrc); + + assert(res == TRUE); + +#elif defined(TOGL_X11) + if (!togl->GlCtx) + return; + (void) glXMakeCurrent(togl->display, + togl->TkWin ? Tk_WindowId(togl->TkWin) : None, togl->GlCtx); +# if defined(__sgi) + if (togl->OldStereoFlag) + oldStereoMakeCurrent(togl->display, + togl->TkWin ? Tk_WindowId(togl->TkWin) : None, togl->GlCtx); + +# endif /*__sgi STEREO */ + +#elif defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + if (!togl->aglCtx) + return; + aglSetCurrentContext(togl->aglCtx); +#endif +} + + +#ifdef TOGL_AGL_CLASSIC +/* tell OpenGL which part of the Mac window to render to */ +static void +SetMacBufRect(Togl *togl) +{ + GLint wrect[4]; + + /* set wrect[0,1] to lower left corner of widget */ + wrect[2] = ((TkWindow *) (togl->TkWin))->changes.width; + wrect[3] = ((TkWindow *) (togl->TkWin))->changes.height; + wrect[0] = ((TkWindow *) (togl->TkWin))->privatePtr->xOff; + wrect[1] = + ((TkWindow *) (togl->TkWin))->privatePtr->toplevel->portPtr-> + portRect.bottom - wrect[3] - + ((TkWindow *) (togl->TkWin))->privatePtr->yOff; + aglSetInteger(togl->aglCtx, AGL_BUFFER_RECT, wrect); + aglEnable(togl->aglCtx, AGL_BUFFER_RECT); + aglUpdateContext(togl->aglCtx); +} +#elif defined(TOGL_AGL) +/* tell OpenGL which part of the Mac window to render to */ +static void +SetMacBufRect(Togl *togl) +{ + GLint wrect[4]; + + /* set wrect[0,1] to lower left corner of widget */ + wrect[2] = Tk_Width(togl->TkWin); + wrect[3] = Tk_Height(togl->TkWin); + wrect[0] = ((TkWindow *) (togl->TkWin))->privatePtr->xOff; + + Rect r; + + GetPortBounds(((TkWindow *) (togl->TkWin))->privatePtr->toplevel->grafPtr, + &r); + + wrect[1] = r.bottom - + wrect[3] - ((TkWindow *) (togl->TkWin))->privatePtr->yOff; + + aglSetInteger(togl->aglCtx, AGL_BUFFER_RECT, wrect); + aglEnable(togl->aglCtx, AGL_BUFFER_RECT); + aglUpdateContext(togl->aglCtx); +} +#endif + +/* + * Called when the widget's contents must be redrawn. Basically, we + * just call the user's render callback function. + * + * Note that the parameter type is ClientData so this function can be + * passed to Tk_DoWhenIdle(). + */ +static void +Togl_Render(ClientData clientData) +{ + Togl *togl = (Togl *) clientData; + + if (togl->DisplayProc) { + +#ifdef TOGL_AGL_CLASSIC + /* Mac is complicated here because OpenGL needs to know what part of + * the parent window to render into, and it seems that region need to + * be invalidated before drawing, so that QuickDraw will allow OpenGL + * to transfer pixels into that part of the window. I'm not even + * totally sure how or why this works as it does, since this aspect of + * Mac OpenGL seems to be totally undocumented. This was put together + * by trial and error! (thiessen) */ + MacRegion r; + RgnPtr rp = &r; + GrafPtr curPort, parentWin; + + parentWin = (GrafPtr) + (((MacDrawable *) (Tk_WindowId(togl->TkWin)))->toplevel-> + portPtr); + if (!parentWin) + return; +#endif + + Togl_MakeCurrent(togl); + +#ifdef TOGL_AGL_CLASSIC + /* Set QuickDraw port and clipping region */ + GetPort(&curPort); + SetPort(parentWin); + r.rgnBBox.left = ((TkWindow *) (togl->TkWin))->privatePtr->xOff; + r.rgnBBox.right = + r.rgnBBox.left + ((TkWindow *) (togl->TkWin))->changes.width - + 1; + r.rgnBBox.top = ((TkWindow *) (togl->TkWin))->privatePtr->yOff; + r.rgnBBox.bottom = + r.rgnBBox.top + ((TkWindow *) (togl->TkWin))->changes.height - + 1; + r.rgnSize = sizeof (Region); + InvalRgn(&rp); + SetClip(&rp); + /* this may seem an odd place to put this, with possibly redundant + * calls to aglSetInteger(AGL_BUFFER_RECT...), but for some reason + * performance is actually a lot better if this is called before every + * render... */ + SetMacBufRect(togl); +#endif + +#ifdef TOGL_AGL + SetMacBufRect(togl); +#endif + + togl->DisplayProc(togl); + +#ifdef TOGL_AGL_CLASSIC + SetPort(curPort); /* restore previous port */ +#endif + + } +#if defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + else { + /* Always need to update on resize */ + SetMacBufRect(togl); + } +#endif + togl->UpdatePending = False; +} + + +static void +RenderOverlay(ClientData clientData) +{ + Togl *togl = (Togl *) clientData; + + if (togl->OverlayFlag && togl->OverlayDisplayProc) { + +#if defined(TOGL_WGL) + int res = wglMakeCurrent(togl->tglGLHdc, togl->tglGLHglrc); + + assert(res == TRUE); + +#elif defined(TOGL_X11) + (void) glXMakeCurrent(Tk_Display(togl->TkWin), + togl->OverlayWindow, togl->OverlayCtx); +# if defined(__sgi) + if (togl->OldStereoFlag) + oldStereoMakeCurrent(Tk_Display(togl->TkWin), + togl->OverlayWindow, togl->OverlayCtx); + +# endif /*__sgi STEREO */ + +#endif /* TOGL_WGL */ + + togl->OverlayDisplayProc(togl); + } + togl->OverlayUpdatePending = False; +} + + +/* + * It's possible to change with this function or in a script some + * options like RGBA - ColorIndex ; Z-buffer and so on + */ +int +Togl_Configure(Tcl_Interp *interp, Togl *togl, + int argc, const char *argv[], int flags) +{ + Bool oldRgbaFlag = togl->RgbaFlag; + int oldRgbaRed = togl->RgbaRed; + int oldRgbaGreen = togl->RgbaGreen; + int oldRgbaBlue = togl->RgbaBlue; + Bool oldDoubleFlag = togl->DoubleFlag; + Bool oldDepthFlag = togl->DepthFlag; + int oldDepthSize = togl->DepthSize; + Bool oldAccumFlag = togl->AccumFlag; + int oldAccumRed = togl->AccumRed; + int oldAccumGreen = togl->AccumGreen; + int oldAccumBlue = togl->AccumBlue; + int oldAccumAlpha = togl->AccumAlpha; + Bool oldAlphaFlag = togl->AlphaFlag; + int oldAlphaSize = togl->AlphaSize; + Bool oldStencilFlag = togl->StencilFlag; + int oldStencilSize = togl->StencilSize; + int oldAuxNumber = togl->AuxNumber; + int oldWidth = togl->Width; + int oldHeight = togl->Height; + int oldSetGrid = togl->SetGrid; + + if (Tk_ConfigureWidget(interp, togl->TkWin, configSpecs, + argc, argv, WIDGREC togl, flags) == TCL_ERROR) { + return (TCL_ERROR); + } +#ifndef USE_OVERLAY + if (togl->OverlayFlag) { + TCL_ERR(interp, "Sorry, overlay was disabled"); + } +#endif + + + if (togl->Width != oldWidth || togl->Height != oldHeight + || togl->SetGrid != oldSetGrid) { + Togl_WorldChanged((ClientData) togl); + /* this added per Lou Arata */ + Tk_ResizeWindow(togl->TkWin, togl->Width, togl->Height); + + if (togl->ReshapeProc && +#if defined(TOGL_WGL) + togl->tglGLHglrc +#elif defined(TOGL_X11) + togl->GlCtx +#elif defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + togl->aglCtx +#endif + ) { + Togl_MakeCurrent(togl); + togl->ReshapeProc(togl); + } + } + + if (togl->RgbaFlag != oldRgbaFlag + || togl->RgbaRed != oldRgbaRed + || togl->RgbaGreen != oldRgbaGreen + || togl->RgbaBlue != oldRgbaBlue + || togl->DoubleFlag != oldDoubleFlag + || togl->DepthFlag != oldDepthFlag + || togl->DepthSize != oldDepthSize + || togl->AccumFlag != oldAccumFlag + || togl->AccumRed != oldAccumRed + || togl->AccumGreen != oldAccumGreen + || togl->AccumBlue != oldAccumBlue + || togl->AccumAlpha != oldAccumAlpha + || togl->AlphaFlag != oldAlphaFlag + || togl->AlphaSize != oldAlphaSize + || togl->StencilFlag != oldStencilFlag + || togl->StencilSize != oldStencilSize + || togl->AuxNumber != oldAuxNumber) { +#ifdef MESA_COLOR_HACK + free_default_color_cells(Tk_Display(togl->TkWin), + Tk_Colormap(togl->TkWin)); +#endif + } +#if defined(__sgi) + oldStereoInit(togl, togl->OldStereoFlag); +#endif + + return TCL_OK; +} + + +static int +Togl_Widget(ClientData clientData, Tcl_Interp *interp, int argc, + CONST84 char *argv[]) +{ + Togl *togl = (Togl *) clientData; + int result = TCL_OK; + Tcl_HashEntry *entry; + Tcl_HashSearch search; + Togl_CmdProc *cmd_proc; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ?options?\"", NULL); + return TCL_ERROR; + } + + Tk_Preserve((ClientData) togl); + + if (!strncmp(argv[1], "configure", MAX(1, strlen(argv[1])))) { + if (argc == 2) { + /* Return list of all configuration parameters */ + result = Tk_ConfigureInfo(interp, togl->TkWin, configSpecs, + WIDGREC togl, (char *) NULL, 0); + } else if (argc == 3) { + if (strcmp(argv[2], "-extensions") == 0) { + /* Return a list of OpenGL extensions available */ + const char *extensions; + + extensions = (const char *) glGetString(GL_EXTENSIONS); + Tcl_SetResult(interp, TCL_STUPID extensions, TCL_STATIC); + result = TCL_OK; + } else { + /* Return a specific configuration parameter */ + result = Tk_ConfigureInfo(interp, togl->TkWin, configSpecs, + WIDGREC togl, argv[2], 0); + } + } else { + /* Execute a configuration change */ + result = Togl_Configure(interp, togl, argc - 2, argv + 2, + TK_CONFIG_ARGV_ONLY); + } + } else if (!strncmp(argv[1], "render", MAX(1, strlen(argv[1])))) { + /* force the widget to be redrawn */ + Togl_Render((ClientData) togl); + } else if (!strncmp(argv[1], "swapbuffers", MAX(1, strlen(argv[1])))) { + /* force the widget to be redrawn */ + Togl_SwapBuffers(togl); + } else if (!strncmp(argv[1], "makecurrent", MAX(1, strlen(argv[1])))) { + /* force the widget to be redrawn */ + Togl_MakeCurrent(togl); + } +#if TOGL_USE_FONTS == 1 + else if (!strncmp(argv[1], "loadbitmapfont", MAX(1, strlen(argv[1])))) { + if (argc == 3) { + GLuint fontbase; + Tcl_Obj *fontbaseAsTclObject; + + fontbase = Togl_LoadBitmapFont(togl, argv[2]); + if (fontbase) { + fontbaseAsTclObject = Tcl_NewIntObj(fontbase); + Tcl_SetObjResult(interp, fontbaseAsTclObject); + result = TCL_OK; + } else { + Tcl_AppendResult(interp, "Could not allocate font", NULL); + result = TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "wrong # args", NULL); + result = TCL_ERROR; + } + } else if (!strncmp(argv[1], "unloadbitmapfont", MAX(1, strlen(argv[1])))) { + if (argc == 3) { + Togl_UnloadBitmapFont(togl, atoi(argv[2])); + result = TCL_OK; + } else { + Tcl_AppendResult(interp, "wrong # args", NULL); + result = TCL_ERROR; + } + } +#endif /* TOGL_USE_FONTS */ + else { + /* Probably a user-defined function */ + entry = Tcl_FindHashEntry(&CommandTable, argv[1]); + if (entry != NULL) { + cmd_proc = (Togl_CmdProc *) Tcl_GetHashValue(entry); + result = cmd_proc(togl, argc, argv); + } else { + Tcl_AppendResult(interp, "Togl: Unknown option: ", argv[1], "\n", + "Try: configure or render\n", + "or one of the user-defined commands:\n", NULL); + entry = Tcl_FirstHashEntry(&CommandTable, &search); + while (entry) { + Tcl_AppendResult(interp, " ", + Tcl_GetHashKey(&CommandTable, entry), "\n", NULL); + entry = Tcl_NextHashEntry(&search); + } + result = TCL_ERROR; + } + } + + Tk_Release((ClientData) togl); + return result; +} + + + +/* + * Togl_Cmd + * + * Called when Togl is executed - creation of a Togl widget. + * * Creates a new window + * * Creates an 'Togl' data structure + * * Creates an event handler for this window + * * Creates a command that handles this object + * * Configures this Togl for the given arguments + */ +static int +Togl_Cmd(ClientData clientData, Tcl_Interp *interp, int argc, + CONST84 char **argv) +{ + const char *name; + Tk_Window mainwin = (Tk_Window) clientData; + Tk_Window tkwin; + Togl *togl; + + if (argc <= 1) { + TCL_ERR(interp, "wrong # args: should be \"pathName read filename\""); + } + + /* Create the window. */ + name = argv[1]; + tkwin = Tk_CreateWindowFromPath(interp, mainwin, name, (char *) NULL); + if (tkwin == NULL) { + return TCL_ERROR; + } + + Tk_SetClass(tkwin, "Togl"); + + /* Create Togl data structure */ + togl = (Togl *) malloc(sizeof (Togl)); + if (!togl) { + return TCL_ERROR; + } + + togl->Next = NULL; +#if defined(TOGL_WGL) + togl->tglGLHdc = NULL; + togl->tglGLHglrc = NULL; +#elif defined(TOGL_X11) + togl->GlCtx = NULL; + togl->OverlayCtx = NULL; +#elif defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + togl->aglCtx = NULL; +#endif /* TOGL_WGL */ + togl->display = Tk_Display(tkwin); + togl->TkWin = tkwin; + togl->Interp = interp; +#ifndef NO_TK_CURSOR + togl->Cursor = None; +#endif + togl->Width = 0; + togl->Height = 0; + togl->SetGrid = 0; + togl->TimerInterval = 0; + togl->RgbaFlag = True; + togl->RgbaRed = 1; + togl->RgbaGreen = 1; + togl->RgbaBlue = 1; + togl->DoubleFlag = False; + togl->DepthFlag = False; + togl->DepthSize = 1; + togl->AccumFlag = False; + togl->AccumRed = 1; + togl->AccumGreen = 1; + togl->AccumBlue = 1; + togl->AccumAlpha = 1; + togl->AlphaFlag = False; + togl->AlphaSize = 1; + togl->StencilFlag = False; + togl->StencilSize = 1; + togl->OverlayFlag = False; + togl->StereoFlag = False; +#ifdef __sgi + togl->OldStereoFlag = False; +#endif + togl->AuxNumber = 0; + togl->Indirect = False; + togl->PixelFormat = 0; + togl->UpdatePending = False; + togl->OverlayUpdatePending = False; + togl->CreateProc = DefaultCreateProc; + togl->DisplayProc = DefaultDisplayProc; + togl->ReshapeProc = DefaultReshapeProc; + togl->DestroyProc = DefaultDestroyProc; + togl->TimerProc = DefaultTimerProc; + togl->OverlayDisplayProc = DefaultOverlayDisplayProc; + togl->ShareList = NULL; + togl->ShareContext = NULL; + togl->Ident = NULL; + togl->Client_Data = DefaultClientData; + + /* for EPS Output */ + togl->EpsRedMap = togl->EpsGreenMap = togl->EpsBlueMap = NULL; + togl->EpsMapSize = 0; + + /* Create command event handler */ + togl->widgetCmd = Tcl_CreateCommand(interp, Tk_PathName(tkwin), + Togl_Widget, (ClientData) togl, + (Tcl_CmdDeleteProc *) ToglCmdDeletedProc); + /* + * Setup the Tk_ClassProcs callbacks to point at our own window creation + * function + * + * We need to check at runtime if we should use the new Tk_SetClassProcs() + * API or if we need to modify the window structure directly */ + + +#ifdef HAVE_TK_SETCLASSPROCS + + if (SetClassProcsPtr != NULL) { /* use public API (Tk 8.4+) */ + Tk_ClassProcs *procsPtr; + + procsPtr = (Tk_ClassProcs *) Tcl_Alloc(sizeof (Tk_ClassProcs)); + procsPtr->size = sizeof (Tk_ClassProcs); + procsPtr->createProc = Togl_CreateWindow; + procsPtr->worldChangedProc = Togl_WorldChanged; + procsPtr->modalProc = NULL; + /* Tk_SetClassProcs(togl->TkWin,procsPtr,(ClientData)togl); */ + (SetClassProcsPtr) (togl->TkWin, procsPtr, (ClientData) togl); + } else +#endif + { /* use private API */ + /* + * We need to set these fields in the Tk_FakeWin structure: dummy17 = + * classProcsPtr dummy18 = instanceData */ + TkClassProcs *procsPtr; + Tk_FakeWin *winPtr = (Tk_FakeWin *) (togl->TkWin); + + procsPtr = (TkClassProcs *) Tcl_Alloc(sizeof (TkClassProcs)); + procsPtr->createProc = Togl_CreateWindow; + procsPtr->geometryProc = Togl_WorldChanged; + procsPtr->modalProc = NULL; + winPtr->dummy17 = (char *) procsPtr; + winPtr->dummy18 = (ClientData) togl; + } + + Tk_CreateEventHandler(tkwin, + ExposureMask | StructureNotifyMask, Togl_EventProc, + (ClientData) togl); + + /* Configure Togl widget */ + if (Togl_Configure(interp, togl, argc - 2, argv + 2, 0) == TCL_ERROR) { + Tk_DestroyWindow(tkwin); + Tcl_AppendResult(interp, "Couldn't configure togl widget\n", NULL); + goto error; + } + + /* + * If OpenGL window wasn't already created by Togl_Configure() we + * create it now. We can tell by checking if the GLX context has + * been initialized. + */ + if (! +#if defined(TOGL_WGL) + togl->tglGLHdc +#elif defined(TOGL_X11) + togl->GlCtx +#elif defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + togl->aglCtx +#endif + ) { + Tk_MakeWindowExist(togl->TkWin); + if (Tk_WindowId(togl->TkWin) == DUMMY_WINDOW) { + return TCL_ERROR; + } + Togl_MakeCurrent(togl); + } + + /* If defined, call create callback */ + if (togl->CreateProc) { + togl->CreateProc(togl); + } + + /* If defined, call reshape proc */ + if (togl->ReshapeProc) { + togl->ReshapeProc(togl); + } + + /* If defined, setup timer */ + if (togl->TimerProc) { + (void) Tk_CreateTimerHandler(togl->TimerInterval, Togl_Timer, + (ClientData) togl); + } + + Tcl_AppendResult(interp, Tk_PathName(tkwin), NULL); + + /* Add to linked list */ + AddToList(togl); + + return TCL_OK; + + error: + (void) Tcl_DeleteCommand(interp, "togl"); + /* free(togl); Don't free it, if we do a crash occurs later... */ + return TCL_ERROR; +} + + +#ifdef USE_OVERLAY + +/* + * Do all the setup for overlay planes + * Return: TCL_OK or TCL_ERROR + */ +static int +SetupOverlay(Togl *togl) +{ +# if defined(TOGL_X11) + +# ifdef GLX_TRANSPARENT_TYPE_EXT + static int ovAttributeList[] = { + GLX_BUFFER_SIZE, 2, + GLX_LEVEL, 1, + GLX_TRANSPARENT_TYPE_EXT, GLX_TRANSPARENT_INDEX_EXT, + None + }; +# else + static int ovAttributeList[] = { + GLX_BUFFER_SIZE, 2, + GLX_LEVEL, 1, + None + }; +# endif + + Display *dpy; + XVisualInfo *visinfo; + TkWindow *winPtr = (TkWindow *) togl->TkWin; + + XSetWindowAttributes swa; + Tcl_HashEntry *hPtr; + int new_flag; + + dpy = Tk_Display(togl->TkWin); + + visinfo = glXChooseVisual(dpy, Tk_ScreenNumber(winPtr), ovAttributeList); + if (!visinfo) { + Tcl_AppendResult(togl->Interp, Tk_PathName(winPtr), + ": No suitable overlay index visual available", (char *) NULL); + togl->OverlayCtx = 0; + togl->OverlayWindow = 0; + togl->OverlayCmap = 0; + return TCL_ERROR; + } +# ifdef GLX_TRANSPARENT_INDEX_EXT + { + int fail = + glXGetConfig(dpy, visinfo, GLX_TRANSPARENT_INDEX_VALUE_EXT, + &togl->OverlayTransparentPixel); + + if (fail) + togl->OverlayTransparentPixel = 0; /* maybe, maybe ... */ + } +# else + togl->OverlayTransparentPixel = 0; /* maybe, maybe ... */ +# endif + + /* share display lists with normal layer context */ + togl->OverlayCtx = + glXCreateContext(dpy, visinfo, togl->GlCtx, !togl->Indirect); + + swa.colormap = XCreateColormap(dpy, XRootWindow(dpy, visinfo->screen), + visinfo->visual, AllocNone); + togl->OverlayCmap = swa.colormap; + + swa.border_pixel = 0; + swa.event_mask = ALL_EVENTS_MASK; + togl->OverlayWindow = XCreateWindow(dpy, Tk_WindowId(togl->TkWin), 0, 0, + togl->Width, togl->Height, 0, + visinfo->depth, InputOutput, + visinfo->visual, CWBorderPixel | CWColormap | CWEventMask, &swa); + + hPtr = Tcl_CreateHashEntry(&winPtr->dispPtr->winTable, + (char *) togl->OverlayWindow, &new_flag); + Tcl_SetHashValue(hPtr, winPtr); + + /* XMapWindow( dpy, togl->OverlayWindow ); */ + togl->OverlayIsMapped = False; + + /* Make sure window manager installs our colormap */ + XSetWMColormapWindows(dpy, togl->OverlayWindow, &togl->OverlayWindow, 1); + + return TCL_OK; + +# elif defined(TOGL_WGL) || defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + /* not yet implemented on these */ + return TCL_ERROR; +# endif +} + +#endif /* USE_OVERLAY */ + + + +#ifdef TOGL_WGL +# define TOGL_CLASS_NAME "Togl Class" +static Bool ToglClassInitialized = False; + +static LRESULT CALLBACK +Win32WinProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam) +{ + LONG result; + Togl *togl = (Togl *) GetWindowLong(hwnd, 0); + WNDCLASS childClass; + + switch (message) { + case WM_WINDOWPOSCHANGED: + /* Should be processed by DefWindowProc, otherwise a double buffered + * context is not properly resized when the corresponding window is + * resized. */ + break; + case WM_DESTROY: + if (togl->tglGLHglrc) { + wglDeleteContext(togl->tglGLHglrc); + } + if (togl->tglGLHdc) { + ReleaseDC(hwnd, togl->tglGLHdc); + } + free(togl); + break; + default: +# if USE_STATIC_LIB + return TkWinChildProc(hwnd, message, wParam, lParam); +# else + /* + * OK, since TkWinChildProc is not explicitly exported in the + * dynamic libraries, we have to retrieve it from the class info + * registered with windows. + * + */ + if (tkWinChildProc == NULL) { + GetClassInfo(Tk_GetHINSTANCE(), TK_WIN_CHILD_CLASS_NAME, + &childClass); + tkWinChildProc = childClass.lpfnWndProc; + } + return tkWinChildProc(hwnd, message, wParam, lParam); +# endif + } + result = DefWindowProc(hwnd, message, wParam, lParam); + Tcl_ServiceAll(); + return result; +} +#endif /* TOGL_WGL */ + + + +/* + * Togl_CreateWindow + * + * Window creation function, invoked as a callback from Tk_MakeWindowExist. + * Creates an OpenGL window for the Togl widget. + */ +static Window +Togl_CreateWindow(Tk_Window tkwin, Window parent, ClientData instanceData) +{ + + Togl *togl = (Togl *) instanceData; + XVisualInfo *visinfo = NULL; + Display *dpy; + Colormap cmap; + int scrnum; + Window window; + +#if defined(TOGL_X11) + Bool directCtx = True; + int attrib_list[1000]; + int attrib_count; + int dummy; + XSetWindowAttributes swa; + +# define MAX_ATTEMPTS 12 + static int ci_depths[MAX_ATTEMPTS] = { + 8, 4, 2, 1, 12, 16, 8, 4, 2, 1, 12, 16 + }; + static int dbl_flags[MAX_ATTEMPTS] = { + 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1 + }; +#elif defined(TOGL_WGL) + HWND hwnd, parentWin; + int pixelformat; + HANDLE hInstance; + WNDCLASS ToglClass; + PIXELFORMATDESCRIPTOR pfd; + XVisualInfo VisInf; +#elif defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + GLint attribs[20]; + int na; + AGLPixelFormat fmt; + XVisualInfo VisInf; +#endif /* TOGL_X11 */ + + + dpy = Tk_Display(togl->TkWin); + +#if defined(TOGL_X11) + /* Make sure OpenGL's GLX extension supported */ + if (!glXQueryExtension(dpy, &dummy, &dummy)) { + Tcl_SetResult(togl->Interp, + TCL_STUPID "Togl: X server has no OpenGL GLX extension", + TCL_STATIC); + return DUMMY_WINDOW; + } + + if (togl->ShareContext && FindTogl(togl->ShareContext)) { + /* share OpenGL context with existing Togl widget */ + Togl *shareWith = FindTogl(togl->ShareContext); + + assert(shareWith != NULL); + assert(shareWith->GlCtx != NULL); + togl->GlCtx = shareWith->GlCtx; + togl->VisInfo = shareWith->VisInfo; + visinfo = togl->VisInfo; + } else { + if (togl->PixelFormat) { + XVisualInfo template; + int count = 1; + + template.visualid = togl->PixelFormat; + visinfo = XGetVisualInfo(dpy, VisualIDMask, &template, &count); + if (visinfo == NULL) { + Tcl_SetResult(togl->Interp, + TCL_STUPID "Togl: couldn't choose pixel format", + TCL_STATIC); + + return DUMMY_WINDOW; + } + /* fill in flags normally passed in that affect behavior */ + (void) glXGetConfig(dpy, visinfo, GLX_RGBA, &togl->RgbaFlag); + (void) glXGetConfig(dpy, visinfo, GLX_DOUBLEBUFFER, + &togl->DoubleFlag); + (void) glXGetConfig(dpy, visinfo, GLX_STEREO, &togl->StereoFlag); + } else { + int attempt; + + /* It may take a few tries to get a visual */ + for (attempt = 0; attempt < MAX_ATTEMPTS; attempt++) { + attrib_count = 0; + attrib_list[attrib_count++] = GLX_USE_GL; + if (togl->RgbaFlag) { + /* RGB[A] mode */ + attrib_list[attrib_count++] = GLX_RGBA; + attrib_list[attrib_count++] = GLX_RED_SIZE; + attrib_list[attrib_count++] = togl->RgbaRed; + attrib_list[attrib_count++] = GLX_GREEN_SIZE; + attrib_list[attrib_count++] = togl->RgbaGreen; + attrib_list[attrib_count++] = GLX_BLUE_SIZE; + attrib_list[attrib_count++] = togl->RgbaBlue; + if (togl->AlphaFlag) { + attrib_list[attrib_count++] = GLX_ALPHA_SIZE; + attrib_list[attrib_count++] = togl->AlphaSize; + } + + /* for EPS Output */ + if (togl->EpsRedMap) + free(togl->EpsRedMap); + if (togl->EpsGreenMap) + free(togl->EpsGreenMap); + if (togl->EpsBlueMap) + free(togl->EpsBlueMap); + togl->EpsRedMap = togl->EpsGreenMap = togl->EpsBlueMap = + NULL; + togl->EpsMapSize = 0; + } else { + /* Color index mode */ + int depth; + + attrib_list[attrib_count++] = GLX_BUFFER_SIZE; + depth = ci_depths[attempt]; + attrib_list[attrib_count++] = depth; + } + if (togl->DepthFlag) { + attrib_list[attrib_count++] = GLX_DEPTH_SIZE; + attrib_list[attrib_count++] = togl->DepthSize; + } + if (togl->DoubleFlag || dbl_flags[attempt]) { + attrib_list[attrib_count++] = GLX_DOUBLEBUFFER; + } + if (togl->StencilFlag) { + attrib_list[attrib_count++] = GLX_STENCIL_SIZE; + attrib_list[attrib_count++] = togl->StencilSize; + } + if (togl->AccumFlag) { + attrib_list[attrib_count++] = GLX_ACCUM_RED_SIZE; + attrib_list[attrib_count++] = togl->AccumRed; + attrib_list[attrib_count++] = GLX_ACCUM_GREEN_SIZE; + attrib_list[attrib_count++] = togl->AccumGreen; + attrib_list[attrib_count++] = GLX_ACCUM_BLUE_SIZE; + attrib_list[attrib_count++] = togl->AccumBlue; + if (togl->AlphaFlag) { + attrib_list[attrib_count++] = GLX_ACCUM_ALPHA_SIZE; + attrib_list[attrib_count++] = togl->AccumAlpha; + } + } + if (togl->AuxNumber != 0) { + attrib_list[attrib_count++] = GLX_AUX_BUFFERS; + attrib_list[attrib_count++] = togl->AuxNumber; + } + if (togl->Indirect) { + directCtx = False; + } + + if (togl->StereoFlag) { + attrib_list[attrib_count++] = GLX_STEREO; + } + attrib_list[attrib_count++] = None; + + visinfo = glXChooseVisual(dpy, Tk_ScreenNumber(togl->TkWin), + attrib_list); + if (visinfo) { + /* found a GLX visual! */ + break; + } + } + + togl->VisInfo = visinfo; + + if (visinfo == NULL) { + Tcl_SetResult(togl->Interp, + TCL_STUPID "Togl: couldn't get visual", TCL_STATIC); + return DUMMY_WINDOW; + } + + /* + * Create a new OpenGL rendering context. + */ + if (togl->ShareList) { + /* share display lists with existing togl widget */ + Togl *shareWith = FindTogl(togl->ShareList); + GLXContext shareCtx; + + if (shareWith) + shareCtx = shareWith->GlCtx; + else + shareCtx = None; + togl->GlCtx = + glXCreateContext(dpy, visinfo, shareCtx, directCtx); + } else { + /* don't share display lists */ + togl->GlCtx = glXCreateContext(dpy, visinfo, None, directCtx); + } + + if (togl->GlCtx == NULL) { + Tcl_SetResult(togl->Interp, + TCL_STUPID "could not create rendering context", + TCL_STATIC); + return DUMMY_WINDOW; + } + + } + } + + +#endif /* TOGL_X11 */ + +#ifdef TOGL_WGL + parentWin = Tk_GetHWND(parent); + hInstance = Tk_GetHINSTANCE(); + if (!ToglClassInitialized) { + ToglClassInitialized = True; + ToglClass.style = CS_HREDRAW | CS_VREDRAW; + ToglClass.cbClsExtra = 0; + ToglClass.cbWndExtra = 4; /* to save struct Togl* */ + ToglClass.hInstance = hInstance; + ToglClass.hbrBackground = NULL; + ToglClass.lpszMenuName = NULL; + ToglClass.lpszClassName = TOGL_CLASS_NAME; + ToglClass.lpfnWndProc = Win32WinProc; + ToglClass.hIcon = NULL; + ToglClass.hCursor = NULL; + if (!RegisterClass(&ToglClass)) { + Tcl_SetResult(togl->Interp, + TCL_STUPID "unable register Togl window class", TCL_STATIC); + return DUMMY_WINDOW; + } + } + + hwnd = CreateWindow(TOGL_CLASS_NAME, NULL, + WS_CHILD | WS_CLIPCHILDREN | WS_CLIPSIBLINGS, 0, 0, + togl->Width, togl->Height, parentWin, NULL, hInstance, NULL); + SetWindowLong(hwnd, 0, (LONG) togl); + SetWindowPos(hwnd, HWND_TOP, 0, 0, 0, 0, + SWP_NOACTIVATE | SWP_NOMOVE | SWP_NOSIZE); + + togl->tglGLHdc = GetDC(hwnd); + + pfd.nSize = sizeof (PIXELFORMATDESCRIPTOR); + pfd.nVersion = 1; + pfd.dwFlags = PFD_DRAW_TO_WINDOW | PFD_SUPPORT_OPENGL; + if (togl->DoubleFlag) { + pfd.dwFlags |= PFD_DOUBLEBUFFER; + } + /* The stereo flag is not supported in the current generic OpenGL + * implementation, but may be supported by specific hardware devices. */ + if (togl->StereoFlag) { + pfd.dwFlags |= PFD_STEREO; + } + + if (togl->PixelFormat) { + pixelformat = togl->PixelFormat; + } else { + pfd.cColorBits = togl->RgbaRed + togl->RgbaGreen + togl->RgbaBlue; + pfd.iPixelType = togl->RgbaFlag ? PFD_TYPE_RGBA : PFD_TYPE_COLORINDEX; + /* Alpha bitplanes are not supported in the current generic OpenGL + * implementation, but may be supported by specific hardware devices. */ + pfd.cAlphaBits = togl->AlphaFlag ? togl->AlphaSize : 0; + pfd.cAccumBits = togl->AccumFlag ? (togl->AccumRed + togl->AccumGreen + + togl->AccumBlue + togl->AccumAlpha) : 0; + pfd.cDepthBits = togl->DepthFlag ? togl->DepthSize : 0; + pfd.cStencilBits = togl->StencilFlag ? togl->StencilSize : 0; + /* Auxiliary buffers are not supported in the current generic OpenGL + * implementation, but may be supported by specific hardware devices. */ + pfd.cAuxBuffers = togl->AuxNumber; + pfd.iLayerType = PFD_MAIN_PLANE; + + if ((pixelformat = ChoosePixelFormat(togl->tglGLHdc, &pfd)) == 0) { + Tcl_SetResult(togl->Interp, + TCL_STUPID "Togl: couldn't choose pixel format", + TCL_STATIC); + return DUMMY_WINDOW; + } + } + if (SetPixelFormat(togl->tglGLHdc, pixelformat, &pfd) == FALSE) { + Tcl_SetResult(togl->Interp, + TCL_STUPID "Togl: couldn't choose pixel format", TCL_STATIC); + return DUMMY_WINDOW; + } + + /* Get the actual pixel format */ + DescribePixelFormat(togl->tglGLHdc, pixelformat, sizeof (pfd), &pfd); + if (togl->PixelFormat) { + /* fill in flags normally passed in that affect behavior */ + togl->RgbaFlag = pfd.iPixelType == PFD_TYPE_RGBA; + togl->DoubleFlag = pfd.cDepthBits > 0; + togl->StereoFlag = (pfd.dwFlags & PFD_STEREO) != 0; + // TODO: set depth flag, and more + } else if (togl->StereoFlag && (pfd.dwFlags & PFD_STEREO) == 0) { + Tcl_SetResult(togl->Interp, + TCL_STUPID "Togl: couldn't choose stereo pixel format", + TCL_STATIC); + return DUMMY_WINDOW; + } + + if (togl->ShareContext && FindTogl(togl->ShareContext)) { + /* share OpenGL context with existing Togl widget */ + Togl *shareWith = FindTogl(togl->ShareContext); + + assert(shareWith); + assert(shareWith->tglGLHglrc); + togl->tglGLHglrc = shareWith->tglGLHglrc; + togl->VisInfo = shareWith->VisInfo; + visinfo = togl->VisInfo; + } else { + /* + * Create a new OpenGL rendering context. And check to share lists. + */ + togl->tglGLHglrc = wglCreateContext(togl->tglGLHdc); + + if (togl->ShareList) { + /* share display lists with existing togl widget */ + Togl *shareWith = FindTogl(togl->ShareList); + + if (shareWith) + wglShareLists(shareWith->tglGLHglrc, togl->tglGLHglrc); + } + + if (!togl->tglGLHglrc) { + Tcl_SetResult(togl->Interp, + TCL_STUPID "could not create rendering context", + TCL_STATIC); + return DUMMY_WINDOW; + } + + /* Just for portability, define the simplest visinfo */ + visinfo = &VisInf; + visinfo->visual = DefaultVisual(dpy, DefaultScreen(dpy)); + visinfo->depth = visinfo->visual->bits_per_rgb; + togl->VisInfo = visinfo; + } + +#endif /* TOGL_WGL */ + + + /* + * find a colormap + */ + scrnum = Tk_ScreenNumber(togl->TkWin); + if (togl->RgbaFlag) { + /* Colormap for RGB mode */ +#if defined(TOGL_X11) + cmap = get_rgb_colormap(dpy, scrnum, visinfo, togl->TkWin); + +#elif defined(TOGL_WGL) + if (pfd.dwFlags & PFD_NEED_PALETTE) { + cmap = Win32CreateRgbColormap(pfd); + } else { + cmap = DefaultColormap(dpy, scrnum); + } + /* for EPS Output */ + if (togl->EpsRedMap) + free(togl->EpsRedMap); + if (togl->EpsGreenMap) + free(togl->EpsGreenMap); + if (togl->EpsBlueMap) + free(togl->EpsBlueMap); + togl->EpsRedMap = togl->EpsGreenMap = togl->EpsBlueMap = NULL; + togl->EpsMapSize = 0; + +#elif defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + cmap = DefaultColormap(dpy, scrnum); + /* for EPS Output */ + if (togl->EpsRedMap) + free(togl->EpsRedMap); + if (togl->EpsGreenMap) + free(togl->EpsGreenMap); + if (togl->EpsBlueMap) + free(togl->EpsBlueMap); + togl->EpsRedMap = togl->EpsGreenMap = togl->EpsBlueMap = NULL; + togl->EpsMapSize = 0; +#endif /* TOGL_X11 */ + } else { + /* Colormap for CI mode */ +#ifdef TOGL_WGL + togl->CiColormapSize = 1 << pfd.cColorBits; + togl->CiColormapSize = togl->CiColormapSize < MAX_CI_COLORMAP_SIZE ? + togl->CiColormapSize : MAX_CI_COLORMAP_SIZE; + +#endif /* TOGL_WGL */ + if (togl->PrivateCmapFlag) { + /* need read/write colormap so user can store own color entries */ +#if defined(TOGL_X11) + cmap = XCreateColormap(dpy, XRootWindow(dpy, visinfo->screen), + visinfo->visual, AllocAll); +#elif defined(TOGL_WGL) + cmap = Win32CreateCiColormap(togl); +#elif defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + /* need to figure out how to do this correctly on Mac... */ + cmap = DefaultColormap(dpy, scrnum); +#endif /* TOGL_X11 */ + } else { + if (visinfo->visual == DefaultVisual(dpy, scrnum)) { + /* share default/root colormap */ + cmap = Tk_Colormap(togl->TkWin); + } else { + /* make a new read-only colormap */ + cmap = XCreateColormap(dpy, XRootWindow(dpy, visinfo->screen), + visinfo->visual, AllocNone); + } + } + } + +#if !defined(TOGL_AGL) + /* Make sure Tk knows to switch to the new colormap when the cursor is over + * this window when running in color index mode. */ + (void) Tk_SetWindowVisual(togl->TkWin, visinfo->visual, visinfo->depth, + cmap); +#endif + +#ifdef TOGL_WGL + /* Install the colormap */ + SelectPalette(togl->tglGLHdc, ((TkWinColormap *) cmap)->palette, TRUE); + RealizePalette(togl->tglGLHdc); +#endif /* TOGL_WGL */ + +#if defined(TOGL_X11) + swa.colormap = cmap; + swa.border_pixel = 0; + swa.event_mask = ALL_EVENTS_MASK; + window = XCreateWindow(dpy, parent, + 0, 0, togl->Width, togl->Height, + 0, visinfo->depth, + InputOutput, visinfo->visual, + CWBorderPixel | CWColormap | CWEventMask, &swa); + /* Make sure window manager installs our colormap */ + (void) XSetWMColormapWindows(dpy, window, &window, 1); + +#elif defined(TOGL_WGL) + window = Tk_AttachHWND(togl->TkWin, hwnd); + +#elif defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + { + TkWindow *winPtr = (TkWindow *) togl->TkWin; + + window = TkpMakeWindow(winPtr, parent); + } +#endif /* TOGL_X11 */ + +#ifdef USE_OVERLAY + if (togl->OverlayFlag) { + if (SetupOverlay(togl) == TCL_ERROR) { + fprintf(stderr, "Warning: couldn't setup overlay.\n"); + togl->OverlayFlag = False; + } + } +#endif /* USE_OVERLAY */ + + /* Request the X window to be displayed */ + (void) XMapWindow(dpy, window); + +#if defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + if (togl->ShareContext && FindTogl(togl->ShareContext)) { + /* share OpenGL context with existing Togl widget */ + Togl *shareWith = FindTogl(togl->ShareContext); + + assert(shareWith); + assert(shareWith->aglCtx); + togl->aglCtx = shareWith->aglCtx; + togl->VisInfo = shareWith->VisInfo; + visinfo = togl->VisInfo; + + } else { + AGLContext shareCtx = NULL; + + if (togl->PixelFormat) { + /* fill in RgbaFlag, DoubleFlag, and StereoFlag */ + fmt = (AGLPixelFormat) togl->PixelFormat; + GLint has_rgba, has_doublebuf, has_stereo; + + if (aglDescribePixelFormat(fmt, AGL_RGBA, &has_rgba) && + aglDescribePixelFormat(fmt, AGL_DOUBLEBUFFER, + &has_doublebuf) + && aglDescribePixelFormat(fmt, AGL_STEREO, &has_stereo)) { + togl->RgbaFlag = (has_rgba ? True : False); + togl->DoubleFlag = (has_doublebuf ? True : False); + togl->StereoFlag = (has_stereo ? True : False); + } else { + Tcl_SetResult(togl->Interp, + TCL_STUPID + "Togl: failed querying pixel format attributes", + TCL_STATIC); + return DUMMY_WINDOW; + } + } else { + + /* Need to do this after mapping window, so MacDrawable structure + * is more completely filled in */ + na = 0; + attribs[na++] = AGL_MINIMUM_POLICY; + attribs[na++] = AGL_ROBUST; + if (togl->RgbaFlag) { + /* RGB[A] mode */ + attribs[na++] = AGL_RGBA; + attribs[na++] = AGL_RED_SIZE; + attribs[na++] = togl->RgbaRed; + attribs[na++] = AGL_GREEN_SIZE; + attribs[na++] = togl->RgbaGreen; + attribs[na++] = AGL_BLUE_SIZE; + attribs[na++] = togl->RgbaBlue; + if (togl->AlphaFlag) { + attribs[na++] = AGL_ALPHA_SIZE; + attribs[na++] = togl->AlphaSize; + } + } else { + /* Color index mode */ + attribs[na++] = AGL_BUFFER_SIZE; + attribs[na++] = 8; + } + if (togl->DepthFlag) { + attribs[na++] = AGL_DEPTH_SIZE; + attribs[na++] = togl->DepthSize; + } + if (togl->DoubleFlag) { + attribs[na++] = AGL_DOUBLEBUFFER; + } + if (togl->StencilFlag) { + attribs[na++] = AGL_STENCIL_SIZE; + attribs[na++] = togl->StencilSize; + } + if (togl->AccumFlag) { + attribs[na++] = AGL_ACCUM_RED_SIZE; + attribs[na++] = togl->AccumRed; + attribs[na++] = AGL_ACCUM_GREEN_SIZE; + attribs[na++] = togl->AccumGreen; + attribs[na++] = AGL_ACCUM_BLUE_SIZE; + attribs[na++] = togl->AccumBlue; + if (togl->AlphaFlag) { + attribs[na++] = AGL_ACCUM_ALPHA_SIZE; + attribs[na++] = togl->AccumAlpha; + } + } + if (togl->AuxNumber != 0) { + attribs[na++] = AGL_AUX_BUFFERS; + attribs[na++] = togl->AuxNumber; + } + attribs[na++] = AGL_NONE; + + if ((fmt = aglChoosePixelFormat(NULL, 0, attribs)) == NULL) { + Tcl_SetResult(togl->Interp, + TCL_STUPID "Togl: couldn't choose pixel format", + TCL_STATIC); + return DUMMY_WINDOW; + } + } + + /* + * Check whether to share lists. + */ + if (togl->ShareList) { + /* share display lists with existing togl widget */ + Togl *shareWith = FindTogl(togl->ShareList); + + if (shareWith) + shareCtx = shareWith->aglCtx; + } + if ((togl->aglCtx = aglCreateContext(fmt, shareCtx)) == NULL) { + GLenum err = aglGetError(); + + aglDestroyPixelFormat(fmt); + if (err == AGL_BAD_MATCH) + Tcl_SetResult(togl->Interp, + TCL_STUPID + "Togl: couldn't create context, shared context doesn't match", + TCL_STATIC); + else if (err == AGL_BAD_CONTEXT) + Tcl_SetResult(togl->Interp, + TCL_STUPID + "Togl: couldn't create context, bad shared context", + TCL_STATIC); + else if (err == AGL_BAD_PIXELFMT) + Tcl_SetResult(togl->Interp, + TCL_STUPID + "Togl: couldn't create context, bad pixel format", + TCL_STATIC); + else + Tcl_SetResult(togl->Interp, + TCL_STUPID + "Togl: couldn't create context, unknown reason", + TCL_STATIC); + return DUMMY_WINDOW; + } + + aglDestroyPixelFormat(fmt); + if (!aglSetDrawable(togl->aglCtx, +# if defined(TOGL_AGL) + ((MacDrawable *) (window))->toplevel->grafPtr +# else + ((MacDrawable *) (window))->toplevel->portPtr +# endif + )) { + aglDestroyContext(togl->aglCtx); + Tcl_SetResult(togl->Interp, + TCL_STUPID "Togl: couldn't set drawable", TCL_STATIC); + return DUMMY_WINDOW; + } + + /* Just for portability, define the simplest visinfo */ + visinfo = &VisInf; + visinfo->visual = DefaultVisual(dpy, DefaultScreen(dpy)); + visinfo->depth = visinfo->visual->bits_per_rgb; + + Tk_SetWindowVisual(togl->TkWin, visinfo->visual, visinfo->depth, cmap); + } +#endif /* TOGL_AGL_CLASSIC || TOGL_AGL */ + +#if defined(TOGL_X11) + /* Check for a single/double buffering snafu */ + { + int dbl_flag; + + if (glXGetConfig(dpy, visinfo, GLX_DOUBLEBUFFER, &dbl_flag)) { + if (!togl->DoubleFlag && dbl_flag) { + /* We requested single buffering but had to accept a */ + /* double buffered visual. Set the GL draw buffer to */ + /* be the front buffer to simulate single buffering. */ + glDrawBuffer(GL_FRONT); + } + } + } +#endif /* TOGL_X11 */ + + /* for EPS Output */ + if (!togl->RgbaFlag) { + int index_size; + +#if defined(TOGL_X11) || defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + GLint index_bits; + + glGetIntegerv(GL_INDEX_BITS, &index_bits); + index_size = 1 << index_bits; +#elif defined(TOGL_WGL) + index_size = togl->CiColormapSize; +#endif /* TOGL_X11 */ + if (togl->EpsMapSize != index_size) { + if (togl->EpsRedMap) + free(togl->EpsRedMap); + if (togl->EpsGreenMap) + free(togl->EpsGreenMap); + if (togl->EpsBlueMap) + free(togl->EpsBlueMap); + togl->EpsMapSize = index_size; + togl->EpsRedMap = (GLfloat *) calloc(index_size, sizeof (GLfloat)); + togl->EpsGreenMap = + (GLfloat *) calloc(index_size, sizeof (GLfloat)); + togl->EpsBlueMap = (GLfloat *) calloc(index_size, sizeof (GLfloat)); + } + } + + return window; +} + +/* + * Togl_WorldChanged + * + * Add support for setgrid option. + */ +static void +Togl_WorldChanged(ClientData instanceData) +{ + Togl *togl = (Togl *) instanceData; + + Tk_GeometryRequest(togl->TkWin, togl->Width, togl->Height); + Tk_SetInternalBorder(togl->TkWin, 0); + if (togl->SetGrid > 0) { + Tk_SetGrid(togl->TkWin, togl->Width / togl->SetGrid, + togl->Height / togl->SetGrid, togl->SetGrid, togl->SetGrid); + } else { + Tk_UnsetGrid(togl->TkWin); + } +} + +/* + * ToglCmdDeletedProc + * + * This procedure is invoked when a widget command is deleted. If + * the widget isn't already in the process of being destroyed, + * this command destroys it. + * + * Results: + * None. + * + * Side effects: + * The widget is destroyed. + * + *---------------------------------------------------------------------- + */ +static void +ToglCmdDeletedProc(ClientData clientData) +{ + Togl *togl = (Togl *) clientData; + Tk_Window tkwin = togl->TkWin; + + /* + * This procedure could be invoked either because the window was + * destroyed and the command was then deleted (in which case tkwin + * is NULL) or because the command was deleted, and then this procedure + * destroys the widget. + */ + + if (togl && tkwin) { + Tk_DeleteEventHandler(tkwin, + ExposureMask | StructureNotifyMask, + Togl_EventProc, (ClientData) togl); + } +#if defined(TOGL_X11) + if (togl->GlCtx) { + if (FindToglWithSameContext(togl) == NULL) + glXDestroyContext(togl->display, togl->GlCtx); + togl->GlCtx = NULL; + } +# ifdef USE_OVERLAY + if (togl->OverlayCtx) { + Tcl_HashEntry *entryPtr; + TkWindow *winPtr = (TkWindow *) togl->TkWin; + + if (winPtr) { + entryPtr = Tcl_FindHashEntry(&winPtr->dispPtr->winTable, + (char *) togl->OverlayWindow); + Tcl_DeleteHashEntry(entryPtr); + } + if (FindToglWithSameOverlayContext(togl) == NULL) + glXDestroyContext(togl->display, togl->OverlayCtx); + togl->OverlayCtx = NULL; + } +# endif /* USE_OVERLAY */ +#endif + /* TODO: delete contexts on other platforms */ + + if (tkwin != NULL) { + if (togl->SetGrid > 0) { + Tk_UnsetGrid(tkwin); + } + togl->TkWin = NULL; + Tk_DestroyWindow(tkwin); + } +} + + +/* + * Togl_Destroy + * + * Gets called when an Togl widget is destroyed. + */ +static void +Togl_Destroy( +#if (TK_MAJOR_VERSION * 100 + TK_MINOR_VERSION) >= 401 + char * +#else + ClientData +#endif + clientData) +{ + Togl *togl = (Togl *) clientData; + + Tk_FreeOptions(configSpecs, WIDGREC togl, togl->display, 0); + +#ifndef NO_TK_CURSOR + if (togl->Cursor != None) { + Tk_FreeCursor(togl->display, togl->Cursor); + } +#endif + if (togl->DestroyProc) { + togl->DestroyProc(togl); + } + + /* remove from linked list */ + RemoveFromList(togl); + +#if !defined(TOGL_WGL) + /* TODO: why not on Windows? */ + free(togl); +#endif +} + + + +/* + * This gets called to handle Togl window configuration events + */ +static void +Togl_EventProc(ClientData clientData, XEvent *eventPtr) +{ + Togl *togl = (Togl *) clientData; + + switch (eventPtr->type) { + case Expose: + if (eventPtr->xexpose.count == 0) { + if (!togl->UpdatePending + && eventPtr->xexpose.window == Tk_WindowId(togl->TkWin)) { + Togl_PostRedisplay(togl); + } +#if defined(TOGL_X11) + if (!togl->OverlayUpdatePending && togl->OverlayFlag + && togl->OverlayIsMapped + && eventPtr->xexpose.window == togl->OverlayWindow) { + Togl_PostOverlayRedisplay(togl); + } +#endif /* TOGL_X11 */ + } + break; + case ConfigureNotify: + if (togl->Width != Tk_Width(togl->TkWin) + || togl->Height != Tk_Height(togl->TkWin)) { + togl->Width = Tk_Width(togl->TkWin); + togl->Height = Tk_Height(togl->TkWin); + (void) XResizeWindow(Tk_Display(togl->TkWin), + Tk_WindowId(togl->TkWin), togl->Width, togl->Height); +#if defined(TOGL_X11) + if (togl->OverlayFlag) { + (void) XResizeWindow(Tk_Display(togl->TkWin), + togl->OverlayWindow, togl->Width, togl->Height); + (void) XRaiseWindow(Tk_Display(togl->TkWin), + togl->OverlayWindow); + } +#endif /* TOGL_X11 */ + Togl_MakeCurrent(togl); + if (togl->ReshapeProc) { + togl->ReshapeProc(togl); + } else { + glViewport(0, 0, togl->Width, togl->Height); +#if defined(TOGL_X11) + if (togl->OverlayFlag) { + Togl_UseLayer(togl, TOGL_OVERLAY); + glViewport(0, 0, togl->Width, togl->Height); + Togl_UseLayer(togl, TOGL_NORMAL); + } +#endif /* TOGL_X11 */ + } +#ifndef TOGL_WGL /* causes double redisplay on Win32 platform */ + Togl_PostRedisplay(togl); +#endif /* TOGL_WGL */ + } + break; + case MapNotify: +#if defined(TOGL_AGL) + { + /* + * See comment for the UnmapNotify case below. + */ + AGLDrawable d = TkMacOSXGetDrawablePort(Tk_WindowId(togl->TkWin)); + + aglSetDrawable(togl->aglCtx, d); + } +#endif /* TOGL_AGL */ + break; + case UnmapNotify: +#if defined(TOGL_AGL) + { + /* + * For Mac OS X Aqua, Tk subwindows are not implemented as + * separate Aqua windows. They are just different regions of + * a single Aqua window. To unmap them they are just not drawn. + * Have to disconnect the AGL context otherwise they will continue + * to be displayed directly by Aqua. + */ + aglSetDrawable(togl->aglCtx, NULL); + } +#endif /* TOGL_AGL */ + break; + case DestroyNotify: + if (togl->TkWin != NULL) { + if (togl->SetGrid > 0) { + Tk_UnsetGrid(togl->TkWin); + } + togl->TkWin = NULL; +#if (TCL_MAJOR_VERSION * 100 + TCL_MINOR_VERSION) >= 800 + /* This function new in Tcl/Tk 8.0 */ + (void) Tcl_DeleteCommandFromToken(togl->Interp, togl->widgetCmd); +#endif + } + if (togl->TimerProc != NULL) { +#if (TK_MAJOR_VERSION * 100 + TK_MINOR_VERSION) >= 401 + Tcl_DeleteTimerHandler(togl->timerHandler); +#else + Tk_DeleteTimerHandler(togl->timerHandler); +#endif + + } + if (togl->UpdatePending) { +#if (TCL_MAJOR_VERSION * 100 + TCL_MINOR_VERSION) >= 705 + Tcl_CancelIdleCall(Togl_Render, (ClientData) togl); +#else + Tk_CancelIdleCall(Togl_Render, (ClientData) togl); +#endif + } +#if (TK_MAJOR_VERSION * 100 + TK_MINOR_VERSION) >= 401 + Tcl_EventuallyFree((ClientData) togl, Togl_Destroy); +#else + Tk_EventuallyFree((ClientData) togl, Togl_Destroy); +#endif + + break; + default: + /* nothing */ + ; + } +} + + + +void +Togl_PostRedisplay(Togl *togl) +{ + if (!togl->UpdatePending) { + togl->UpdatePending = True; + Tk_DoWhenIdle(Togl_Render, (ClientData) togl); + } +} + + + +void +Togl_SwapBuffers(const Togl *togl) +{ + if (togl->DoubleFlag) { +#if defined(TOGL_WGL) + int res = SwapBuffers(togl->tglGLHdc); + + assert(res == TRUE); +#elif defined(TOGL_X11) + glXSwapBuffers(Tk_Display(togl->TkWin), Tk_WindowId(togl->TkWin)); +#elif defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + aglSwapBuffers(togl->aglCtx); +#endif /* TOGL_WGL */ + } else { + glFlush(); + } +} + + + +const char * +Togl_Ident(const Togl *togl) +{ + return togl->Ident; +} + + +int +Togl_Width(const Togl *togl) +{ + return togl->Width; +} + + +int +Togl_Height(const Togl *togl) +{ + return togl->Height; +} + + +Tcl_Interp * +Togl_Interp(const Togl *togl) +{ + return togl->Interp; +} + + +Tk_Window +Togl_TkWin(const Togl *togl) +{ + return togl->TkWin; +} + + +#if defined(TOGL_X11) +/* + * A replacement for XAllocColor. This function should never + * fail to allocate a color. When XAllocColor fails, we return + * the nearest matching color. If we have to allocate many colors + * this function isn't too efficient; the XQueryColors() could be + * done just once. + * Written by Michael Pichler, Brian Paul, Mark Kilgard + * Input: dpy - X display + * cmap - X colormap + * cmapSize - size of colormap + * In/Out: color - the XColor struct + * Output: exact - 1=exact color match, 0=closest match + */ +static void +noFaultXAllocColor(Display *dpy, Colormap cmap, int cmapSize, + XColor *color, int *exact) +{ + XColor *ctable, subColor; + int i, bestmatch; + double mindist; /* 3*2^16^2 exceeds long int precision. */ + + /* First try just using XAllocColor. */ + if (XAllocColor(dpy, cmap, color)) { + *exact = 1; + return; + } + + /* Retrieve color table entries. */ + /* XXX alloca candidate. */ + ctable = (XColor *) malloc(cmapSize * sizeof (XColor)); + for (i = 0; i < cmapSize; i++) { + ctable[i].pixel = i; + } + (void) XQueryColors(dpy, cmap, ctable, cmapSize); + + /* Find best match. */ + bestmatch = -1; + mindist = 0; + for (i = 0; i < cmapSize; i++) { + double dr = (double) color->red - (double) ctable[i].red; + double dg = (double) color->green - (double) ctable[i].green; + double db = (double) color->blue - (double) ctable[i].blue; + double dist = dr * dr + dg * dg + db * db; + + if (bestmatch < 0 || dist < mindist) { + bestmatch = i; + mindist = dist; + } + } + + /* Return result. */ + subColor.red = ctable[bestmatch].red; + subColor.green = ctable[bestmatch].green; + subColor.blue = ctable[bestmatch].blue; + free(ctable); + /* Try to allocate the closest match color. This should only fail if the + * cell is read/write. Otherwise, we're incrementing the cell's reference + * count. */ + if (!XAllocColor(dpy, cmap, &subColor)) { + /* do this to work around a problem reported by Frank Ortega */ + subColor.pixel = (unsigned long) bestmatch; + subColor.red = ctable[bestmatch].red; + subColor.green = ctable[bestmatch].green; + subColor.blue = ctable[bestmatch].blue; + subColor.flags = DoRed | DoGreen | DoBlue; + } + *color = subColor; +} + +#elif defined(TOGL_WGL) + +static UINT +Win32AllocColor(const Togl *togl, float red, float green, float blue) +{ + /* Modified version of XAllocColor emulation of Tk. - returns index, + * instead of color itself - allocates logical palette entry even for + * non-palette devices */ + + TkWinColormap *cmap = (TkWinColormap *) Tk_Colormap(togl->TkWin); + UINT index; + COLORREF newColor, closeColor; + PALETTEENTRY entry, closeEntry; + int new, refCount; + Tcl_HashEntry *entryPtr; + + entry.peRed = (unsigned char) (red * 255 + .5); + entry.peGreen = (unsigned char) (green * 255 + .5); + entry.peBlue = (unsigned char) (blue * 255 + .5); + entry.peFlags = 0; + + /* + * Find the nearest existing palette entry. + */ + + newColor = RGB(entry.peRed, entry.peGreen, entry.peBlue); + index = GetNearestPaletteIndex(cmap->palette, newColor); + GetPaletteEntries(cmap->palette, index, 1, &closeEntry); + closeColor = RGB(closeEntry.peRed, closeEntry.peGreen, closeEntry.peBlue); + + /* + * If this is not a duplicate and colormap is not full, allocate a new entry. + */ + + if (newColor != closeColor) { + if (cmap->size == (unsigned int) togl->CiColormapSize) { + entry = closeEntry; + } else { + cmap->size++; + ResizePalette(cmap->palette, cmap->size); + index = cmap->size - 1; + SetPaletteEntries(cmap->palette, index, 1, &entry); + SelectPalette(togl->tglGLHdc, cmap->palette, TRUE); + RealizePalette(togl->tglGLHdc); + } + } + newColor = PALETTERGB(entry.peRed, entry.peGreen, entry.peBlue); + entryPtr = Tcl_CreateHashEntry(&cmap->refCounts, (char *) newColor, &new); + if (new) { + refCount = 1; + } else { + refCount = ((int) Tcl_GetHashValue(entryPtr)) + 1; + } + Tcl_SetHashValue(entryPtr, (ClientData) refCount); + + /* for EPS output */ + togl->EpsRedMap[index] = (GLfloat) (entry.peRed / 255.0); + togl->EpsGreenMap[index] = (GLfloat) (entry.peGreen / 255.0); + togl->EpsBlueMap[index] = (GLfloat) (entry.peBlue / 255.0); + return index; +} + +static void +Win32FreeColor(const Togl *togl, unsigned long index) +{ + TkWinColormap *cmap = (TkWinColormap *) Tk_Colormap(togl->TkWin); + COLORREF cref; + UINT count, refCount; + PALETTEENTRY entry, *entries; + Tcl_HashEntry *entryPtr; + + if (index >= cmap->size) { + panic("Tried to free a color that isn't allocated."); + } + GetPaletteEntries(cmap->palette, index, 1, &entry); + cref = PALETTERGB(entry.peRed, entry.peGreen, entry.peBlue); + entryPtr = Tcl_FindHashEntry(&cmap->refCounts, (char *) cref); + if (!entryPtr) { + panic("Tried to free a color that isn't allocated."); + } + refCount = (int) Tcl_GetHashValue(entryPtr) - 1; + if (refCount == 0) { + count = cmap->size - index; + entries = (PALETTEENTRY *) ckalloc(sizeof (PALETTEENTRY) * count); + GetPaletteEntries(cmap->palette, index + 1, count, entries); + SetPaletteEntries(cmap->palette, index, count, entries); + SelectPalette(togl->tglGLHdc, cmap->palette, TRUE); + RealizePalette(togl->tglGLHdc); + ckfree((char *) entries); + cmap->size--; + Tcl_DeleteHashEntry(entryPtr); + } else { + Tcl_SetHashValue(entryPtr, (ClientData) refCount); + } +} + +static void +Win32SetColor(const Togl *togl, + unsigned long index, float red, float green, float blue) +{ + TkWinColormap *cmap = (TkWinColormap *) Tk_Colormap(togl->TkWin); + PALETTEENTRY entry; + + entry.peRed = (unsigned char) (red * 255 + .5); + entry.peGreen = (unsigned char) (green * 255 + .5); + entry.peBlue = (unsigned char) (blue * 255 + .5); + entry.peFlags = 0; + SetPaletteEntries(cmap->palette, index, 1, &entry); + SelectPalette(togl->tglGLHdc, cmap->palette, TRUE); + RealizePalette(togl->tglGLHdc); + + /* for EPS output */ + togl->EpsRedMap[index] = (GLfloat) (entry.peRed / 255.0); + togl->EpsGreenMap[index] = (GLfloat) (entry.peGreen / 255.0); + togl->EpsBlueMap[index] = (GLfloat) (entry.peBlue / 255.0); +} +#endif /* TOGL_X11 */ + + +unsigned long +Togl_AllocColor(const Togl *togl, float red, float green, float blue) +{ + if (togl->RgbaFlag) { + (void) fprintf(stderr, + "Error: Togl_AllocColor illegal in RGBA mode.\n"); + return 0; + } + /* TODO: maybe not... */ + if (togl->PrivateCmapFlag) { + (void) fprintf(stderr, + "Error: Togl_FreeColor illegal with private colormap\n"); + return 0; + } +#if defined(TOGL_X11) + { + XColor xcol; + int exact; + + xcol.red = (short) (red * 65535.0); + xcol.green = (short) (green * 65535.0); + xcol.blue = (short) (blue * 65535.0); + + noFaultXAllocColor(Tk_Display(togl->TkWin), Tk_Colormap(togl->TkWin), + Tk_Visual(togl->TkWin)->map_entries, &xcol, &exact); + /* for EPS output */ + togl->EpsRedMap[xcol.pixel] = (float) xcol.red / 65535.0; + togl->EpsGreenMap[xcol.pixel] = (float) xcol.green / 65535.0; + togl->EpsBlueMap[xcol.pixel] = (float) xcol.blue / 65535.0; + + return xcol.pixel; + } + +#elif defined(TOGL_WGL) + return Win32AllocColor(togl, red, green, blue); + +#elif defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + /* still need to implement this on Mac... */ + return 0; + +#endif /* TOGL_X11 */ +} + + + +void +Togl_FreeColor(const Togl *togl, unsigned long pixel) +{ + if (togl->RgbaFlag) { + (void) fprintf(stderr, + "Error: Togl_AllocColor illegal in RGBA mode.\n"); + return; + } + /* TODO: maybe not... */ + if (togl->PrivateCmapFlag) { + (void) fprintf(stderr, + "Error: Togl_FreeColor illegal with private colormap\n"); + return; + } +#if defined(TOGL_X11) + (void) XFreeColors(Tk_Display(togl->TkWin), Tk_Colormap(togl->TkWin), + &pixel, 1, 0); +#elif defined(TOGL_WGL) + Win32FreeColor(togl, pixel); +#endif /* TOGL_X11 */ +} + + + +void +Togl_SetColor(const Togl *togl, + unsigned long index, float red, float green, float blue) +{ + + if (togl->RgbaFlag) { + (void) fprintf(stderr, + "Error: Togl_AllocColor illegal in RGBA mode.\n"); + return; + } + if (!togl->PrivateCmapFlag) { + (void) fprintf(stderr, + "Error: Togl_SetColor requires a private colormap\n"); + return; + } +#if defined(TOGL_X11) + { + XColor xcol; + + xcol.pixel = index; + xcol.red = (short) (red * 65535.0); + xcol.green = (short) (green * 65535.0); + xcol.blue = (short) (blue * 65535.0); + xcol.flags = DoRed | DoGreen | DoBlue; + + (void) XStoreColor(Tk_Display(togl->TkWin), Tk_Colormap(togl->TkWin), + &xcol); + + /* for EPS output */ + togl->EpsRedMap[xcol.pixel] = (float) xcol.red / 65535.0; + togl->EpsGreenMap[xcol.pixel] = (float) xcol.green / 65535.0; + togl->EpsBlueMap[xcol.pixel] = (float) xcol.blue / 65535.0; + } +#elif defined(TOGL_WGL) + Win32SetColor(togl, index, red, green, blue); +#endif /* TOGL_X11 */ +} + + +#if TOGL_USE_FONTS == 1 + +# if defined(TOGL_WGL) +# include "tkWinInt.h" +# include "tkFont.h" + +/* + * The following structure represents Windows' implementation of a font. + */ + +typedef struct WinFont +{ + TkFont font; /* Stuff used by generic font package. Must be + * first in structure. */ + HFONT hFont; /* Windows information about font. */ + HWND hwnd; /* Toplevel window of application that owns + * this font, used for getting HDC. */ + int widths[256]; /* Widths of first 256 chars in this font. */ +} WinFont; +# endif /* TOGL_WGL */ + + +# define MAX_FONTS 1000 +static GLuint ListBase[MAX_FONTS]; +static GLuint ListCount[MAX_FONTS]; + + + +/* + * Load the named bitmap font as a sequence of bitmaps in a display list. + * fontname may be one of the predefined fonts like TOGL_BITMAP_8_BY_13 + * or an X font name, or a Windows font name, etc. + */ +GLuint +Togl_LoadBitmapFont(const Togl *togl, const char *fontname) +{ + static Bool FirstTime = True; + +# if defined(TOGL_X11) + XFontStruct *fontinfo; +# elif defined(TOGL_WGL) + WinFont *winfont; + HFONT oldFont; + TEXTMETRIC tm; +# endif + /* TOGL_X11 */ + int first, last, count; + GLuint fontbase; + const char *name; + + /* Initialize the ListBase and ListCount arrays */ + if (FirstTime) { + int i; + + for (i = 0; i < MAX_FONTS; i++) { + ListBase[i] = ListCount[i] = 0; + } + FirstTime = False; + } + + /* + * This method of selecting X fonts according to a TOGL_ font name + * is a kludge. To be fixed when I find time... + */ + if (fontname == TOGL_BITMAP_8_BY_13) { + name = "8x13"; + } else if (fontname == TOGL_BITMAP_9_BY_15) { + name = "9x15"; + } else if (fontname == TOGL_BITMAP_TIMES_ROMAN_10) { + name = "-adobe-times-medium-r-normal--10-100-75-75-p-54-iso8859-1"; + } else if (fontname == TOGL_BITMAP_TIMES_ROMAN_24) { + name = "-adobe-times-medium-r-normal--24-240-75-75-p-124-iso8859-1"; + } else if (fontname == TOGL_BITMAP_HELVETICA_10) { + name = "-adobe-helvetica-medium-r-normal--10-100-75-75-p-57-iso8859-1"; + } else if (fontname == TOGL_BITMAP_HELVETICA_12) { + name = "-adobe-helvetica-medium-r-normal--12-120-75-75-p-67-iso8859-1"; + } else if (fontname == TOGL_BITMAP_HELVETICA_18) { + name = "-adobe-helvetica-medium-r-normal--18-180-75-75-p-98-iso8859-1"; + } else if (!fontname) { + name = DEFAULT_FONTNAME; + } else { + name = (const char *) fontname; + } + + assert(name); + +# if defined(TOGL_X11) + fontinfo = (XFontStruct *) XLoadQueryFont(Tk_Display(togl->TkWin), name); + if (!fontinfo) { + return 0; + } + first = fontinfo->min_char_or_byte2; + last = fontinfo->max_char_or_byte2; +# elif defined(TOGL_WGL) + winfont = (WinFont *) Tk_GetFont(togl->Interp, togl->TkWin, name); + if (!winfont) { + return 0; + } + oldFont = SelectObject(togl->tglGLHdc, winfont->hFont); + GetTextMetrics(togl->tglGLHdc, &tm); + first = tm.tmFirstChar; + last = tm.tmLastChar; +# elif defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + first = 10; /* don't know how to determine font range on + * Mac... */ + last = 127; +# endif + /* TOGL_X11 */ + + count = last - first + 1; + fontbase = glGenLists((GLuint) (last + 1)); + if (fontbase == 0) { +# ifdef TOGL_WGL + SelectObject(togl->tglGLHdc, oldFont); + Tk_FreeFont((Tk_Font) winfont); +# endif + /* TOGL_WGL */ + return 0; + } +# if defined(TOGL_WGL) + wglUseFontBitmaps(togl->tglGLHdc, first, count, (int) fontbase + first); + SelectObject(togl->tglGLHdc, oldFont); + Tk_FreeFont((Tk_Font) winfont); +# elif defined(TOGL_X11) + glXUseXFont(fontinfo->fid, first, count, (int) fontbase + first); +# elif defined(TOGL_AGL_CLASSIC) || defined(TOGL_AGL) + aglUseFont(togl->aglCtx, 1, 0, 14, /* for now, only app font, regular + * 14-point */ + 10, 118, fontbase + first); +# endif + + /* Record the list base and number of display lists for + * Togl_UnloadBitmapFont(). */ + { + int i; + + for (i = 0; i < MAX_FONTS; i++) { + if (ListBase[i] == 0) { + ListBase[i] = fontbase; + ListCount[i] = last + 1; + break; + } + } + } + + return fontbase; +} + + + +/* + * Release the display lists which were generated by Togl_LoadBitmapFont(). + */ +void +Togl_UnloadBitmapFont(const Togl *togl, GLuint fontbase) +{ + int i; + + (void) togl; + for (i = 0; i < MAX_FONTS; i++) { + if (ListBase[i] == fontbase) { + glDeleteLists(ListBase[i], ListCount[i]); + ListBase[i] = ListCount[i] = 0; + return; + } + } +} + +#endif /* TOGL_USE_FONTS */ + + +/* + * Overlay functions + */ + + +void +Togl_UseLayer(Togl *togl, int layer) +{ + if (!togl->OverlayWindow) + return; + if (layer == TOGL_OVERLAY) { +#if defined(TOGL_WGL) + int res = wglMakeCurrent(togl->tglGLHdc, togl->tglGLOverlayHglrc); + + assert(res == TRUE); +#elif defined(TOGL_X11) + (void) glXMakeCurrent(Tk_Display(togl->TkWin), + togl->OverlayWindow, togl->OverlayCtx); +# if defined(__sgi) + if (togl->OldStereoFlag) + oldStereoMakeCurrent(Tk_Display(togl->TkWin), + togl->OverlayWindow, togl->OverlayCtx); +# endif + /* __sgi STEREO */ +#endif /* TOGL_WGL */ + } else if (layer == TOGL_NORMAL) { +#if defined(TOGL_WGL) + int res = wglMakeCurrent(togl->tglGLHdc, togl->tglGLHglrc); + + assert(res == TRUE); +#elif defined(TOGL_X11) + (void) glXMakeCurrent(Tk_Display(togl->TkWin), + Tk_WindowId(togl->TkWin), togl->GlCtx); +# if defined(__sgi) + if (togl->OldStereoFlag) + oldStereoMakeCurrent(Tk_Display(togl->TkWin), + Tk_WindowId(togl->TkWin), togl->GlCtx); +# endif + /* __sgi STEREO */ +#endif /* TOGL_WGL */ + } else { + /* error */ + } +} + + +void +Togl_ShowOverlay(Togl *togl) +{ +#if defined(TOGL_X11) /* not yet implemented on Windows */ + if (togl->OverlayWindow) { + (void) XMapWindow(Tk_Display(togl->TkWin), togl->OverlayWindow); + (void) XInstallColormap(Tk_Display(togl->TkWin), togl->OverlayCmap); + togl->OverlayIsMapped = True; + } +#endif /* TOGL_X11 */ +} + + +void +Togl_HideOverlay(Togl *togl) +{ + if (togl->OverlayWindow && togl->OverlayIsMapped) { + (void) XUnmapWindow(Tk_Display(togl->TkWin), togl->OverlayWindow); + togl->OverlayIsMapped = False; + } +} + + +void +Togl_PostOverlayRedisplay(Togl *togl) +{ + if (!togl->OverlayUpdatePending + && togl->OverlayWindow && togl->OverlayDisplayProc) { + Tk_DoWhenIdle(RenderOverlay, (ClientData) togl); + togl->OverlayUpdatePending = True; + } +} + + +void +Togl_OverlayDisplayFunc(Togl_Callback *proc) +{ + DefaultOverlayDisplayProc = proc; +} + + +int +Togl_ExistsOverlay(const Togl *togl) +{ + return togl->OverlayFlag; +} + + +int +Togl_GetOverlayTransparentValue(const Togl *togl) +{ + return togl->OverlayTransparentPixel; +} + + +int +Togl_IsMappedOverlay(const Togl *togl) +{ + return togl->OverlayFlag && togl->OverlayIsMapped; +} + + +unsigned long +Togl_AllocColorOverlay(const Togl *togl, float red, float green, float blue) +{ +#if defined(TOGL_X11) /* not yet implemented on Windows */ + if (togl->OverlayFlag && togl->OverlayCmap) { + XColor xcol; + + xcol.red = (short) (red * 65535.0); + xcol.green = (short) (green * 65535.0); + xcol.blue = (short) (blue * 65535.0); + if (!XAllocColor(Tk_Display(togl->TkWin), togl->OverlayCmap, &xcol)) + return (unsigned long) -1; + return xcol.pixel; + } +#endif /* TOGL_X11 */ + return (unsigned long) -1; +} + + +void +Togl_FreeColorOverlay(const Togl *togl, unsigned long pixel) +{ +#if defined(TOGL_X11) /* not yet implemented on Windows */ + if (togl->OverlayFlag && togl->OverlayCmap) { + (void) XFreeColors(Tk_Display(togl->TkWin), togl->OverlayCmap, &pixel, + 1, 0); + } +#endif /* TOGL_X11 */ +} + + +/* + * User client data + */ + +void +Togl_ClientData(ClientData clientData) +{ + DefaultClientData = clientData; +} + + +ClientData +Togl_GetClientData(const Togl *togl) +{ + return togl->Client_Data; +} + + +void +Togl_SetClientData(Togl *togl, ClientData clientData) +{ + togl->Client_Data = clientData; +} + + +/* + * X11-only functions + * Contributed by Miguel A. De Riera Pasenau (miguel@DALILA.UPC.ES) + */ + +Display * +Togl_Display(const Togl *togl) +{ + return Tk_Display(togl->TkWin); +} + +Screen * +Togl_Screen(const Togl *togl) +{ + return Tk_Screen(togl->TkWin); +} + +int +Togl_ScreenNumber(const Togl *togl) +{ + return Tk_ScreenNumber(togl->TkWin); +} + +Colormap +Togl_Colormap(const Togl *togl) +{ + return Tk_Colormap(togl->TkWin); +} + + + +#ifdef MESA_COLOR_HACK +/* + * Let's know how many free colors do we have + */ +# if 0 +static unsigned char rojo[] = { 4, 39, 74, 110, 145, 181, 216, 251 }, verde[] = { +4, 39, 74, 110, 145, 181, 216, 251}, azul[] = { +4, 39, 74, 110, 145, 181, 216, 251}; + +unsigned char rojo[] = { 4, 36, 72, 109, 145, 182, 218, 251 }, verde[] = { +4, 36, 72, 109, 145, 182, 218, 251}, azul[] = { +4, 36, 72, 109, 145, 182, 218, 251}; + +azul[] = { +0, 85, 170, 255}; +# endif + +# define RLEVELS 5 +# define GLEVELS 9 +# define BLEVELS 5 + +/* to free dithered_rgb_colormap pixels allocated by Mesa */ +static unsigned long *ToglMesaUsedPixelCells = NULL; +static int ToglMesaUsedFreeCells = 0; + +static int +get_free_color_cells(Display *display, int screen, Colormap colormap) +{ + if (!ToglMesaUsedPixelCells) { + XColor xcol; + int i; + int colorsfailed, ncolors = XDisplayCells(display, screen); + + long r, g, b; + + ToglMesaUsedPixelCells = + (unsigned long *) calloc(ncolors, sizeof (unsigned long)); + + /* Allocate X colors and initialize color_table[], red_table[], etc */ + /* de Mesa 2.1: xmesa1.c setup_dithered_(...) */ + i = colorsfailed = 0; + for (r = 0; r < RLEVELS; r++) + for (g = 0; g < GLEVELS; g++) + for (b = 0; b < BLEVELS; b++) { + int exact; + + xcol.red = (r * 65535) / (RLEVELS - 1); + xcol.green = (g * 65535) / (GLEVELS - 1); + xcol.blue = (b * 65535) / (BLEVELS - 1); + noFaultXAllocColor(display, colormap, ncolors, + &xcol, &exact); + ToglMesaUsedPixelCells[i++] = xcol.pixel; + if (!exact) { + colorsfailed++; + } + } + ToglMesaUsedFreeCells = i; + + XFreeColors(display, colormap, ToglMesaUsedPixelCells, + ToglMesaUsedFreeCells, 0x00000000); + } + return ToglMesaUsedFreeCells; +} + + +static void +free_default_color_cells(Display *display, Colormap colormap) +{ + if (ToglMesaUsedPixelCells) { + XFreeColors(display, colormap, ToglMesaUsedPixelCells, + ToglMesaUsedFreeCells, 0x00000000); + free(ToglMesaUsedPixelCells); + ToglMesaUsedPixelCells = NULL; + ToglMesaUsedFreeCells = 0; + } +} +#endif + + +/* + * Generate EPS file. + * Contributed by Miguel A. De Riera Pasenau (miguel@DALILA.UPC.ES) + */ + +/* Function that creates a EPS File from a created pixmap on the current + * context. Based on the code from Copyright (c) Mark J. Kilgard, 1996. + * Parameters: name_file, b&w / Color flag, redraw function. The redraw + * function is needed in order to draw things into the new created pixmap. */ + +/* Copyright (c) Mark J. Kilgard, 1996. */ + +static GLvoid * +grabPixels(int inColor, unsigned int width, unsigned int height) +{ + GLvoid *buffer; + GLint swapbytes, lsbfirst, rowlength; + GLint skiprows, skippixels, alignment; + GLenum format; + unsigned int size; + + if (inColor) { + format = GL_RGB; + size = width * height * 3; + } else { + format = GL_LUMINANCE; + size = width * height * 1; + } + + buffer = (GLvoid *) malloc(size); + if (buffer == NULL) + return NULL; + + /* Save current modes. */ + glGetIntegerv(GL_PACK_SWAP_BYTES, &swapbytes); + glGetIntegerv(GL_PACK_LSB_FIRST, &lsbfirst); + glGetIntegerv(GL_PACK_ROW_LENGTH, &rowlength); + glGetIntegerv(GL_PACK_SKIP_ROWS, &skiprows); + glGetIntegerv(GL_PACK_SKIP_PIXELS, &skippixels); + glGetIntegerv(GL_PACK_ALIGNMENT, &alignment); + /* Little endian machines (DEC Alpha for example) could benefit from + * setting GL_PACK_LSB_FIRST to GL_TRUE instead of GL_FALSE, but this would + * * * * * * * * * require changing the generated bitmaps too. */ + glPixelStorei(GL_PACK_SWAP_BYTES, GL_FALSE); + glPixelStorei(GL_PACK_LSB_FIRST, GL_FALSE); + glPixelStorei(GL_PACK_ROW_LENGTH, 0); + glPixelStorei(GL_PACK_SKIP_ROWS, 0); + glPixelStorei(GL_PACK_SKIP_PIXELS, 0); + glPixelStorei(GL_PACK_ALIGNMENT, 1); + + /* Actually read the pixels. */ + glReadPixels(0, 0, width, height, format, + GL_UNSIGNED_BYTE, (GLvoid *) buffer); + + /* Restore saved modes. */ + glPixelStorei(GL_PACK_SWAP_BYTES, swapbytes); + glPixelStorei(GL_PACK_LSB_FIRST, lsbfirst); + glPixelStorei(GL_PACK_ROW_LENGTH, rowlength); + glPixelStorei(GL_PACK_SKIP_ROWS, skiprows); + glPixelStorei(GL_PACK_SKIP_PIXELS, skippixels); + glPixelStorei(GL_PACK_ALIGNMENT, alignment); + return buffer; +} + + +static int +generateEPS(const char *filename, int inColor, + unsigned int width, unsigned int height) +{ + FILE *fp; + GLvoid *pixels; + unsigned char *curpix; + unsigned int components, i; + int pos; + unsigned int bitpixel; + + pixels = grabPixels(inColor, width, height); + if (pixels == NULL) + return 1; + if (inColor) + components = 3; /* Red, green, blue. */ + else + components = 1; /* Luminance. */ + + fp = fopen(filename, "w"); + if (fp == NULL) { + return 2; + } + (void) fprintf(fp, "%%!PS-Adobe-2.0 EPSF-1.2\n"); + (void) fprintf(fp, "%%%%Creator: OpenGL pixmap render output\n"); + (void) fprintf(fp, "%%%%BoundingBox: 0 0 %d %d\n", width, height); + (void) fprintf(fp, "%%%%EndComments\n"); + + i = (((width * height) + 7) / 8) / 40; /* # of lines, 40 bytes per + * line */ + (void) fprintf(fp, "%%%%BeginPreview: %d %d %d %d\n%%", width, height, 1, + i); + pos = 0; + curpix = (unsigned char *) pixels; + for (i = 0; i < width * height * components;) { + bitpixel = 0; + if (inColor) { + double pix = 0; + + pix = 0.30 * (double) curpix[i] + 0.59 * (double) curpix[i + 1] + + 0.11 * (double) curpix[i + 2]; + i += 3; + if (pix > 127.0) + bitpixel |= 0x80; + pix = 0.30 * (double) curpix[i] + 0.59 * (double) curpix[i + 1] + + 0.11 * (double) curpix[i + 2]; + i += 3; + if (pix > 127.0) + bitpixel |= 0x40; + pix = 0.30 * (double) curpix[i] + 0.59 * (double) curpix[i + 1] + + 0.11 * (double) curpix[i + 2]; + i += 3; + if (pix > 127.0) + bitpixel |= 0x20; + pix = 0.30 * (double) curpix[i] + 0.59 * (double) curpix[i + 1] + + 0.11 * (double) curpix[i + 2]; + i += 3; + if (pix > 127.0) + bitpixel |= 0x10; + pix = 0.30 * (double) curpix[i] + 0.59 * (double) curpix[i + 1] + + 0.11 * (double) curpix[i + 2]; + i += 3; + if (pix > 127.0) + bitpixel |= 0x08; + pix = 0.30 * (double) curpix[i] + 0.59 * (double) curpix[i + 1] + + 0.11 * (double) curpix[i + 2]; + i += 3; + if (pix > 127.0) + bitpixel |= 0x04; + pix = 0.30 * (double) curpix[i] + 0.59 * (double) curpix[i + 1] + + 0.11 * (double) curpix[i + 2]; + i += 3; + if (pix > 127.0) + bitpixel |= 0x02; + pix = 0.30 * (double) curpix[i] + 0.59 * (double) curpix[i + 1] + + 0.11 * (double) curpix[i + 2]; + i += 3; + if (pix > 127.0) + bitpixel |= 0x01; + } else { + if (curpix[i++] > 0x7f) + bitpixel |= 0x80; + if (curpix[i++] > 0x7f) + bitpixel |= 0x40; + if (curpix[i++] > 0x7f) + bitpixel |= 0x20; + if (curpix[i++] > 0x7f) + bitpixel |= 0x10; + if (curpix[i++] > 0x7f) + bitpixel |= 0x08; + if (curpix[i++] > 0x7f) + bitpixel |= 0x04; + if (curpix[i++] > 0x7f) + bitpixel |= 0x02; + if (curpix[i++] > 0x7f) + bitpixel |= 0x01; + } + (void) fprintf(fp, "%02x", bitpixel); + if (++pos >= 40) { + (void) fprintf(fp, "\n%%"); + pos = 0; + } + } + if (pos) + (void) fprintf(fp, "\n%%%%EndPreview\n"); + else + (void) fprintf(fp, "%%EndPreview\n"); + + (void) fprintf(fp, "gsave\n"); + (void) fprintf(fp, "/bwproc {\n"); + (void) fprintf(fp, " rgbproc\n"); + (void) fprintf(fp, " dup length 3 idiv string 0 3 0\n"); + (void) fprintf(fp, " 5 -1 roll {\n"); + (void) fprintf(fp, " add 2 1 roll 1 sub dup 0 eq\n"); + (void) fprintf(fp, " { pop 3 idiv 3 -1 roll dup 4 -1 roll dup\n"); + (void) fprintf(fp, " 3 1 roll 5 -1 roll put 1 add 3 0 }\n"); + (void) fprintf(fp, " { 2 1 roll } ifelse\n"); + (void) fprintf(fp, " } forall\n"); + (void) fprintf(fp, " pop pop pop\n"); + (void) fprintf(fp, "} def\n"); + (void) fprintf(fp, "systemdict /colorimage known not {\n"); + (void) fprintf(fp, " /colorimage {\n"); + (void) fprintf(fp, " pop\n"); + (void) fprintf(fp, " pop\n"); + (void) fprintf(fp, " /rgbproc exch def\n"); + (void) fprintf(fp, " { bwproc } image\n"); + (void) fprintf(fp, " } def\n"); + (void) fprintf(fp, "} if\n"); + (void) fprintf(fp, "/picstr %d string def\n", width * components); + (void) fprintf(fp, "%d %d scale\n", width, height); + (void) fprintf(fp, "%d %d %d\n", width, height, 8); + (void) fprintf(fp, "[%d 0 0 %d 0 0]\n", width, height); + (void) fprintf(fp, "{currentfile picstr readhexstring pop}\n"); + (void) fprintf(fp, "false %d\n", components); + (void) fprintf(fp, "colorimage\n"); + + curpix = (unsigned char *) pixels; + pos = 0; + for (i = width * height * components; i != 0; i--) { + (void) fprintf(fp, "%02hx", *curpix++); + if (++pos >= 40) { + (void) fprintf(fp, "\n"); + pos = 0; + } + } + if (pos) + (void) fprintf(fp, "\n"); + + (void) fprintf(fp, "grestore\n"); + free(pixels); + if (fclose(fp) != 0) + return 1; + return 0; +} + + +/* int Togl_DumpToEpsFile( const Togl *togl, const char *filename, int inColor, + * void (*user_redraw)(void)) */ +/* changed by GG */ +int +Togl_DumpToEpsFile(const Togl *togl, const char *filename, + int inColor, void (*user_redraw) (const Togl *)) +{ + Bool using_mesa = False; + +#if 0 + Pixmap eps_pixmap; + GLXPixmap eps_glxpixmap; + XVisualInfo *vi = togl->VisInfo; + Window win = Tk_WindowId(togl->TkWin); +#endif + int retval; + unsigned int width = togl->Width, height = togl->Height; + +#if defined(TOGL_X11) + Display *dpy = Tk_Display(togl->TkWin); + int scrnum = Tk_ScreenNumber(togl->TkWin); + + if (strstr(glXQueryServerString(dpy, scrnum, GLX_VERSION), "Mesa")) + using_mesa = True; + else +#endif /* TOGL_X11 */ + using_mesa = False; + /* I don't use Pixmap do drawn into, because the code should link with Mesa + * libraries and OpenGL libraries, and the which library we use at run time + * should not matter, but the name of the calls differs one from another: + * MesaGl: glXCreateGLXPixmapMESA( dpy, vi, eps_pixmap, + * Tk_Colormap(togl->TkWin)) OpenGl: glXCreateGLXPixmap( dpy, vi, + * eps_pixmap); instead of this I read direct from back buffer of the + * screeen. */ +#if 0 + eps_pixmap = XCreatePixmap(dpy, win, width, height, vi->depth); + if (using_mesa) + eps_glxpixmap = + glXCreateGLXPixmapMESA(dpy, vi, eps_pixmap, + Tk_Colormap(togl->TkWin)); + else + eps_glxpixmap = glXCreateGLXPixmap(dpy, vi, eps_pixmap); + + glXMakeCurrent(dpy, eps_glxpixmap, togl->GlCtx); + user_redraw(); +#endif + if (!togl->RgbaFlag) { + +#if defined(TOGL_WGL) + /* Due to the lack of a unique inverse mapping from the frame buffer to + * the logical palette we need a translation map from the complete + * logical palette. */ + { + int n, i; + TkWinColormap *cmap = (TkWinColormap *) Tk_Colormap(togl->TkWin); + LPPALETTEENTRY entry = + malloc(togl->EpsMapSize * sizeof (PALETTEENTRY)); + n = GetPaletteEntries(cmap->palette, 0, togl->EpsMapSize, entry); + for (i = 0; i < n; i++) { + togl->EpsRedMap[i] = (GLfloat) (entry[i].peRed / 255.0); + togl->EpsGreenMap[i] = (GLfloat) (entry[i].peGreen / 255.0); + togl->EpsBlueMap[i] = (GLfloat) (entry[i].peBlue / 255.0); + } + free(entry); + } +#endif /* TOGL_WGL */ + + glPixelMapfv(GL_PIXEL_MAP_I_TO_R, togl->EpsMapSize, togl->EpsRedMap); + glPixelMapfv(GL_PIXEL_MAP_I_TO_G, togl->EpsMapSize, togl->EpsGreenMap); + glPixelMapfv(GL_PIXEL_MAP_I_TO_B, togl->EpsMapSize, togl->EpsBlueMap); + } + /* user_redraw(); */ + user_redraw(togl); /* changed by GG */ + /* glReadBuffer( GL_FRONT); */ + /* by default it read GL_BACK in double buffer mode */ + glFlush(); + retval = generateEPS(filename, inColor, width, height); +#if 0 + glXMakeCurrent(dpy, win, togl->GlCtx); + glXDestroyGLXPixmap(dpy, eps_glxpixmap); + XFreePixmap(dpy, eps_pixmap); +#endif + return retval; +} + +/* + * Full screen stereo for SGI graphics + * Contributed by Ben Evans (Ben.Evans@anusf.anu.edu.au) + * This code was based on SGI's /usr/share/src/OpenGL/teach/stereo + */ + +#if defined(__sgi) + +static struct stereoStateRec +{ + Bool useSGIStereo; + Display *currentDisplay; + Window currentWindow; + GLXContext currentContext; + GLenum currentDrawBuffer; + int currentStereoBuffer; + Bool enabled; + char *stereoCommand; + char *restoreCommand; +} stereo; + +/* call instead of glDrawBuffer */ +void +Togl_OldStereoDrawBuffer(GLenum mode) +{ + if (stereo.useSGIStereo) { + stereo.currentDrawBuffer = mode; + switch (mode) { + case GL_FRONT: + case GL_BACK: + case GL_FRONT_AND_BACK: + /* + ** Simultaneous drawing to both left and right buffers isn't + ** really possible if we don't have a stereo capable visual. + ** For now just fall through and use the left buffer. + */ + case GL_LEFT: + case GL_FRONT_LEFT: + case GL_BACK_LEFT: + stereo.currentStereoBuffer = STEREO_BUFFER_LEFT; + break; + case GL_RIGHT: + case GL_FRONT_RIGHT: + stereo.currentStereoBuffer = STEREO_BUFFER_RIGHT; + mode = GL_FRONT; + break; + case GL_BACK_RIGHT: + stereo.currentStereoBuffer = STEREO_BUFFER_RIGHT; + mode = GL_BACK; + break; + default: + break; + } + if (stereo.currentDisplay && stereo.currentWindow) { + glXWaitGL(); /* sync with GL command stream before calling X + */ + XSGISetStereoBuffer(stereo.currentDisplay, + stereo.currentWindow, stereo.currentStereoBuffer); + glXWaitX(); /* sync with X command stream before calling GL + */ + } + } + glDrawBuffer(mode); +} + +/* call instead of glClear */ +void +Togl_OldStereoClear(GLbitfield mask) +{ + GLenum drawBuffer; + + if (stereo.useSGIStereo) { + drawBuffer = stereo.currentDrawBuffer; + switch (drawBuffer) { + case GL_FRONT: + Togl_OldStereoDrawBuffer(GL_FRONT_RIGHT); + glClear(mask); + Togl_OldStereoDrawBuffer(drawBuffer); + break; + case GL_BACK: + Togl_OldStereoDrawBuffer(GL_BACK_RIGHT); + glClear(mask); + Togl_OldStereoDrawBuffer(drawBuffer); + break; + case GL_FRONT_AND_BACK: + Togl_OldStereoDrawBuffer(GL_RIGHT); + glClear(mask); + Togl_OldStereoDrawBuffer(drawBuffer); + break; + case GL_LEFT: + case GL_FRONT_LEFT: + case GL_BACK_LEFT: + case GL_RIGHT: + case GL_FRONT_RIGHT: + case GL_BACK_RIGHT: + default: + break; + } + } + glClear(mask); +} + +static void +oldStereoMakeCurrent(Display *dpy, Window win, GLXContext ctx) +{ + + if (dpy && (dpy != stereo.currentDisplay)) { + int event, error; + + /* Make sure new Display supports SGIStereo */ + if (XSGIStereoQueryExtension(dpy, &event, &error) == False) { + dpy = NULL; + } + } + if (dpy && win && (win != stereo.currentWindow)) { + /* Make sure new Window supports SGIStereo */ + if (XSGIQueryStereoMode(dpy, win) == X_STEREO_UNSUPPORTED) { + win = None; + } + } + if (ctx && (ctx != stereo.currentContext)) { + GLint drawBuffer; + + glGetIntegerv(GL_DRAW_BUFFER, &drawBuffer); + Togl_OldStereoDrawBuffer((GLenum) drawBuffer); + } + stereo.currentDisplay = dpy; + stereo.currentWindow = win; + stereo.currentContext = ctx; +} + + +/* call before using stereo */ +static void +oldStereoInit(Togl *togl, int stereoEnabled) +{ + stereo.useSGIStereo = stereoEnabled; + stereo.currentDisplay = NULL; + stereo.currentWindow = None; + stereo.currentContext = NULL; + stereo.currentDrawBuffer = GL_NONE; + stereo.currentStereoBuffer = STEREO_BUFFER_NONE; + stereo.enabled = False; +} + +#endif /* __sgi STEREO */ + + +void +Togl_StereoFrustum(GLfloat left, GLfloat right, GLfloat bottom, GLfloat top, + GLfloat zNear, GLfloat zFar, GLfloat eyeDist, GLfloat eyeOffset) +{ + GLfloat eyeShift = (eyeDist - zNear) * (eyeOffset / eyeDist); + + glFrustum(left + eyeShift, right + eyeShift, bottom, top, zNear, zFar); + glTranslatef(-eyeShift, 0, 0); +} + + +#ifdef TOGL_AGL_CLASSIC +/* needed to make shared library on Mac with CodeWarrior; should be overridden + * by user app */ +/* + * int main(int argc, char *argv[]) { return -1; } */ + +/* the following code is borrowed from tkMacAppInit.c */ + +/* + *---------------------------------------------------------------------- + * + * MacintoshInit -- + * + * This procedure calls Mac specific initilization calls. Most of + * these calls must be made as soon as possible in the startup + * process. + * + * Results: + * Returns TCL_OK if everything went fine. If it didn't the + * application should probably fail. + * + * Side effects: + * Inits the application. + * + *---------------------------------------------------------------------- + */ + +int +Togl_MacInit(void) +{ + int i; + long result, mask = 0x0700; /* mask = system 7.x */ + +# if GENERATING68K && !GENERATINGCFM + SetApplLimit(GetApplLimit() - (TK_MAC_68K_STACK_GROWTH)); +# endif + MaxApplZone(); + for (i = 0; i < 4; i++) { + (void) MoreMasters(); + } + + /* + * Tk needs us to set the qd pointer it uses. This is needed + * so Tk doesn't have to assume the availablity of the qd global + * variable. Which in turn allows Tk to be used in code resources. + */ + tcl_macQdPtr = &qd; + + /* + * If appearance is present, then register Tk as an Appearance client + * This means that the mapping from non-Appearance to Appearance cdefs + * will be done for Tk regardless of the setting in the Appearance + * control panel. + */ + if (TkMacHaveAppearance()) { + RegisterAppearanceClient(); + } + + InitGraf(&tcl_macQdPtr->thePort); + InitFonts(); + InitWindows(); + InitMenus(); + InitDialogs((long) NULL); + InitCursor(); + + /* + * Make sure we are running on system 7 or higher + */ + if ((NGetTrapAddress(_Gestalt, ToolTrap) == + NGetTrapAddress(_Unimplemented, ToolTrap)) + || (((Gestalt(gestaltSystemVersion, &result) != noErr) + || (result < mask)))) { + panic("Tcl/Tk requires System 7 or higher."); + } + + /* + * Make sure we have color quick draw + * (this means we can't run on 68000 macs) + */ + if (((Gestalt(gestaltQuickdrawVersion, &result) != noErr) + || (result < gestalt32BitQD13))) { + panic("Tk requires Color QuickDraw."); + } + + FlushEvents(everyEvent, 0); + SetEventMask(everyEvent); + + Tcl_MacSetEventProc(TkMacConvertEvent); + return TCL_OK; +} + +int +Togl_MacSetupMainInterp(Tcl_Interp *interp) +{ + TkMacInitAppleEvents(interp); + TkMacInitMenus(interp); + return TCL_OK; +} + +#endif /* TOGL_AGL_CLASSIC */ diff --git a/Togl/src/Togl/togl.h b/Togl/src/Togl/togl.h new file mode 100644 index 0000000..35e4043 --- /dev/null +++ b/Togl/src/Togl/togl.h @@ -0,0 +1,243 @@ +/* $Id: togl.h,v 1.28 2005/10/27 07:45:48 gregcouch Exp $ */ + +/* vi:set sw=4: */ + +/* + * Togl - a Tk OpenGL widget + * + * Copyright (C) 1996-1998 Brian Paul and Ben Bederson + * See the LICENSE file for copyright details. + */ + + +#ifndef TOGL_H +# define TOGL_H + +/* Define the window system in Makefile.config */ +/* # include "togl_ws.h" */ + +# ifdef TOGL_WGL +# define WIN32_LEAN_AND_MEAN +# include +# undef WIN32_LEAN_AND_MEAN +# if defined(_MSC_VER) +# define DllEntryPoint DllMain +# endif +# endif + +# ifdef _WIN32 +# define TOGL_EXTERN __declspec(dllexport) extern +# else +# define TOGL_EXTERN extern +# endif /* _WIN32 */ + +# ifdef TOGL_AGL_CLASSIC +# ifndef MAC_TCL +# define MAC_TCL 1 +# endif +# endif + +# ifdef TOGL_AGL +# ifndef MAC_OSX_TCL +# define MAC_OSX_TCL 1 +# endif +# ifndef MAC_OSX_TK +# define MAC_OSX_TK 1 +# endif +# endif + +# include +# include +# if defined(TOGL_AGL) || defined(TOGL_AGL_CLASSIC) +# include +# else +# include +# endif + +# ifdef __sgi +# include +# include +# endif + +# ifndef CONST84 +# define CONST84 +# endif + +# ifndef NULL +# define NULL 0 +# endif + +# ifndef TOGL_USE_FONTS +# define TOGL_USE_FONTS 1 /* needed for demos */ +# endif + +# ifdef __cplusplus +/* *INDENT-OFF* */ +extern "C" { +/* *INDENT-ON* */ +# endif + +# define TOGL_VERSION "1.7" +# define TOGL_MAJOR_VERSION 1 +# define TOGL_MINOR_VERSION 7 + +/* + * "Standard" fonts which can be specified to Togl_LoadBitmapFont() + */ +# define TOGL_BITMAP_8_BY_13 ((char *) 1) +# define TOGL_BITMAP_9_BY_15 ((char *) 2) +# define TOGL_BITMAP_TIMES_ROMAN_10 ((char *) 3) +# define TOGL_BITMAP_TIMES_ROMAN_24 ((char *) 4) +# define TOGL_BITMAP_HELVETICA_10 ((char *) 5) +# define TOGL_BITMAP_HELVETICA_12 ((char *) 6) +# define TOGL_BITMAP_HELVETICA_18 ((char *) 7) + +/* + * Normal and overlay plane constants + */ +# define TOGL_NORMAL 1 +# define TOGL_OVERLAY 2 + +struct Togl; +typedef struct Togl Togl; + +typedef void (Togl_Callback) (Togl *togl); +typedef int (Togl_CmdProc) (Togl *togl, int argc, CONST84 char *argv[]); + +TOGL_EXTERN int Togl_Init(Tcl_Interp *interp); + +/* + * Default/initial callback setup functions + */ + +TOGL_EXTERN void Togl_CreateFunc(Togl_Callback *proc); +TOGL_EXTERN void Togl_DisplayFunc(Togl_Callback *proc); +TOGL_EXTERN void Togl_ReshapeFunc(Togl_Callback *proc); +TOGL_EXTERN void Togl_DestroyFunc(Togl_Callback *proc); +TOGL_EXTERN void Togl_TimerFunc(Togl_Callback *proc); +TOGL_EXTERN void Togl_ResetDefaultCallbacks(void); + +/* + * Change callbacks for existing widget + */ + +TOGL_EXTERN void Togl_SetCreateFunc(Togl *togl, Togl_Callback *proc); +TOGL_EXTERN void Togl_SetDisplayFunc(Togl *togl, Togl_Callback *proc); +TOGL_EXTERN void Togl_SetReshapeFunc(Togl *togl, Togl_Callback *proc); +TOGL_EXTERN void Togl_SetDestroyFunc(Togl *togl, Togl_Callback *proc); +TOGL_EXTERN void Togl_SetTimerFunc(Togl *togl, Togl_Callback *proc); + +/* + * Miscellaneous + */ + +TOGL_EXTERN int Togl_Configure(Tcl_Interp *interp, Togl *togl, + int argc, const char *argv[], int flags); +TOGL_EXTERN void Togl_MakeCurrent(const Togl *togl); +TOGL_EXTERN void Togl_CreateCommand(char *cmd_name, Togl_CmdProc *cmd_proc); +TOGL_EXTERN void Togl_PostRedisplay(Togl *togl); +TOGL_EXTERN void Togl_SwapBuffers(const Togl *togl); + +/* + * Query functions + */ + +TOGL_EXTERN const char *Togl_Ident(const Togl *togl); +TOGL_EXTERN int Togl_Width(const Togl *togl); +TOGL_EXTERN int Togl_Height(const Togl *togl); +TOGL_EXTERN Tcl_Interp *Togl_Interp(const Togl *togl); +TOGL_EXTERN Tk_Window Togl_TkWin(const Togl *togl); + +/* + * Color Index mode + */ + +TOGL_EXTERN unsigned long Togl_AllocColor(const Togl *togl, float red, + float green, float blue); +TOGL_EXTERN void Togl_FreeColor(const Togl *togl, unsigned long index); +TOGL_EXTERN void Togl_SetColor(const Togl *togl, unsigned long index, + float red, float green, float blue); + +# if TOGL_USE_FONTS == 1 +/* + * Bitmap fonts + */ + +TOGL_EXTERN GLuint Togl_LoadBitmapFont(const Togl *togl, const char *fontname); +TOGL_EXTERN void Togl_UnloadBitmapFont(const Togl *togl, GLuint fontbase); + +# endif +/* + * Overlay functions + */ + +TOGL_EXTERN void Togl_UseLayer(Togl *togl, int layer); +TOGL_EXTERN void Togl_ShowOverlay(Togl *togl); +TOGL_EXTERN void Togl_HideOverlay(Togl *togl); +TOGL_EXTERN void Togl_PostOverlayRedisplay(Togl *togl); +TOGL_EXTERN void Togl_OverlayDisplayFunc(Togl_Callback *proc); +TOGL_EXTERN int Togl_ExistsOverlay(const Togl *togl); +TOGL_EXTERN int Togl_GetOverlayTransparentValue(const Togl *togl); +TOGL_EXTERN int Togl_IsMappedOverlay(const Togl *togl); +TOGL_EXTERN unsigned long Togl_AllocColorOverlay(const Togl *togl, + float red, float green, float blue); +TOGL_EXTERN void Togl_FreeColorOverlay(const Togl *togl, unsigned long index); + +/* + * User client data + */ + +TOGL_EXTERN void Togl_ClientData(ClientData clientData); +TOGL_EXTERN ClientData Togl_GetClientData(const Togl *togl); +TOGL_EXTERN void Togl_SetClientData(Togl *togl, ClientData clientData); + +# ifdef TOGL_X11 +/* + * X11-only commands. + * Contributed by Miguel A. De Riera Pasenau (miguel@DALILA.UPC.ES) + */ + +TOGL_EXTERN Display *Togl_Display(const Togl *togl); +TOGL_EXTERN Screen *Togl_Screen(const Togl *togl); +TOGL_EXTERN int Togl_ScreenNumber(const Togl *togl); +TOGL_EXTERN Colormap Togl_Colormap(const Togl *togl); + +# endif +# ifdef __sgi +/* + * SGI stereo-only commands. + * Contributed by Ben Evans (Ben.Evans@anusf.anu.edu.au) + */ + +TOGL_EXTERN void Togl_OldStereoDrawBuffer(GLenum mode); +TOGL_EXTERN void Togl_OldStereoClear(GLbitfield mask); +# endif + +TOGL_EXTERN void Togl_StereoFrustum(GLfloat left, GLfloat right, GLfloat bottom, + GLfloat top, GLfloat near, GLfloat far, GLfloat eyeDist, + GLfloat eyeOffset); + +/* + * Generate EPS file. + * Contributed by Miguel A. De Riera Pasenau (miguel@DALILA.UPC.ES) + */ + +TOGL_EXTERN int Togl_DumpToEpsFile(const Togl *togl, const char *filename, + int inColor, void (*user_redraw) (const Togl *)); + +# ifdef TOGL_AGL_CLASSIC +/* + * Mac-specific setup functions + */ +extern int Togl_MacInit(void); +extern int Togl_MacSetupMainInterp(Tcl_Interp *interp); +# endif + +# ifdef __cplusplus +/* *INDENT-OFF* */ +} +/* *INDENT-ON* */ +# endif + + +#endif diff --git a/Togl/src/Togl/tree2.rgba b/Togl/src/Togl/tree2.rgba new file mode 100644 index 0000000..67b0279 Binary files /dev/null and b/Togl/src/Togl/tree2.rgba differ diff --git a/Togl/src/lablgl.bat b/Togl/src/lablgl.bat new file mode 100755 index 0000000..234ed98 --- /dev/null +++ b/Togl/src/lablgl.bat @@ -0,0 +1,2 @@ +@rem toplevel for lablgl with Togl support +ocaml -I +labltk -I +lablGL labltk.cma lablgl.cma togl.cma %1 %2 %3 %4 %5 %6 %7 %8 %9 diff --git a/Togl/src/ml_togl.c b/Togl/src/ml_togl.c new file mode 100644 index 0000000..17e2ff7 --- /dev/null +++ b/Togl/src/ml_togl.c @@ -0,0 +1,156 @@ +/* $Id: ml_togl.c,v 1.16 2006-03-23 06:01:55 garrigue Exp $ */ + +#ifdef _WIN32 +#include +#endif +#include +#ifdef __APPLE__ +#include +#else +#include +#endif +#include +#include +#include +#include +#include +#include +#include +#include "togl.h" +#include "ml_gl.h" +#include "togl_tags.h" + +/* extern Tcl_Interp *cltclinterp; */ /* The Tcl interpretor */ +/* extern void tk_error (char *message); */ /* Raise TKerror */ + +int TOGLenum_val(value tag) +{ + switch(tag) + { +#include "togl_tags.c" + } + invalid_argument ("Unknown Togl tag"); +} + +/* Avoid direct use of stderr */ +void togl_prerr(const char *msg) +{ + value ml_msg = copy_string(msg); + value *prerr = caml_named_value("togl_prerr"); + if (!prerr) caml_failwith(msg); + caml_callback_exn(*prerr, ml_msg); +} + +CAMLprim value ml_Togl_Init (value unit) /* ML */ +{ + value *interp = caml_named_value("cltclinterp"); + Tcl_Interp *cltclinterp = + (interp ? (Tcl_Interp *) Nativeint_val(Field(*interp,0)) : NULL); + if (cltclinterp == NULL || Togl_Init(cltclinterp) == TCL_ERROR) + raise_with_string(*caml_named_value("tkerror"), "Togl_Init failed"); + return Val_unit; +} + +/* Does not register the structure with Caml ! +static value Val_togl (struct Togl *togl) +{ + value wrapper = alloc(1,No_scan_tag); + Field(wrapper,0) = (value) togl; + return wrapper; +} +*/ + +enum { + CreateFunc = 0, + DisplayFunc, + ReshapeFunc, + DestroyFunc, + TimerFunc, + OverlayDisplayFunc, + RenderFunc, + LastFunc +}; + +static value *callbacks = NULL; + +#define CALLBACK(func) \ +static void callback_##func (struct Togl *togl) \ +{ callback (Field(*callbacks, func), Val_addr(togl)); } +#define CALLBACK_const(func) \ +static void callback_##func (const struct Togl *togl) \ +{ callback (Field(*callbacks, func), Val_addr(togl)); } + +#define ENABLER(func) \ +CAMLprim value ml_Togl_##func (value unit) \ +{ if (callbacks == NULL) callbacks = caml_named_value ("togl_callbacks"); \ + Togl_##func (callback_##func); \ + return Val_unit; } + +CALLBACK (CreateFunc) +CALLBACK (DisplayFunc) +CALLBACK (ReshapeFunc) +CALLBACK (DestroyFunc) +CALLBACK (TimerFunc) +CALLBACK (OverlayDisplayFunc) +CALLBACK_const (RenderFunc) + +ENABLER (CreateFunc) +ENABLER (DisplayFunc) +ENABLER (ReshapeFunc) +ENABLER (DestroyFunc) +ENABLER (TimerFunc) +ENABLER (OverlayDisplayFunc) + +ML_0 (Togl_ResetDefaultCallbacks) +ML_1 (Togl_PostRedisplay, Addr_val) +ML_1 (Togl_SwapBuffers, Addr_val) +ML_1_ (Togl_Ident, Addr_val, copy_string) +ML_1_ (Togl_Width, Addr_val, Val_int) +ML_1_ (Togl_Height, Addr_val, Val_int) + +CAMLprim value ml_Togl_LoadBitmapFont (value togl, value font) /* ML */ +{ + char *fontname = NULL; + + if (Is_block(font)) fontname = String_val (Field(font,0)); + else switch (font) { + case MLTAG_Fixed_8x13: fontname = TOGL_BITMAP_8_BY_13; break; + case MLTAG_Fixed_9x15: fontname = TOGL_BITMAP_9_BY_15; break; + case MLTAG_Times_10: fontname = TOGL_BITMAP_TIMES_ROMAN_10; break; + case MLTAG_Times_24: fontname = TOGL_BITMAP_TIMES_ROMAN_24; break; + case MLTAG_Helvetica_10: fontname = TOGL_BITMAP_HELVETICA_10; break; + case MLTAG_Helvetica_12: fontname = TOGL_BITMAP_HELVETICA_12; break; + case MLTAG_Helvetica_18: fontname = TOGL_BITMAP_HELVETICA_18; break; + } + return Val_int (Togl_LoadBitmapFont (Addr_val(togl), fontname)); +} + +ML_2 (Togl_UnloadBitmapFont, Addr_val, Int_val) +ML_2 (Togl_UseLayer, Addr_val, TOGLenum_val) +#ifdef _WIN32 +CAMLprim value ml_Togl_ShowOverlay(value v) +{ invalid_argument("Togl_ShowOverlay: not implemented"); return Val_unit; } +#else +ML_1 (Togl_ShowOverlay, Addr_val) +#endif +ML_1 (Togl_HideOverlay, Addr_val) +ML_1 (Togl_PostOverlayRedisplay, Addr_val) +ML_1_ (Togl_ExistsOverlay, Addr_val, Val_int) +ML_1_ (Togl_GetOverlayTransparentValue, Addr_val, Val_int) + +CAMLprim value ml_Togl_DumpToEpsFile (value togl, value filename, value rgb) +{ + if (callbacks == NULL) callbacks = caml_named_value ("togl_callbacks"); + if (Togl_DumpToEpsFile(Addr_val(togl), String_val(filename), + Int_val(rgb), callback_RenderFunc) + == TCL_ERROR) + raise_with_string(*caml_named_value("tkerror"), + "Dump to EPS file failed"); + return Val_unit; +} + +#if 0 && defined(_WIN32) && !defined(CAML_DLL) && (WINVER < 0x0500) +/* VC7 or later, building with pre-VC7 runtime libraries */ +long _ftol( double ); /* defined by VC6 C libs */ +long _ftol2( double dblSource ) { return _ftol( dblSource ); } +#endif diff --git a/Togl/src/togl.ml b/Togl/src/togl.ml new file mode 100644 index 0000000..9e7969e --- /dev/null +++ b/Togl/src/togl.ml @@ -0,0 +1,276 @@ +(* $Id: togl.ml,v 1.23 2006-03-23 00:39:27 garrigue Exp $ *) + +open StdLabels +open Tk +open Protocol + +let may x name f = + match x with None -> [] + | Some a -> [TkToken name; TkToken (f a)] + +let cbool x = if x then "1" else "0" +let cint = string_of_int +let id x = x + +let togl_options_optionals f = + fun + ?accum + ?accumalphasize + ?accumbluesize + ?accumgreensize + ?accumredsize + ?alpha + ?alphasize + ?auxbuffers + ?bluesize + ?depth + ?depthsize + ?double + ?greensize + ?height + (* ?ident *) + ?overlay + ?privatecmap + ?redsize + ?rgba + ?stencil + ?stencilsize + ?stereo + (* ?time *) + ?width + -> + f (may accum "-accum" cbool + @ may accumalphasize "-accumalphasize" cint + @ may accumbluesize "-accumbluesize" cint + @ may accumgreensize "-accumgreensize" cint + @ may accumredsize "-accumredsize" cint + @ may alpha "-alpha" cbool + @ may alphasize "-alphasize" cint + @ may auxbuffers "-auxbuffers" cint + @ may bluesize "-bluesize" cint + @ may depth "-depth" cbool + @ may depthsize "-depthsize" cint + @ may double "-double" cbool + @ may greensize "-greensize" cint + @ may height "-height" cint + (* @ may ident "-ident" id *) + @ may overlay "-overlay" cbool + @ may privatecmap "-privatecmap" cbool + @ may redsize "-redsize" cint + @ may rgba "-rgba" cbool + @ may stencil "-stencil" cbool + @ may stencilsize "-stencilsize" cint + @ may stereo "-stereo" cbool + (* @ may time "-time" cint *) + @ may width "-width" cint) + +type t + +external init : unit -> unit = "ml_Togl_Init" + +external _create_func : unit -> unit = "ml_Togl_CreateFunc" +external _display_func : unit -> unit = "ml_Togl_DisplayFunc" +external _reshape_func : unit -> unit = "ml_Togl_ReshapeFunc" +external _destroy_func : unit -> unit = "ml_Togl_DestroyFunc" +external _timer_func : unit -> unit = "ml_Togl_TimerFunc" +external _overlay_display_func : unit -> unit = "ml_Togl_OverlayDisplayFunc" + +external _reset_default_callbacks : unit -> unit + = "ml_Togl_ResetDefaultCallbacks" +external _post_redisplay : t -> unit = "ml_Togl_PostRedisplay" +external _swap_buffers : t -> unit = "ml_Togl_SwapBuffers" + +external _ident : t -> string = "ml_Togl_Ident" +external _height : t -> int = "ml_Togl_Height" +external _width : t -> int = "ml_Togl_Width" + +type font = [ + `Fixed_8x13 + | `Fixed_9x15 + | `Times_10 + | `Times_24 + | `Helvetica_10 + | `Helvetica_12 + | `Helvetica_18 + | `Xfont of string +] + +external _load_bitmap_font : t -> font:font -> GlList.base + = "ml_Togl_LoadBitmapFont" +external _unload_bitmap_font : t -> base:GlList.base -> unit + = "ml_Togl_UnloadBitmapFont" + +external _use_layer : t -> num:int -> unit = "ml_Togl_UseLayer" +external _show_overlay : t -> unit = "ml_Togl_ShowOverlay" +external _hide_overlay : t -> unit = "ml_Togl_HideOverlay" +external _post_overlay_redisplay : t -> unit = "ml_Togl_PostOverlayRedisplay" + +external _exists_overlay : t -> bool = "ml_Togl_ExistsOverlay" +external _get_overlay_transparent_value : t -> int + = "ml_Togl_GetOverlayTransparentValue" + +external _dump_to_eps_file : t -> string -> bool -> unit + = "ml_Togl_DumpToEpsFile" + +type w +type widget = w Widget.widget + +let togl_table = Hashtbl.create 7 + +let wrap f (w : widget) = + let togl = + try Hashtbl.find togl_table w + with Not_found -> raise (TkError "Unreferenced togl widget") + in f togl + +let render = wrap _post_redisplay +let swap_buffers = wrap _swap_buffers +let height = wrap _height +let width = wrap _width +let load_bitmap_font = wrap _load_bitmap_font +let unload_bitmap_font = wrap _unload_bitmap_font +let use_layer = wrap _use_layer +let show_overlay = wrap _show_overlay +let hide_overlay = wrap _hide_overlay +let overlay_redisplay = wrap _post_overlay_redisplay +let exists_overlay = wrap _exists_overlay +let get_overlay_transparent_value = wrap _get_overlay_transparent_value + +let make_current togl = + ignore (tkEval [|TkToken (Widget.name togl); TkToken "makecurrent"|]) + +let null_func _ = () +let display_table = Hashtbl.create 7 +and reshape_table = Hashtbl.create 7 +and overlay_table = Hashtbl.create 7 + +let cb_of_togl table togl = + try + let key = _ident togl in + let cb = Hashtbl.find table key in + ignore (tkEval [|TkToken key; TkToken "makecurrent"|]); + cb () + with Not_found -> () + +let create_id = 0 +and display_id = 1 +and reshape_id = 2 +and destroy_id = 3 +and timer_id = 4 +and overlay_display_id = 5 +and render_id = 6 + +let callback_table = + [|null_func; + cb_of_togl display_table; + cb_of_togl reshape_table; + null_func; + null_func; + cb_of_togl overlay_table; + null_func|] +let () = + Callback.register "togl_callbacks" callback_table; + (* Also export an error-reporting function *) + Callback.register "togl_prerr" + (fun msg -> prerr_string msg; flush stderr) + +let callback_func table (w : widget) ~cb = + let key = Widget.name w in + (try Hashtbl.remove table key with Not_found -> ()); + Hashtbl.add table key cb + +let display_func = callback_func display_table +let reshape_func w ~cb = + make_current w; cb (); + callback_func reshape_table w ~cb +let overlay_display_func = callback_func overlay_table + +let dump_to_eps_file ~filename ?(rgba=false) ?render togl = + let render = + match render with Some f -> f + | None -> + try Hashtbl.find display_table (_ident togl) + with Not_found -> + raise (TkError "Togl.dump_to_eps_file : no render function") + in + callback_table.(render_id) <- (fun _ -> render()); + _dump_to_eps_file togl filename rgba + +let dump_to_eps_file ~filename ?rgba ?render = + wrap (dump_to_eps_file ~filename ?rgba ?render) + +let rec timer_func ~ms ~cb = + ignore (Timer.add ~ms ~callback:(fun () -> cb (); timer_func ~ms ~cb)) + +let configure ?height ?width w = + let options = may height "-height" cint @ may width "-width" cint in + tkEval [|TkToken (Widget.name w); TkTokenList options|] + +(* +class widget w t = + val w : widget = w + val t = t + method widget = w + method name = coe w + method configure = configure ?w + method bind = bind w + method redisplay = post_redisplay t + method swap_buffers = swap_buffers t + method width = width t + method height = height t + method load_font = load_bitmap_font t + method unload_font = unload_bitmap_font t + method use_layer = use_layer t + method show_overlay = show_overlay t + method hide_overlay = hide_overlay t + method overlay_redisplay = post_overlay_redisplay t + method exist_overlay = exists_overlay t + method overlay_transparent_value = get_overlay_transparent_value t + method dump_to_eps_file = dump_to_eps_file t + method make_current = + tkEval [|TkToken (Widget.name w); TkToken "makecurrent"|]; () +end +*) + +let ready = ref false + +let init_togl () = + init (); + _create_func (); + _display_func (); + _reshape_func (); + _overlay_display_func (); + _destroy_func (); + ready := true + +let create ?name = + togl_options_optionals + (fun options parent -> + prerr_endline "Before init"; + if not !ready then init_togl (); + prerr_endline "After init"; + let w : widget = + Widget.new_atom "togl" ~parent ?name in + let togl = ref None in + callback_table.(create_id) <- + (fun t -> togl := Some t; Hashtbl.add togl_table w t); + callback_table.(destroy_id) <- + (fun t -> + begin try Hashtbl.remove togl_table w with Not_found -> () end; + List.iter [display_table; reshape_table; overlay_table] ~f: + begin fun tbl -> + try Hashtbl.remove tbl (Widget.name w) with Not_found -> () + end); + prerr_endline "Before create"; + let command = + [|TkToken "togl"; TkToken (Widget.name w); + TkToken "-ident"; TkToken (Widget.name w); + TkTokenList options|] in + let _res : string = + try tkEval command + with TkError "invalid command name \"togl\"" -> + raise (TkError "Togl initialization failed") + in + prerr_endline "After create"; + match !togl with None -> raise (TkError "Togl widget creation failed") + | Some t -> w) diff --git a/Togl/src/togl.mli b/Togl/src/togl.mli new file mode 100644 index 0000000..02af103 --- /dev/null +++ b/Togl/src/togl.mli @@ -0,0 +1,62 @@ +(* $Id: togl.mli,v 1.6 2000-04-03 02:57:44 garrigue Exp $ *) + +type w +type widget = w Widget.widget + +val render : widget -> unit +val swap_buffers : widget -> unit +val height : widget -> int +val width : widget -> int +type font = [ + `Fixed_8x13 + | `Fixed_9x15 + | `Times_10 + | `Times_24 + | `Helvetica_10 + | `Helvetica_12 + | `Helvetica_18 + | `Xfont of string +] +val load_bitmap_font : widget -> font:font -> GlList.base +val unload_bitmap_font : widget -> base:GlList.base -> unit +val use_layer : widget -> num:int -> unit +val show_overlay : widget -> unit +val hide_overlay : widget -> unit +val overlay_redisplay : widget -> unit +val exists_overlay : widget -> bool +val get_overlay_transparent_value : widget -> int +val make_current : widget -> unit + +val display_func : widget -> cb:(unit -> unit) -> unit +val reshape_func : widget -> cb:(unit -> unit) -> unit +val overlay_display_func : widget -> cb:(unit -> unit) -> unit + +val dump_to_eps_file : + filename:string -> ?rgba:bool -> ?render:(unit -> unit) -> widget -> unit + +val timer_func : ms:int -> cb:(unit -> unit) -> unit + +val configure : ?height:int -> ?width:int -> widget -> string + +val create : + ?name:string -> + ?accum:bool -> + ?accumalphasize:int -> + ?accumbluesize:int -> + ?accumgreensize:int -> + ?accumredsize:int -> + ?alpha:bool -> + ?alphasize:int -> + ?auxbuffers:int -> + ?bluesize:int -> + ?depth:bool -> + ?depthsize:int -> + ?double:bool -> + ?greensize:int -> + ?height:int -> + ?overlay:bool -> + ?privatecmap:bool -> + ?redsize:int -> + ?rgba:bool -> + ?stencil:bool -> + ?stencilsize:int -> ?stereo:bool -> ?width:int -> 'a Widget.widget -> widget diff --git a/Togl/src/togl_tags.var b/Togl/src/togl_tags.var new file mode 100644 index 0000000..95220a1 --- /dev/null +++ b/Togl/src/togl_tags.var @@ -0,0 +1,11 @@ +overlay +normal +$$ +Fixed_8x13 -> TOGL_BITMAP_8_BY_13 +Fixed_9x15 -> TOGL_BITMAP_9_BY_15 +Times_10 -> TOGL_BITMAP_TIMES_ROMAN_10 +Times_24 -> TOGL_BITMAP_TIMES_ROMAN_24 +Helvetica_10 -> TOGL_BITMAP_HELVETICA_10 +Helvetica_12 -> TOGL_BITMAP_HELVETICA_12 +Helvetica_18 -> TOGL_BITMAP_HELVETICA_18 +Xfont diff --git a/src/.cvsignore b/src/.cvsignore new file mode 100644 index 0000000..b2b6161 --- /dev/null +++ b/src/.cvsignore @@ -0,0 +1,18 @@ +var2def +var2switch +gl_tags.c +gl_tags.h +glu_tags.c +glu_tags.h +raw_tags.c +raw_tags.h +togl_tags.c +togl_tags.h +build.ml +lablgltop +lablgl +*.dll +*.so +*.exp +*.lib +.depend diff --git a/src/.depend b/src/.depend new file mode 100644 index 0000000..6a57ba2 --- /dev/null +++ b/src/.depend @@ -0,0 +1,63 @@ +build.cmo: +build.cmx: +gl.cmo: gl.cmi +gl.cmx: gl.cmi +glArray.cmo: raw.cmi glDraw.cmi gl.cmi glArray.cmi +glArray.cmx: raw.cmx glDraw.cmx gl.cmx glArray.cmi +glClear.cmo: gl.cmi glClear.cmi +glClear.cmx: gl.cmx glClear.cmi +glDraw.cmo: raw.cmi glPix.cmi gl.cmi glDraw.cmi +glDraw.cmx: raw.cmx glPix.cmx gl.cmx glDraw.cmi +glFunc.cmo: gl.cmi glFunc.cmi +glFunc.cmx: gl.cmx glFunc.cmi +glLight.cmo: gl.cmi glLight.cmi +glLight.cmx: gl.cmx glLight.cmi +glList.cmo: glList.cmi +glList.cmx: glList.cmi +glMap.cmo: raw.cmi glMap.cmi +glMap.cmx: raw.cmx glMap.cmi +glMat.cmo: raw.cmi glMat.cmi +glMat.cmx: raw.cmx glMat.cmi +glMisc.cmo: raw.cmi glMisc.cmi +glMisc.cmx: raw.cmx glMisc.cmi +glPix.cmo: raw.cmi gl.cmi glPix.cmi +glPix.cmx: raw.cmx gl.cmx glPix.cmi +glShader.cmo: glShader.cmi +glShader.cmx: glShader.cmi +glTex.cmo: raw.cmi glPix.cmi glMisc.cmi gl.cmi glTex.cmi +glTex.cmx: raw.cmx glPix.cmx glMisc.cmx gl.cmx glTex.cmi +gluMat.cmo: gl.cmi gluMat.cmi +gluMat.cmx: gl.cmx gluMat.cmi +gluMisc.cmo: raw.cmi glTex.cmi glPix.cmi gl.cmi gluMisc.cmi +gluMisc.cmx: raw.cmx glTex.cmx glPix.cmx gl.cmx gluMisc.cmi +gluNurbs.cmo: raw.cmi glMap.cmi gl.cmi gluNurbs.cmi +gluNurbs.cmx: raw.cmx glMap.cmx gl.cmx gluNurbs.cmi +gluQuadric.cmo: gluQuadric.cmi +gluQuadric.cmx: gluQuadric.cmi +gluTess.cmo: gluTess.cmi +gluTess.cmx: gluTess.cmi +raw.cmo: raw.cmi +raw.cmx: raw.cmi +var2def.cmo: +var2def.cmx: +var2switch.cmo: +var2switch.cmx: +gl.cmi: +glArray.cmi: raw.cmi glDraw.cmi +glClear.cmi: gl.cmi +glDraw.cmi: glPix.cmi gl.cmi +glFunc.cmi: gl.cmi +glLight.cmi: gl.cmi +glList.cmi: +glMap.cmi: raw.cmi +glMat.cmi: raw.cmi gl.cmi +glMisc.cmi: raw.cmi +glPix.cmi: raw.cmi gl.cmi +glShader.cmi: +glTex.cmi: glPix.cmi gl.cmi +gluMat.cmi: gl.cmi +gluMisc.cmi: glTex.cmi glPix.cmi gl.cmi +gluNurbs.cmi: raw.cmi glMap.cmi gl.cmi +gluQuadric.cmi: +gluTess.cmi: +raw.cmi: diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 0000000..e51fd83 --- /dev/null +++ b/src/Makefile @@ -0,0 +1,99 @@ +# Include shared parts +TOPDIR = .. +include ../Makefile.common + +# Composite options +INCLUDES = $(GLINCLUDES) $(XINCLUDES) +LIBS = $(GLLIBS) $(XLIBS) +LIBDIRS = + + +OCAMLINC=-I +labltk + +# Files +LIBOBJS = raw.cmo \ + gl.cmo glLight.cmo glList.cmo glMap.cmo \ + glMat.cmo glMisc.cmo glPix.cmo glClear.cmo \ + glTex.cmo glDraw.cmo glFunc.cmo gluMisc.cmo \ + gluNurbs.cmo gluQuadric.cmo gluTess.cmo gluMat.cmo \ + glArray.cmo glShader.cmo +MLOBJS = $(LIBOBJS) togl.cmo +OPTOBJS = $(LIBOBJS:.cmo=.cmx) +COBJS = ml_gl$(XO) ml_glu$(XO) ml_raw$(XO) ml_glarray$(XO) \ + ml_glutess$(XO) ml_shader$(XO) +TOGLOBJS = ml_togl$(XO) $(TOGLDIR)/togl$(XO) + +all: tools + $(MAKE) lablgl.cma + +opt: lablgl.cmxa + +tools: var2def$(XE) var2switch$(XE) + +var2def$(XE): var2def.ml + $(LINKER) -pp camlp4o var2def.ml -o $@ + +var2switch$(XE): var2switch.ml + $(LINKER) -pp camlp4o var2switch.ml -o $@ + +ifeq ($(TOOLCHAIN), msvc) +liblablgl$(XA): $(COBJS) + $(MKLIB)$@ $(COBJS) +dlllablgl.dll: $(COBJS:$(XO)=.d$(XO)) + $(MKDLL)$@ $(COBJS:$(XO)=.d$(XO)) $(GLLIBS) $(OCAMLDLL) +lablgl.cma: liblablgl$(XA) dlllablgl.dll $(LIBOBJS) $(CONFIG) + $(LINKER) -a -o $@ $(LIBOBJS) \ + -cclib -llablgl -dllib -llablgl \ + -cclib "$(GLLIBS)" +lablgl.cmxa: liblablgl$(XA) $(OPTOBJS) $(CONFIG) + $(OPTLINK) -a -o $@ $(OPTOBJS) -cclib -llablgl \ + -cclib "$(GLLIBS)" +else +liblablgl$(XA): lablgl.cma +lablgl.cma: $(COBJS) $(LIBOBJS) $(CONFIG) + $(LIBRARIAN) -o lablgl $(COBJS) $(LIBOBJS) $(GLLIBS) $(XLIBS) +lablgl.cmxa: $(COBJS) $(OPTOBJS) $(CONFIG) + $(LIBRARIAN) -o lablgl $(COBJS) $(OPTOBJS) $(GLLIBS) $(XLIBS) +endif + +gl_tags.c: gl_tags.var + $(VAR2SWITCH) -table GL_ < gl_tags.var > $@ + +glu_tags.c: glu_tags.var + $(VAR2SWITCH) GLU_ < glu_tags.var > $@ + +build.ml: build.ml.in ../Makefile.config + sed -e "s|@LABLGL_MLS@|$(LIBOBJS:.cmo=)|" \ + -e "s|@TOGL_MLS@|togl|" \ + -e "s|@GLUT_MLS@|glut|" \ + -e "s|@GLLIBS@|$(GLLIBS0)|" \ + -e "s|@TKLIBS@|$(TKLIBS0)|" \ + -e "s|@GLUTLIBS@|$(GLUTLIBS0)|" < build.ml.in > $@ + +preinstall: build.ml + if test -d "$(INSTALLDIR)"; then : ; else mkdir -p "$(INSTALLDIR)"; fi + cp build.ml $(LIBOBJS:.cmo=.ml) $(LIBOBJS:.cmo=.mli) "$(INSTALLDIR)" + cp liblablgl$(XA) "$(INSTALLDIR)" + cd "$(INSTALLDIR)" && $(RANLIB) liblablgl$(XA) + if test -f dlllablgl$(XS); then cp dlllablgl$(XS) "$(DLLDIR)"; fi + +install: preinstall + cp $(LIBOBJS:.cmo=.cmi) lablgl.cma "$(INSTALLDIR)" + @if test -f lablgl.cmxa; then $(MAKE) installopt; fi + +installopt: + cp lablgl.cmxa lablgl$(XA) $(LIBOBJS:.cmo=.cmx) "$(INSTALLDIR)" + cd "$(INSTALLDIR)" && $(RANLIB) lablgl$(XA) + +clean: + rm -f *.cm* *.a *.o *.so *.lib *.obj *.exe *.opt *_tags.c *_tags.h *~ \ + *.dll var2def$(XE) var2switch$(XE) lablgltop$(XE) lablgl$(XB) + +depend: + ocamldep -pp camlp4o *.ml *.mli > .depend + +#dependencies +ml_gl$(XO): ml_gl.h gl_tags.h gl_tags.c ml_raw.h +ml_glu$(XO) ml_glutess$(XO) : ml_gl.h ml_glu.h glu_tags.h glu_tags.c +ml_raw$(XO): raw_tags.h ml_raw.h +include .depend diff --git a/src/build.ml.in b/src/build.ml.in new file mode 100755 index 0000000..6f72a6f --- /dev/null +++ b/src/build.ml.in @@ -0,0 +1,128 @@ +(* $Id: build.ml.in,v 1.5 2008-12-26 07:13:21 garrigue Exp $ *) +(* A script to build lablGL libraries *) + +open StdLabels + +let ocamlc = ref "ocamlc.opt" +let ocamlopt = ref "ocamlopt.opt" +let flags = ref "-w s -I +labltk" +let ccomp_type = ref "msvc" (* "msvc" for MSVC++, "cc" for Mingw. Attempt to autodetect *) + +let split ?(sep = [' ';'\t';'\r';'\n']) s = + let len = String.length s in + let rec loop last cur acc = + if cur > len then acc else + let next = cur+1 in + if cur = len || List.mem s.[cur] sep then + if cur > last then loop next next (String.sub s ~pos:last ~len:(cur-last) :: acc) + else loop next next acc + else loop last next acc + in List.rev (loop 0 0 []) + +let lablgl_mls = split "@LABLGL_MLS@" +let togl_mls = split "@TOGL_MLS@" +let glut_mls = split "@GLUT_MLS@" +let gl_libs = "@GLLIBS@" +let tk_libs = "@TKLIBS@ " +let glut_libs = "@GLUTLIBS@ " + +(* Hack to check for mingw *) +let () = + try + let ic = open_in "../Makefile.config" in + while true do + let s = input_line ic in + match split ~sep:[' ';'\t';'='] s with + "CCOMPTYPE" :: cc :: _ -> ccomp_type := cc + | _ -> () + done + with _ -> () + +let has_mingw_import nm = + (* sufficient for now... *) + Filename.check_suffix nm "32.lib" + +let norm_libs libs = + if !ccomp_type = "msvc" then libs else + let libs = + List.map (split libs) ~f: + (fun nm -> + if has_mingw_import nm then "-l" ^ Filename.chop_extension nm + else nm) + in String.concat " " libs + +let gl_libs = norm_libs gl_libs +let tk_libs = norm_libs tk_libs +let glut_libs = norm_libs glut_libs + +let exe cmd args = + let cmd = String.concat " " (cmd :: !flags :: args) in + print_endline cmd; flush stdout; + let err = Sys.command cmd in + if err > 0 then failwith ("error "^string_of_int err) + +let may_remove f = + if Sys.file_exists f then Sys.remove f + +let byte () = + List.iter (lablgl_mls @ togl_mls @ glut_mls) ~f: + begin fun file -> + if Sys.file_exists (file ^ ".mli") then exe !ocamlc ["-c"; file^".mli"]; + exe !ocamlc ["-c"; file^".ml"] + end; + List.iter ["lablgl", lablgl_mls, gl_libs; + "togl", togl_mls, tk_libs; + "lablglut", glut_mls, glut_libs] + ~f:begin fun (lib, mls,libs) -> + let cmos = List.map mls ~f:(fun nm -> nm ^".cmo") in + exe !ocamlc (["-a -o"; lib^".cma"; "-cclib -l"^lib; "-dllib -l"^lib; + "-cclib \""^libs^"\""] @ cmos); + List.iter cmos ~f:may_remove + end + +let native () = + List.iter (lablgl_mls @ togl_mls @ glut_mls) ~f: + (fun file -> exe !ocamlopt ["-c"; file^".ml"]); + List.iter ["lablgl", lablgl_mls, gl_libs; + "togl", togl_mls, tk_libs; + "lablglut", glut_mls, glut_libs] + ~f:begin fun (lib, mls,libs) -> + let cmxs = List.map mls ~f:(fun nm -> nm ^".cmx") in + exe !ocamlopt (["-a -o"; lib^".cmxa"; "-cclib -l"^lib; + "-cclib \""^libs^"\""] @ cmxs); + List.iter mls ~f:(fun nm -> may_remove (nm ^ ".obj"); may_remove (nm ^ ".o")) + end + +let rename ~ext1 ~ext2 file = + if Sys.file_exists (file^ext1) && not (Sys.file_exists (file^ext2)) then begin + prerr_endline ("Renaming "^file^ext1^" to "^file^ext2); + Sys.rename (file^ext1) (file^ext2) + end + +let () = + try + let arg = if Array.length Sys.argv > 1 then Sys.argv.(1) else "" in + if arg <> "" && arg <> "byte" && arg <> "opt" then begin + prerr_endline "ocaml build.ml [ byte | opt ]"; + prerr_endline " byte build bytecode library only"; + prerr_endline " opt build both bytecode and native (default)"; + exit 2 + end; + byte (); + if arg = "opt" || arg <> "byte" then begin + try native () with + Failure err -> + prerr_endline ("Native build failed: " ^ err); + prerr_endline "You can still use the bytecode version" + end; + if !ccomp_type = "msvc" then begin + List.iter ["liblablgl"; "libtogl"; "liblablglut"] ~f:(rename ~ext1:".a" ~ext2:".noa"); + List.iter ["liblablgl"; "libtogl"; "liblablglut"] ~f:(rename ~ext1:".nolib" ~ext2:".lib"); + prerr_endline "Now ready to use on an OCaml MSVC port" + end else begin + List.iter ["liblablgl"; "libtogl"; "liblablglut"] ~f:(rename ~ext1:".noa" ~ext2:".a"); + List.iter ["liblablgl"; "libtogl"; "liblablglut"] ~f:(rename ~ext1:".lib" ~ext2:".nolib"); + prerr_endline "Now ready to use on an OCaml Mingw port" + end + with Failure err -> + prerr_endline ("Bytecode failed: " ^ err) diff --git a/src/gl.ml b/src/gl.ml new file mode 100644 index 0000000..6ca7931 --- /dev/null +++ b/src/gl.ml @@ -0,0 +1,89 @@ +(* $Id: gl.ml,v 1.31 2012-03-06 03:31:02 garrigue Exp $ *) + +(* Register an exception *) + +exception GLerror of string + +let _ = Callback.register_exception "glerror" (GLerror "") + +(* Types common to all modules *) + +type rgb = float * float * float +type rgba = float * float * float * float + +type point2 = float * float +type point3 = float * float * float +type point4 = float * float * float * float +type vect3 = float * float *float + +type clampf = float +type short = int +type kind = [`bitmap|`byte|`float|`int|`short|`ubyte|`uint|`ushort] +type real_kind = [`byte|`float|`int|`short|`ubyte|`uint|`ushort] + +type format = + [`alpha|`bgr|`bgra|`blue|`color_index|`depth_component|`green|`luminance + |`luminance_alpha|`red|`rgb|`rgba|`stencil_index] +let format_size (#format as f) = + match f with + `rgba | `bgra -> 4 + | `rgb | `bgr -> 3 + | `luminance_alpha -> 2 + | _ -> 1 + +type target = + [`color_4|`index|`normal|`texture_coord_1|`texture_coord_2|`texture_coord_3 + |`texture_coord_4|`trim_2|`trim_3|`vertex_3|`vertex_4] +let target_size = function + `index|`normal|`texture_coord_1 -> 1 + | `texture_coord_2|`trim_2 -> 2 + | `vertex_3|`texture_coord_3|`trim_3 -> 3 + | `vertex_4|`color_4|`texture_coord_4 -> 4 + +type cmp_func = + [`always|`equal|`gequal|`greater|`lequal|`less|`never|`notequal] +type face = [`back|`both|`front] + +(* Basic functions *) + +external flush : unit -> unit = "ml_glFlush" +external finish : unit -> unit = "ml_glFinish" + +type cap = + [`alpha_test|`auto_normal|`blend|`clip_plane0|`clip_plane1|`clip_plane2 + |`clip_plane3|`clip_plane4|`clip_plane5|`color_material|`cull_face + |`depth_test|`dither|`fog|`light0|`light1|`light2|`light3|`light4|`light5 + |`light6|`light7|`lighting|`line_smooth|`line_stipple + |`index_logic_op |`color_logic_op + |`map1_color_4|`map1_index|`map1_normal|`map1_texture_coord_1 + |`map1_texture_coord_2|`map1_texture_coord_3|`map1_texture_coord_4 + |`map1_vertex_3|`map1_vertex_4|`map2_color_4|`map2_index|`map2_normal + |`map2_texture_coord_1|`map2_texture_coord_2|`map2_texture_coord_3 + |`map2_texture_coord_4|`map2_vertex_3|`map2_vertex_4|`normalize|`point_smooth + |`polygon_offset_fill|`polygon_offset_line|`polygon_offset_point + |`polygon_smooth|`polygon_stipple|`scissor_test|`stencil_test|`texture_1d + |`texture_2d|`texture_gen_q|`texture_gen_r|`texture_gen_s|`texture_gen_t] + +external enable : cap -> unit = "ml_glEnable" +external disable : cap -> unit = "ml_glDisable" +external is_enabled : cap -> bool = "ml_glIsEnabled" + +type error = + [`no_error|`invalid_enum|`invalid_value|`invalid_operation + |`stack_overflow|`stack_underflow|`out_of_memory|`table_too_large] +external get_error : unit -> error = "ml_glGetError" +let raise_error name = + let err = get_error () in + if err = `no_error then () else + let s = + List.assoc err + [ `invalid_enum, "Invalid Enum"; + `invalid_value, "Invalid Value"; + `invalid_operation, "Invalid Operation"; + `stack_overflow, "Stack Overflow"; + `stack_underflow, "Stack Underflow"; + `out_of_memory, "Out of Memory"; + `table_too_large, "Table Too Large" ] + in + let s = if name = "" then s else (name ^ ": " ^ s) in + raise (GLerror s) diff --git a/src/gl.mli b/src/gl.mli new file mode 100644 index 0000000..8d28c40 --- /dev/null +++ b/src/gl.mli @@ -0,0 +1,64 @@ +(* $Id: gl.mli,v 1.23 2012-03-06 03:31:02 garrigue Exp $ *) + +(* Exceptions *) + +exception GLerror of string + +(* Types common to all modules *) + +type rgb = float * float * float +type rgba = float * float * float * float + +type point2 = float * float +type point3 = float * float * float +type point4 = float * float * float * float +type vect3 = float * float *float + +type clampf = float +type short = int +type kind = [`bitmap|`byte|`float|`int|`short|`ubyte|`uint|`ushort] +type real_kind = [`byte|`float|`int|`short|`ubyte|`uint|`ushort] + +type format = + [`alpha|`bgr|`bgra|`blue|`color_index|`depth_component|`green|`luminance + |`luminance_alpha|`red|`rgb|`rgba|`stencil_index] +val format_size : [< format] -> int + +type target = + [`color_4|`index|`normal|`texture_coord_1|`texture_coord_2|`texture_coord_3 + |`texture_coord_4|`trim_2|`trim_3|`vertex_3|`vertex_4] +val target_size : [< target] -> int + +type cmp_func = + [`always|`equal|`gequal|`greater|`lequal|`less|`never|`notequal] +type face = [`back|`both|`front] + +(* Basic functions *) + +val flush : unit -> unit +val finish : unit -> unit + +type cap = + [`alpha_test|`auto_normal|`blend|`clip_plane0|`clip_plane1|`clip_plane2 + |`clip_plane3|`clip_plane4|`clip_plane5|`color_material|`cull_face + |`depth_test|`dither|`fog|`light0|`light1|`light2|`light3|`light4|`light5 + |`light6|`light7|`lighting|`line_smooth|`line_stipple + |`index_logic_op |`color_logic_op + |`map1_color_4|`map1_index|`map1_normal|`map1_texture_coord_1 + |`map1_texture_coord_2|`map1_texture_coord_3|`map1_texture_coord_4 + |`map1_vertex_3|`map1_vertex_4|`map2_color_4|`map2_index|`map2_normal + |`map2_texture_coord_1|`map2_texture_coord_2|`map2_texture_coord_3 + |`map2_texture_coord_4|`map2_vertex_3|`map2_vertex_4|`normalize|`point_smooth + |`polygon_offset_fill|`polygon_offset_line|`polygon_offset_point + |`polygon_smooth|`polygon_stipple|`scissor_test|`stencil_test|`texture_1d + |`texture_2d|`texture_gen_q|`texture_gen_r|`texture_gen_s|`texture_gen_t] +val enable : cap -> unit +val disable : cap -> unit +val is_enabled : cap -> bool + +type error = + [`no_error|`invalid_enum|`invalid_value|`invalid_operation + |`stack_overflow|`stack_underflow|`out_of_memory|`table_too_large] +val get_error : unit -> error +val raise_error : string -> unit + (* raise GLerror if there is a current error, otherwise do nothing *) diff --git a/src/glArray.ml b/src/glArray.ml new file mode 100644 index 0000000..5b8368e --- /dev/null +++ b/src/glArray.ml @@ -0,0 +1,54 @@ +(* $Id: glArray.ml,v 1.6 2008-10-30 07:51:33 garrigue Exp $ *) + +open Gl +open Raw + +type kind = [`edge_flag | `texture_coord | `color | `index | `normal | `vertex ] + +let check_static func f raw = + if not (Raw.static raw) then + invalid_arg ("GlArray." ^ func ^ " : buffer must be static"); + f raw + +external _edge_flag : [< `bitmap] Raw.t -> unit = "ml_glEdgeFlagPointer" +let edge_flag raw = check_static "edge_flag" _edge_flag raw + +external _tex_coord : + [< `one | `two | `three | `four] -> + [< `short | `int | `float | `double] Raw.t -> unit + = "ml_glTexCoordPointer" +let tex_coord n = check_static "tex_coord" (_tex_coord n) + +external _color : + [< `three | `four] -> + [< `byte | `ubyte | `short | `ushort | `int | `uint | `float | `double] Raw.t + -> unit + = "ml_glColorPointer" +let color n = check_static "color" (_color n) + +external _index : [< `ubyte | `short | `int | `float | `double] Raw.t -> unit + = "ml_glIndexPointer" +let index raw = check_static "index" _index raw + +external _normal : [< `byte | `short | `int | `float | `double] Raw.t -> unit + = "ml_glNormalPointer" +let normal raw = check_static "normal" _normal raw + +external _vertex : + [< `two | `three | `four] -> [< `short | `int | `float | `double] Raw.t + -> unit + = "ml_glVertexPointer" +let vertex n = check_static "vertex" (_vertex n) + +external enable : kind -> unit= "ml_glEnableClientState" + +external disable : kind -> unit = "ml_glDisableClientState" + +external element : int -> unit = "ml_glArrayElement" + +external draw_arrays : GlDraw.shape -> first:int -> count:int -> unit + = "ml_glDrawArrays" + +external draw_elements + : GlDraw.shape -> count:int -> [< `ubyte | `ushort | `uint] Raw.t -> unit + = "ml_glDrawElements" diff --git a/src/glArray.mli b/src/glArray.mli new file mode 100644 index 0000000..5cbbe3c --- /dev/null +++ b/src/glArray.mli @@ -0,0 +1,62 @@ +(** Vertex array manipulation functions *) +(* $Id: glArray.mli,v 1.7 2008-10-25 02:22:58 garrigue Exp $ *) + +(** The six different kinds for array *) +type kind = + [ `color | `edge_flag | `index | `normal | `texture_coord | `vertex ] + +(** Tell openGL the address of the edgeFlag array. + Raw array must be static. *) +val edge_flag : [ `bitmap ] Raw.t -> unit + +(** Tell openGL the address of the texCoor array + Raw array must be static. *) +val tex_coord : + [< `one | `two | `three | `four] -> + [< `double | `float | `int | `short ] Raw.t -> unit + +(** Tell openGL the address of the color array + Raw array must be static. *) +val color : + [< `three | `four] -> + [< `byte | `double | `float | `int | `short | `ubyte | `uint | `ushort ] + Raw.t -> unit + +(** Tell openGL the address of the index array + Raw array must be static. *) +val index : [< `double | `float | `int | `short | `ubyte ] Raw.t -> unit + +(** Tell openGL the address of the normal array + Raw array must be static. *) +val normal : [< `byte | `double | `float | `int | `short ] Raw.t -> unit + +(** Tell openGL the address of the vertex array + Raw array must be static. *) +val vertex : + [< `two | `three | `four] -> [< `double | `float | `int | `short ] Raw.t + -> unit + +(** Tell openGL the address of to use the specified array + Raw array must be static. *) +external enable : kind -> unit = "ml_glEnableClientState" + +(** Tell openGL the address of not to use the specified array + Raw array must be static. *) +external disable : kind -> unit = "ml_glDisableClientState" + +(* GlArray.element i + sends to openGL the element i of all enabled arrays *) +external element : int -> unit = "ml_glArrayElement" + +(* GlArray.draw_arrays shape i c + sends to openGL a GlDraw.begins shape and all the element from i to i+c-1 + of all enabled arrays and finally do a GlDraw.ends () *) +external draw_arrays : GlDraw.shape -> first:int -> count:int -> unit + = "ml_glDrawArrays" + +(* GlArray.draw_elements shape c tbl + sends to openGL a GlDraw.begins shape and all the element from tbl[0] to + tbl[c-1] of all enabled arrays and finally do a GlDraw.ends () *) +external draw_elements : + GlDraw.shape -> count:int -> [< `ubyte | `uint | `ushort ] Raw.t -> unit + = "ml_glDrawElements" diff --git a/src/glClear.ml b/src/glClear.ml new file mode 100644 index 0000000..be01f1a --- /dev/null +++ b/src/glClear.ml @@ -0,0 +1,20 @@ +(* $Id: glClear.ml,v 1.5 2000-04-12 07:40:23 garrigue Exp $ *) + +open Gl + +external accum : float -> float -> float -> float -> unit + = "ml_glClearAccum" +let accum ?(alpha=1.) (r,g,b : rgb) = + accum r g b alpha + +type buffer = [`color|`depth|`accum|`stencil] +external clear : buffer list -> unit = "ml_glClear" + +external color : + red:float -> green:float -> blue:float -> alpha:float -> unit + = "ml_glClearColor" +let color ?(alpha=1.) (red, green, blue : rgb) = + color ~red ~green ~blue ~alpha +external depth : clampf -> unit = "ml_glClearDepth" +external index : float -> unit = "ml_glClearIndex" +external stencil : int -> unit = "ml_glClearStencil" diff --git a/src/glClear.mli b/src/glClear.mli new file mode 100644 index 0000000..dae4c8a --- /dev/null +++ b/src/glClear.mli @@ -0,0 +1,12 @@ +(* $Id: glClear.mli,v 1.3 1999-11-15 09:55:05 garrigue Exp $ *) + +type buffer = [`accum|`color|`depth|`stencil] +val clear : buffer list -> unit + (* glClear: clear the specified buffers *) + +val accum : ?alpha:float -> Gl.rgb -> unit +val color : ?alpha:float -> Gl.rgb -> unit +val depth : Gl.clampf -> unit +val index : float -> unit +val stencil : int -> unit + (* Set the clear value for each buffer: glClearAccum etc *) diff --git a/src/glDraw.ml b/src/glDraw.ml new file mode 100644 index 0000000..f98a9a6 --- /dev/null +++ b/src/glDraw.ml @@ -0,0 +1,56 @@ +(* $Id: glDraw.ml,v 1.6 2007-04-13 01:17:50 garrigue Exp $ *) + +open Gl + +external color : + red:float -> green:float -> blue:float -> alpha:float -> unit + = "ml_glColor4d" +let color ?(alpha=1.) (red, green, blue : rgb) = + color ~red ~green ~blue ~alpha + +external index : float -> unit = "ml_glIndexd" + +external cull_face : face -> unit = "ml_glCullFace" +external edge_flag : bool -> unit = "ml_glEdgeFlag" +external front_face : [`cw|`ccw] -> unit = "ml_glFrontFace" + +external line_width : float -> unit = "ml_glLineWidth" +external line_stipple : factor:int -> pattern:short -> unit + = "ml_glLineStipple" +let line_stipple ?(factor=1) pattern = + line_stipple ~factor ~pattern +external point_size : float -> unit = "ml_glPointSize" + +external polygon_offset : factor:float -> units:float -> unit + = "ml_glPolygonOffset" +external polygon_mode : face:face -> [`point|`line|`fill] -> unit + = "ml_glPolygonMode" +external polygon_stipple : [`bitmap] Raw.t -> unit = "ml_glPolygonStipple" +let polygon_stipple (img : GlPix.bitmap) = + if GlPix.height img <> 32 or GlPix.width img <> 32 + then invalid_arg "GlDraw.polygon_stipple"; + polygon_stipple (GlPix.to_raw img) + +external shade_model : [`flat|`smooth] -> unit = "ml_glShadeModel" + +type shape = + [ `points | `lines | `polygon | `triangles | `quads | `line_strip + | `line_loop | `triangle_strip | `triangle_fan | `quad_strip ] +external begins : shape -> unit = "ml_glBegin" +external ends : unit -> unit = "ml_glEnd" + +external normal : x:float -> y:float -> z:float -> unit + = "ml_glNormal3d" +let normal ?(x=0.) ?(y=0.) ?(z=0.) () = normal ~x ~y ~z +and normal3 (x,y,z) = normal ~x ~y ~z + +external rect : point2 -> point2 -> unit = "ml_glRectd" + +external vertex : x:float -> y:float -> ?z:float -> ?w:float -> unit -> unit + = "ml_glVertex" +let vertex2 (x,y : point2) = vertex ~x ~y () +and vertex3 (x,y,z : point3) = vertex ~x ~y ~z () +and vertex4 (x,y,z,w : point4) = vertex ~x ~y ~z ~w () + +external viewport : x:int -> y:int -> w:int -> h:int -> unit + = "ml_glViewport" diff --git a/src/glDraw.mli b/src/glDraw.mli new file mode 100644 index 0000000..7f35774 --- /dev/null +++ b/src/glDraw.mli @@ -0,0 +1,42 @@ +(* $Id: glDraw.mli,v 1.3 2007-04-13 01:17:50 garrigue Exp $ *) + +open Gl + +val color : ?alpha:float -> rgb -> unit + (* Sets the current color *) +val index : float -> unit + (* Sets the current index *) +val cull_face : face -> unit + (* Specifies which faces are candidates for culling *) +val front_face : [`ccw|`cw] -> unit + (* Specifies wether front faces are clockwise or not *) +val edge_flag : bool -> unit +val line_width : float -> unit +val line_stipple : ?factor:int -> short -> unit + (* [line_stipple :factor pattern] sets the line stipple to the + 16-bit integer [pattern]. Each bit is used [factor] times *) +val point_size : float -> unit +val polygon_offset : factor:float -> units:float -> unit +val polygon_mode : face:face -> [`fill|`line|`point] -> unit +val polygon_stipple : GlPix.bitmap -> unit + +val shade_model : [`flat|`smooth] -> unit + +val normal : ?x:float -> ?y:float -> ?z:float -> unit -> unit +val normal3 : vect3 -> unit + (* [glNormal] *) + +val rect : point2 -> point2 -> unit + +type shape = + [`line_loop|`line_strip|`lines|`points|`polygon|`quad_strip|`quads + |`triangle_fan|`triangle_strip|`triangles] +val begins : shape -> unit +val ends : unit -> unit + +val vertex : x:float -> y:float -> ?z:float -> ?w:float -> unit -> unit +val vertex2 : point2 -> unit +val vertex3 : point3 -> unit +val vertex4 : point4 -> unit + +val viewport : x:int -> y:int -> w:int -> h:int -> unit diff --git a/src/glFunc.ml b/src/glFunc.ml new file mode 100644 index 0000000..240a12e --- /dev/null +++ b/src/glFunc.ml @@ -0,0 +1,66 @@ +(* $Id: glFunc.ml,v 1.7 2000-04-12 07:40:23 garrigue Exp $ *) + +open Gl + +external accum : op:[`accum|`load|`add|`mult|`return] -> float -> unit + = "ml_glAccum" +external alpha_func : cmp_func -> ref:clampf -> unit = "ml_glAlphaFunc" + +type sfactor = [ + `zero + | `one + | `dst_color + | `one_minus_dst_color + | `src_alpha + | `one_minus_src_alpha + | `dst_alpha + | `one_minus_dst_alpha + | `src_alpha_saturate +] +type dfactor = [ + `zero + | `one + | `src_color + | `one_minus_src_color + | `src_alpha + | `one_minus_src_alpha + | `dst_alpha + | `one_minus_dst_alpha +] +external blend_func : src:sfactor -> dst:dfactor -> unit = "ml_glBlendFunc" + +external color_mask : bool -> bool -> bool -> bool -> unit + = "ml_glColorMask" +let color_mask ?(red=false) ?(green=false) ?(blue=false) ?(alpha=false) ()= + color_mask red green blue alpha + +external depth_func : cmp_func -> unit = "ml_glDepthFunc" +external depth_mask : bool -> unit = "ml_glDepthMask" +external depth_range : near:float -> far:float -> unit = "ml_glDepthRange" + +type draw_buffer = + [`none|`front_left|`front_right|`back_left|`back_right + |`front|`back|`left|`right|`front_and_back|`aux of int] +external draw_buffer : draw_buffer -> unit = "ml_glDrawBuffer" + +external index_mask : int -> unit = "ml_glIndexMask" + +type logic_op = + [`clear|`set|`copy|`copy_inverted|`noop|`invert|`And|`nand|`Or|`nor + |`xor|`equiv|`and_reverse|`and_inverted|`or_reverse|`or_inverted] +external logic_op : logic_op -> unit = "ml_glLogicOp" + +type read_buffer = + [`front_left|`front_right|`back_left|`back_right|`front|`back + |`left|`right|`aux of int] +external read_buffer : read_buffer -> unit = "ml_glReadBuffer" + +external stencil_func : cmp_func -> ref:int -> mask:int -> unit + = "ml_glStencilFunc" +external stencil_mask : int -> unit = "ml_glStencilMask" +type stencil_op = [`keep|`zero|`replace|`incr|`decr|`invert] +external stencil_op : + fail:stencil_op -> zfail:stencil_op -> zpass:stencil_op -> unit + = "ml_glStencilOp" +let stencil_op ?(fail=`keep) ?(zfail=`keep) ?(zpass=`keep) () = + stencil_op ~fail ~zfail ~zpass diff --git a/src/glFunc.mli b/src/glFunc.mli new file mode 100644 index 0000000..51865a2 --- /dev/null +++ b/src/glFunc.mli @@ -0,0 +1,43 @@ +(* $Id: glFunc.mli,v 1.4 2000-04-03 02:57:41 garrigue Exp $ *) + +val accum : op:[`accum|`add|`load|`mult|`return] -> float -> unit + +val alpha_func : Gl.cmp_func -> ref:Gl.clampf -> unit + +type sfactor = + [`dst_alpha|`dst_color|`one|`one_minus_dst_alpha|`one_minus_dst_color + |`one_minus_src_alpha|`src_alpha|`src_alpha_saturate|`zero] +type dfactor = + [`dst_alpha|`one|`one_minus_dst_alpha|`one_minus_src_alpha + |`one_minus_src_color|`src_alpha|`src_color|`zero] +val blend_func : src:sfactor -> dst:dfactor -> unit + +val color_mask : + ?red:bool -> ?green:bool -> ?blue:bool -> ?alpha:bool -> unit -> unit + +val depth_func : Gl.cmp_func -> unit +val depth_mask : bool -> unit +val depth_range : near:float -> far:float -> unit + +val index_mask : int -> unit + +val stencil_func : Gl.cmp_func -> ref:int -> mask:int -> unit +val stencil_mask : int -> unit +type stencil_op = [`decr|`incr|`invert|`keep|`replace|`zero] +val stencil_op : + ?fail:stencil_op -> ?zfail:stencil_op -> ?zpass:stencil_op -> unit -> unit + +type logic_op = + [`And|`Or|`and_inverted|`and_reverse|`clear|`copy|`copy_inverted|`equiv + |`invert|`nand|`noop|`nor|`or_inverted|`or_reverse|`set|`xor] +val logic_op : logic_op -> unit + +type draw_buffer = + [`aux of int|`back|`back_left|`back_right|`front|`front_and_back|`front_left + |`front_right|`left|`none|`right] +val draw_buffer : draw_buffer -> unit + +type read_buffer = + [`aux of int|`back|`back_left|`back_right|`front|`front_left|`front_right + |`left|`right] +val read_buffer : read_buffer -> unit diff --git a/src/glLight.ml b/src/glLight.ml new file mode 100644 index 0000000..e22e3e3 --- /dev/null +++ b/src/glLight.ml @@ -0,0 +1,53 @@ +(* $Id: glLight.ml,v 1.7 2003-04-24 16:42:59 erickt Exp $ *) + +open Gl + +type color_material = + [`emission|`ambient|`diffuse|`specular|`ambient_and_diffuse] +external color_material : face:face -> color_material -> unit + = "ml_glColorMaterial" + +type fog_param = [ + `mode of [`linear|`exp|`exp2] + | `density of float + | `start of float + | `End of float + | `index of float + | `color of rgba +] +external fog : fog_param -> unit = "ml_glFog" + +type light_param = [ + `ambient of rgba + | `diffuse of rgba + | `specular of rgba + | `position of point4 + | `spot_direction of point3 + | `spot_exponent of float + | `spot_cutoff of float + | `constant_attenuation of float + | `linear_attenuation of float + | `quadratic_attenuation of float +] +external light : num:int -> light_param -> unit + = "ml_glLight" + +type light_model_param = [ + `ambient of rgba + | `local_viewer of bool + | `two_side of bool + | `color_control of [`separate_specular_color | `single_color] +] +external light_model : light_model_param -> unit = "ml_glLightModel" + +type material_param = [ + `ambient of rgba + | `diffuse of rgba + | `specular of rgba + | `emission of rgba + | `shininess of float + | `ambient_and_diffuse of rgba + | `color_indexes of (float * float * float) +] +external material : face:face -> material_param -> unit + = "ml_glMaterial" diff --git a/src/glLight.mli b/src/glLight.mli new file mode 100644 index 0000000..4f381a2 --- /dev/null +++ b/src/glLight.mli @@ -0,0 +1,49 @@ +(* $Id: glLight.mli,v 1.7 2003-04-24 16:42:59 erickt Exp $ *) + +open Gl + +type color_material = + [`emission|`ambient|`diffuse|`specular|`ambient_and_diffuse] +val color_material : face:face -> color_material -> unit + +type fog_param = [ + `mode of [`linear|`exp|`exp2] + | `density of float + | `start of float + | `End of float + | `index of float + | `color of rgba +] +val fog : fog_param -> unit + +type light_param = [ + `ambient of rgba + | `diffuse of rgba + | `specular of rgba + | `position of point4 + | `spot_direction of point3 + | `spot_exponent of float + | `spot_cutoff of float + | `constant_attenuation of float + | `linear_attenuation of float + | `quadratic_attenuation of float +] +val light : num:int -> light_param -> unit + +val light_model : [ + `ambient of rgba + | `local_viewer of bool + | `two_side of bool + | `color_control of [`separate_specular_color|`single_color] +] -> unit + +type material_param = [ + `ambient of rgba + | `diffuse of rgba + | `specular of rgba + | `emission of rgba + | `shininess of float + | `ambient_and_diffuse of rgba + | `color_indexes of (float * float * float) +] +val material : face:face -> material_param -> unit diff --git a/src/glList.ml b/src/glList.ml new file mode 100644 index 0000000..d1abaa2 --- /dev/null +++ b/src/glList.ml @@ -0,0 +1,29 @@ +(* $Id: glList.ml,v 1.4 2000-04-12 07:40:24 garrigue Exp $ *) + +type t = int +type base = int + +external is_list : t -> bool = "ml_glIsList" +external gen_lists : len:int -> base = "ml_glGenLists" +external delete_lists : base -> len:int -> unit = "ml_glDeleteLists" +external begins : t -> mode:[`compile|`compile_and_execute] -> unit + = "ml_glNewList" +external ends : unit -> unit = "ml_glEndList" +external call : t -> unit = "ml_glCallList" +external call_lists : [ `byte of string | `int of int array] -> unit + = "ml_glCallLists" +external list_base : base -> unit = "ml_glListBase" + +let nth base ~pos = base + pos + +let create mode = + let l = gen_lists ~len:1 in begins l ~mode; l + +let delete l = + delete_lists l ~len:1 + +let call_lists ?base lists = + begin match base with None -> () + | Some base -> list_base base + end; + call_lists lists diff --git a/src/glList.mli b/src/glList.mli new file mode 100644 index 0000000..e8da9a1 --- /dev/null +++ b/src/glList.mli @@ -0,0 +1,30 @@ +(* $Id: glList.mli,v 1.4 2000-04-03 02:57:41 garrigue Exp $ *) + +type t + +val create : [`compile|`compile_and_execute] -> t + (* [create mode] creates a new display list in given mode. + It is equivalent to + [let base = gen_lists len:1 in begins (nth base pos:0)] *) +val ends : unit -> unit + (* glEndList: end a display list started by create or begins *) +val call : t -> unit +val delete : t -> unit + +type base + +val nth : base -> pos:int -> t + (* [nth base :pos] returns the index of the list at base+pos *) +val is_list : t -> bool + (* [is_list l] is true if l indexes a display list *) +val gen_lists : len:int -> base + (* Generate len new display lists. They are indexed by + [nth base pos:0] to [nth base pos:(len-1)] *) +val begins : t -> mode:[`compile|`compile_and_execute] -> unit + (* glNewList: start the definition of a display list in given mode *) +val delete_lists : base -> len:int -> unit + (* Delete len lists starting at base *) +val call_lists : ?base:base -> [ `byte of string | `int of int array] -> unit + (* Call the lists whose indexes are given either by a string + (code of each character) or an array. + If the base is omited, the base given in a previous call is assumed *) diff --git a/src/glMap.ml b/src/glMap.ml new file mode 100644 index 0000000..d072309 --- /dev/null +++ b/src/glMap.ml @@ -0,0 +1,38 @@ +(* $Id: glMap.ml,v 1.4 2008-01-10 05:50:37 garrigue Exp $ *) + +external eval_coord1 : float -> unit = "ml_glEvalCoord1d" +external eval_coord2 : float -> float -> unit = "ml_glEvalCoord2d" +external eval_mesh1 : mode:[`point|`line] -> int -> int -> unit + = "ml_glEvalMesh1" +let eval_mesh1 ~mode ~range:(u1,u2) = eval_mesh1 ~mode u1 u2 +external eval_mesh2 : + mode:[`point|`line|`fill] -> int -> int -> int -> int -> unit + = "ml_glEvalMesh2" +let eval_mesh2 ~mode ~range1:(u1,u2) ~range2:(v1,v2) = + eval_mesh2 ~mode u1 u2 v1 v2 +external eval_point1 : int -> unit = "ml_glEvalPoint1" +external eval_point2 : int -> int -> unit = "ml_glEvalPoint2" + +type target = + [ `vertex_3 + | `vertex_4 + | `index + | `color_4 + | `normal + | `texture_coord_1 + | `texture_coord_2 + | `texture_coord_3 + | `texture_coord_4 ] +external map1 : + target:target -> (float*float) -> order:int -> [`double] Raw.t -> unit + = "ml_glMap1d" +external map2 : + target:target -> (float*float) -> order:int -> + (float*float) -> order:int -> [`double] Raw.t -> unit + = "ml_glMap2d_bc" "ml_glMap2d" +external grid1 : n:int -> range:(float * float) -> unit + = "ml_glMapGrid1d" +external grid2 : + n1:int -> range1:(float * float) -> + n2:int -> range2:(float * float) -> unit + = "ml_glMapGrid2d" diff --git a/src/glMap.mli b/src/glMap.mli new file mode 100644 index 0000000..065fd2d --- /dev/null +++ b/src/glMap.mli @@ -0,0 +1,39 @@ +(* $Id: glMap.mli,v 1.3 2000-04-12 07:40:24 garrigue Exp $ *) + +type target = + [ `vertex_3 + | `vertex_4 + | `index + | `color_4 + | `normal + | `texture_coord_1 + | `texture_coord_2 + | `texture_coord_3 + | `texture_coord_4 ] +val map1 : + target:target -> float * float -> order:int -> [`double] Raw.t -> unit + (* [map1 :target (u1,u2) :order points] defines a 1-dimensional map. + [order] is the number of control points in [points] *) +val map2 : + target:target -> + float * float -> + order:int -> float * float -> order:int -> [`double] Raw.t -> unit + (* [map1 :target (u1,u2) order:uorder (v1,v2) order:vorder points] + defines a 2-dimensional map. + The number of control points in [points] is [uorder*vorder] *) + +val eval_coord1 : float -> unit +val eval_coord2 : float -> float -> unit + (* Evaluate the maps at given coordinates *) + +val grid1 : n:int -> range:float * float -> unit +val grid2 : + n1:int -> range1:float * float -> n2:int -> range2:float * float -> unit + (* Define 1- and 2-dimensional meshes to the maps *) + +val eval_mesh1 : mode:[`line|`point] -> range:(int * int) -> unit +val eval_mesh2 : + mode:[`fill|`line|`point] -> range1:(int * int) -> range2:(int * int) -> unit +val eval_point1 : int -> unit +val eval_point2 : int -> int -> unit + (* Evaluate meshes at given coordinates *) diff --git a/src/glMat.ml b/src/glMat.ml new file mode 100644 index 0000000..febd90a --- /dev/null +++ b/src/glMat.ml @@ -0,0 +1,77 @@ +(* $Id: glMat.ml,v 1.11 2005-10-28 02:49:09 garrigue Exp $ *) + +type t = [`double] Raw.t + +external frustum : + x:(float * float) -> y:(float * float) -> z:(float * float) -> unit + = "ml_glFrustum" + +external load_identity : unit -> unit = "ml_glLoadIdentity" +external load : t -> unit = "ml_glLoadMatrixd" +let load m = + if Raw.length m <> 16 then invalid_arg "Gl.load_matrix"; + load m +external load_transpose : t -> unit = "ml_glLoadTransposeMatrixd" +let load_transpose m = + if Raw.length m <> 16 then invalid_arg "Gl.load_transpose_matrix"; + load_transpose m + + +external get_matrix : [`modelview_matrix|`projection_matrix|`texture_matrix] -> t -> unit = "ml_glGetDoublev" +let get_matrix mode = + let model = Raw.create `double ~len:16 in + get_matrix mode model; + model + +external mode : [`modelview|`projection|`texture] -> unit + = "ml_glMatrixMode" +external mult : t -> unit = "ml_glMultMatrixd" +let mult m = + if Raw.length m <> 16 then invalid_arg "Gl.mult_matrix"; + mult m +external mult_transpose : t -> unit = "ml_glMultTransposeMatrixd" +let mult_transpose m = + if Raw.length m <> 16 then invalid_arg "Gl.mult_matrix"; + mult_transpose m + +external ortho : + x:(float * float) -> y:(float * float) -> z:(float * float) -> unit + = "ml_glOrtho" + +external pop : unit -> unit = "ml_glPopMatrix" +external push : unit -> unit = "ml_glPushMatrix" + +external rotate : angle:float -> x:float -> y:float -> z:float -> unit + = "ml_glRotated" +let rotate3 ~angle (x,y,z) = rotate ~angle ~x ~y ~z +let rotate ~angle ?(x=0.) ?(y=0.) ?(z=0.) () = rotate ~angle ~x ~y ~z + +external scale : x:float -> y:float -> z:float -> unit = "ml_glScaled" +let scale3 (x,y,z) = scale ~x ~y ~z +let scale ?(x=0.) ?(y=0.) ?(z=0.) () = scale ~x ~y ~z + +external translate : x:float -> y:float -> z:float -> unit = "ml_glTranslated" +let translate3 (x,y,z) = translate ~x ~y ~z +let translate ?(x=0.) ?(y=0.) ?(z=0.) () = translate ~x ~y ~z + +let of_raw mat = + if Raw.length mat <> 16 then invalid_arg "GlMatrix.of_array"; + mat +external to_raw : t -> [`double] Raw.t = "%identity" + +let of_array m : t = + if Array.length m <> 4 then invalid_arg "GlMatrix.of_array"; + let mat = Raw.create `double ~len:16 in + for i = 0 to 3 do + let arr = Array.unsafe_get m i in + if Array.length arr <> 4 then invalid_arg "GlMatrix.of_array"; + Raw.sets_float mat ~pos:(i*4) arr + done; + mat + +let to_array (mat : t) = + let m = Array.create 4 [||] in + for i = 0 to 3 do + Array.unsafe_set m i (Raw.gets_float mat ~pos:(i*4) ~len:4) + done; + m diff --git a/src/glMat.mli b/src/glMat.mli new file mode 100644 index 0000000..577f3f6 --- /dev/null +++ b/src/glMat.mli @@ -0,0 +1,37 @@ +(* $Id: glMat.mli,v 1.6 2003-04-22 03:24:02 erickt Exp $ *) + +open Gl + +type t + +val of_raw : [`double] Raw.t -> t +external to_raw : t -> [`double] Raw.t = "%identity" + (* Those two functions are just the identity, and keep sharing. + [double] Raw.t is a raw array of 16 floating point values + representing as 4x4 matrix *) +val of_array : float array array -> t +val to_array : t -> float array array + +val load : t -> unit +val load_transpose : t -> unit +val mult : t -> unit +val mult_transpose : t -> unit +val load_identity : unit -> unit + +val push : unit -> unit +val pop : unit -> unit + (* Push and pop the matrix on the stack *) + +val mode : [`modelview|`projection|`texture] -> unit +val get_matrix : [`modelview_matrix|`projection_matrix|`texture_matrix] -> t + +val rotate : angle:float -> ?x:float -> ?y:float -> ?z:float -> unit -> unit +val scale : ?x:float -> ?y:float -> ?z:float -> unit -> unit +val translate : ?x:float -> ?y:float -> ?z:float -> unit -> unit + +val rotate3 : angle:float -> vect3 -> unit +val scale3 : point3 -> unit +val translate3 : point3 -> unit + +val ortho : x:float * float -> y:float * float -> z:float * float -> unit +val frustum : x:float * float -> y:float * float -> z:float * float -> unit diff --git a/src/glMisc.ml b/src/glMisc.ml new file mode 100644 index 0000000..37cf002 --- /dev/null +++ b/src/glMisc.ml @@ -0,0 +1,63 @@ +(* $Id: glMisc.ml,v 1.8 2008-10-25 02:22:58 garrigue Exp $ *) + +open StdLabels + +external get_string : [`vendor|`renderer|`version|`extensions] -> string + = "ml_glGetString" + +let rec check_substring ~sep ~start ~buf s = + let len = String.length s in + if String.length buf < len + start then false else + if String.sub buf ~pos:start ~len = s && + (String.length buf = len + start || buf.[len+start] = sep) then true + else match + try Some (String.index_from buf start sep) with Not_found -> None + with + | None -> false + | Some n -> check_substring ~sep ~start:(n+1) ~buf s + +let check_extension s = + check_substring ~sep:' ' ~start:0 ~buf:(get_string `extensions) s + +type equation = float * float * float * float +external clip_plane : plane:int -> equation -> unit + = "ml_glClipPlane" +let clip_plane ~plane equation = + if plane < 0 or plane > 5 then invalid_arg "Gl.clip_plane"; + clip_plane ~plane equation + +type hint_target = + [`fog|`line_smooth|`perspective_correction|`point_smooth|`polygon_smooth] +external hint : hint_target -> [`fastest|`nicest|`dont_care] -> unit + = "ml_glHint" + +external init_names : unit -> unit = "ml_glInitNames" +external load_name : int -> unit = "ml_glLoadName" +external pop_name : unit -> unit = "ml_glPopName" +external push_name : int -> unit = "ml_glPushName" + +external pop_attrib : unit -> unit = "ml_glPopAttrib" +type attrib = + [ `accum_buffer|`color_buffer|`current|`depth_buffer|`enable|`eval|`fog + | `hint|`lighting|`line|`list|`pixel_mode|`point|`polygon|`polygon_stipple + | `scissor|`stencil_buffer|`texture|`transform|`viewport ] +external push_attrib : attrib list -> unit = "ml_glPushAttrib" + +external pass_through : float -> unit = "ml_glPassThrough" +external render_mode : [`render|`select|`feedback] -> int = "ml_glRenderMode" +external select_buffer : int -> [`uint] Raw.t -> unit = "ml_glSelectBuffer" +let select_buffer raw = + if not (Raw.static raw) then + invalid_arg "GlMisc.select_buffer : buffer must be static"; + select_buffer (Raw.length raw) raw +type feedback_mode = + [`_2d |`_3d |`_3d_color |`_3d_color_texture |`_4d_color_texture] +external feedback_buffer : int -> feedback_mode -> [`float] Raw.t -> unit + = "ml_glFeedbackBuffer" +let feedback_buffer ~mode buf = + if not (Raw.static buf) then + invalid_arg "GlMisc.feedback_buffer : buffer must be static"; + feedback_buffer (Raw.length buf) mode buf + +external scissor : x:int -> y:int -> width:int -> height:int -> unit + = "ml_glScissor" diff --git a/src/glMisc.mli b/src/glMisc.mli new file mode 100644 index 0000000..763eeb0 --- /dev/null +++ b/src/glMisc.mli @@ -0,0 +1,38 @@ +(* $Id: glMisc.mli,v 1.6 2008-10-25 02:22:58 garrigue Exp $ *) + +(* Getting information *) +val get_string : [`vendor|`renderer|`version|`extensions] -> string +val check_extension : string -> bool + +(* Clipping planes *) +type equation = float * float * float * float +val clip_plane : plane:int -> equation -> unit + +(* Speed hint *) +type hint_target = + [`fog|`line_smooth|`perspective_correction|`point_smooth|`polygon_smooth] +val hint : hint_target -> [`fastest|`nicest|`dont_care] -> unit + +(* Names *) +val init_names : unit -> unit +val load_name : int -> unit +val push_name : int -> unit +val pop_name : unit -> unit + +type attrib = + [ `accum_buffer|`color_buffer|`current|`depth_buffer|`enable|`eval|`fog + | `hint|`lighting|`line|`list|`pixel_mode|`point|`polygon|`polygon_stipple + | `scissor|`stencil_buffer|`texture|`transform|`viewport ] +val push_attrib : attrib list -> unit +val pop_attrib : unit -> unit + +val render_mode : [`feedback|`render|`select] -> int +val pass_through : float -> unit +val select_buffer : [`uint] Raw.t -> unit + (* argument must be a static Raw.t *) +type feedback_mode = + [`_2d |`_3d |`_3d_color |`_3d_color_texture |`_4d_color_texture] +val feedback_buffer : mode:feedback_mode -> [`float] Raw.t -> unit + (* argument must be a static Raw.t *) + +val scissor : x:int -> y:int -> width:int -> height:int -> unit diff --git a/src/glPix.ml b/src/glPix.ml new file mode 100644 index 0000000..dd5cd7d --- /dev/null +++ b/src/glPix.ml @@ -0,0 +1,107 @@ +(* $Id: glPix.ml,v 1.10 2005-10-14 13:35:32 garrigue Exp $ *) + +open Gl + +type ('a,'b) t = { format: 'a ; width: int ; height:int ; raw: 'b Raw.t } + +let create k ~format ~width ~height = + let size = format_size format * width * height in + let len = match k with `bitmap -> (size-1)/8+1 | #Gl.real_kind -> size in + let raw = Raw.create k ~len in + { format = format; width = width; height = height; raw = raw } + +let of_raw raw ~format ~width ~height = + let size = format_size format * width * height + and len = Raw.length raw in + let len = + match Raw.kind raw with `bitmap -> len * 8 | #Gl.real_kind -> len in + if size > len then invalid_arg "GlPix.of_raw"; + { format = format; width = width; height = height; raw = raw } + +let to_raw img = img.raw +let format img = img.format +let width img = img.width +let height img = img.height + +let raw_pos img = + let width = + match Raw.kind img.raw with `bitmap -> (img.width-1)/8+1 + | #Gl.real_kind -> img.width + in + let stride = format_size img.format in + let line = stride * width in + fun ~x ~y -> x * stride + y * line + +external bitmap : + width:int -> height:int -> orig:point2 -> move:point2 -> + [`bitmap] Raw.t -> unit + = "ml_glBitmap" +type bitmap = ([`color_index], [`bitmap]) t +let bitmap (img : bitmap) = + bitmap ~width:img.width ~height:img.height img.raw + +external copy : + x:int -> y:int -> width:int -> height:int -> + buffer:[`color|`depth|`stencil] -> unit + = "ml_glCopyPixels" + +external draw : + width:int -> height:int -> format:[< format] -> [< Gl.kind] Raw.t -> unit + = "ml_glDrawPixels" +let draw img = + draw img.raw ~width:img.width ~height:img.height ~format:img.format + +type map = + [`i_to_i|`i_to_r|`i_to_g|`i_to_b|`i_to_a + |`s_to_s|`r_to_r|`g_to_g|`b_to_b|`a_to_a] +external map : map -> [`float] Raw.t -> unit + = "ml_glPixelMapfv" + +type store_param = [ + `pack_swap_bytes of bool + | `pack_lsb_first of bool + | `pack_row_length of int + | `pack_skip_pixels of int + | `pack_skip_rows of int + | `pack_alignment of int + | `unpack_swap_bytes of bool + | `unpack_lsb_first of bool + | `unpack_row_length of int + | `unpack_skip_pixels of int + | `unpack_skip_rows of int + | `unpack_alignment of int +] +external store : store_param -> unit = "ml_glPixelStorei" + +type transfer_param = [ + `map_color of bool + | `map_stencil of bool + | `index_shift of int + | `index_offset of int + | `red_scale of float + | `red_bias of float + | `green_scale of float + | `green_bias of float + | `blue_scale of float + | `blue_bias of float + | `alpha_scale of float + | `alpha_bias of float + | `depth_scale of float + | `depth_bias of float +] +external transfer : transfer_param -> unit = "ml_glPixelTransfer" + +external zoom : x:float -> y:float -> unit = "ml_glPixelZoom" + +external raster_pos : + x:float -> y:float -> ?z:float -> ?w:float -> unit -> unit + = "ml_glRasterPos" + +external read : + x:int -> y:int -> width:int -> height:int -> + format:[< format] -> [< Gl.kind] Raw.t -> unit + = "ml_glReadPixels_bc" "ml_glReadPixels" +let read ~x ~y ~width ~height ~format ~kind = + let raw = Raw.create kind ~len:(width * height * format_size format) in + read ~x ~y ~width ~height ~format raw; + { raw = raw; width = width; height = height; format = format } diff --git a/src/glPix.mli b/src/glPix.mli new file mode 100644 index 0000000..545f4fa --- /dev/null +++ b/src/glPix.mli @@ -0,0 +1,80 @@ +(* $Id: glPix.mli,v 1.9 2004-12-02 02:01:16 garrigue Exp $ *) + +(* An abstract type for pixmaps *) + +type (+'a,+'b) t + +val create : + ([< Gl.kind] as 'a) -> + format:([< Gl.format] as 'b) -> width:int -> height:int -> ('b, 'a) t + +val of_raw : + ([< Gl.kind] as 'a) Raw.t -> + format:([< Gl.format] as 'b) -> width:int -> height:int -> ('b, 'a) t +val to_raw : ('a, 'b) t -> 'b Raw.t +val format : ('a, 'b) t -> 'a +val width : ('a, 'b) t -> int +val height : ('a, 'b) t -> int +val raw_pos : ([< Gl.format], [< Gl.kind]) t -> x:int -> y:int -> int + (* [raw_pos image :x :y] partially evaluates on [image] *) + +(* openGL functions *) + +val read : + x:int -> + y:int -> + width:int -> + height:int -> + format:([< Gl.format] as 'a) -> kind:([< Gl.kind] as 'b) -> ('a, 'b) t + +type bitmap = ([`color_index], [`bitmap]) t +val bitmap : + bitmap -> orig:Gl.point2 -> move:Gl.point2 -> unit + +val draw : ([< Gl.format], [< Gl.kind]) t -> unit + +type map = + [`a_to_a|`b_to_b|`g_to_g|`i_to_a|`i_to_b + |`i_to_g|`i_to_i|`i_to_r|`r_to_r|`s_to_s] +val map : map -> [`float] Raw.t -> unit + +type store_param = [ + `pack_swap_bytes of bool + | `pack_lsb_first of bool + | `pack_row_length of int + | `pack_skip_pixels of int + | `pack_skip_rows of int + | `pack_alignment of int + | `unpack_swap_bytes of bool + | `unpack_lsb_first of bool + | `unpack_row_length of int + | `unpack_skip_pixels of int + | `unpack_skip_rows of int + | `unpack_alignment of int +] +val store : store_param -> unit + +type transfer_param = [ + `map_color of bool + | `map_stencil of bool + | `index_shift of int + | `index_offset of int + | `red_scale of float + | `red_bias of float + | `green_scale of float + | `green_bias of float + | `blue_scale of float + | `blue_bias of float + | `alpha_scale of float + | `alpha_bias of float + | `depth_scale of float + | `depth_bias of float +] +val transfer : transfer_param -> unit + +val zoom : x:float -> y:float -> unit +val raster_pos : x:float -> y:float -> ?z:float -> ?w:float -> unit -> unit + +val copy : + x:int -> + y:int -> width:int -> height:int -> buffer:[`color|`depth|`stencil] -> unit diff --git a/src/glShader.ml b/src/glShader.ml new file mode 100644 index 0000000..a210d90 --- /dev/null +++ b/src/glShader.ml @@ -0,0 +1,99 @@ +(* $Id: glShader.ml,v 1.1 2010-03-11 08:30:02 garrigue Exp $ *) +(* Code contributed by Florent Monnier *) + +(** GLSL Shaders *) + +type shader_object +type shader_program + +external create: shader_type:[`vertex_shader|`fragment_shader] -> shader_object = "ml_glcreateshader" +external delete: shader:shader_object -> unit = "ml_gldeleteshader" +external is_shader: shader:shader_object -> bool = "ml_glisshader" +external source: shader:shader_object -> string -> unit = "ml_glshadersource" +external compile: shader:shader_object -> unit = "ml_glcompileshader" +external create_program: unit -> shader_program = "ml_glcreateprogram" +external delete_program: program:shader_program -> unit = "ml_gldeleteprogram" +external attach: program:shader_program -> shader:shader_object -> unit = "ml_glattachshader" +external detach: program:shader_program -> shader:shader_object -> unit = "ml_gldetachshader" +external link_program: program:shader_program -> unit = "ml_gllinkprogram" +external use_program: program:shader_program -> unit = "ml_gluseprogram" +external unuse_program: unit -> unit = "ml_glunuseprogram" +external shader_compile_status: shader:shader_object -> bool = "ml_glgetshadercompilestatus" +external shader_compile_status_exn: shader:shader_object -> unit = "ml_glgetshadercompilestatus_exn" +external get_uniform_location: program:shader_program -> name:string -> int = "ml_glgetuniformlocation" + + +external get_program_attached_shaders: program:shader_program -> int = "ml_glgetprogram_attached_shaders" +external get_program_active_uniforms: program:shader_program -> int = "ml_glgetprogram_active_uniforms" +external get_program_active_attributes: program:shader_program -> int = "ml_glgetprogram_active_attributes" + +external get_program_validate_status: program:shader_program -> bool = "ml_glgetprogram_validate_status" +external get_program_link_status: program:shader_program -> bool = "ml_glgetprogram_link_status" +external get_program_delete_status: program:shader_program -> bool = "ml_glgetprogram_delete_status" + + +external uniform1f: location:int -> v0:float -> unit = "ml_gluniform1f" +external uniform2f: location:int -> v0:float -> v1:float -> unit = "ml_gluniform2f" +external uniform3f: location:int -> v0:float -> v1:float -> v2:float -> unit = "ml_gluniform3f" +external uniform4f: location:int -> v0:float -> v1:float -> v2:float -> v3:float -> unit = "ml_gluniform4f" +external uniform1i: location:int -> v0:int -> unit = "ml_gluniform1i" +external uniform2i: location:int -> v0:int -> v1:int -> unit = "ml_gluniform2i" +external uniform3i: location:int -> v0:int -> v1:int -> v2:int -> unit = "ml_gluniform3i" +external uniform4i: location:int -> v0:int -> v1:int -> v2:int -> v3:int -> unit = "ml_gluniform4i" + + +external uniform1fv: location:int -> value:float array -> unit = "ml_gluniform1fv" +external uniform2fv: location:int -> count:int -> value:float array -> unit = "ml_gluniform2fv" +external uniform3fv: location:int -> count:int -> value:float array -> unit = "ml_gluniform3fv" +external uniform4fv: location:int -> count:int -> value:float array -> unit = "ml_gluniform4fv" + +external uniform1iv: location:int -> value:int array -> unit = "ml_gluniform1iv" +external uniform2iv: location:int -> count:int -> value:int array -> unit = "ml_gluniform2iv" +external uniform3iv: location:int -> count:int -> value:int array -> unit = "ml_gluniform3iv" +external uniform4iv: location:int -> count:int -> value:int array -> unit = "ml_gluniform4iv" + + +external uniform_matrix2f: location:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix2f" +external uniform_matrix3f: location:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix3f" +external uniform_matrix4f: location:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix4f" + +external uniform_matrix2x3f: location:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix2x3f" +external uniform_matrix3x2f: location:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix3x2f" + +external uniform_matrix2x4f: location:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix2x4f" +external uniform_matrix4x2f: location:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix4x2f" + +external uniform_matrix3x4f: location:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix3x4f" +external uniform_matrix4x3f: location:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix4x3f" + + +external uniform_matrix2fv: location:int -> count:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix2fv" +external uniform_matrix3fv: location:int -> count:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix3fv" +external uniform_matrix4fv: location:int -> count:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix4fv" + +external uniform_matrix2x3fv: location:int -> count:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix2x3fv" +external uniform_matrix3x2fv: location:int -> count:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix3x2fv" + +external uniform_matrix2x4fv: location:int -> count:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix2x4fv" +external uniform_matrix4x2fv: location:int -> count:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix4x2fv" + +external uniform_matrix3x4fv: location:int -> count:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix3x4fv" +external uniform_matrix4x3fv: location:int -> count:int -> transpose:bool -> value:float array -> unit = "ml_gluniformmatrix4x3fv" + + +external get_attrib_location: program:shader_program -> name:string -> int = "ml_glgetattriblocation" +external bind_attrib_location: program:shader_program -> index:int -> name:string -> unit = "ml_glbindattriblocation" + + +external vertex_attrib1s: index:int -> v:int -> unit = "ml_glvertexattrib1s" +external vertex_attrib1d: index:int -> v:float -> unit = "ml_glvertexattrib1d" +external vertex_attrib2s: index:int -> v0:int -> v1:int -> unit = "ml_glvertexattrib2s" +external vertex_attrib2d: index:int -> v0:float -> v1:float -> unit = "ml_glvertexattrib2d" +external vertex_attrib3s: index:int -> v0:int -> v1:int -> v2:int -> unit = "ml_glvertexattrib3s" +external vertex_attrib3d: index:int -> v0:float -> v1:float -> v2:float -> unit = "ml_glvertexattrib3d" +external vertex_attrib4s: index:int -> v0:int -> v1:int -> v2:int -> v3:int -> unit = "ml_glvertexattrib4s" +external vertex_attrib4d: index:int -> v0:float -> v1:float -> v2:float -> v3:float -> unit = "ml_glvertexattrib4d" + +external get_shader_infolog: shader:shader_object -> string = "ml_glgetshaderinfolog" +external get_program_infolog: program:shader_program -> string = "ml_glgetprograminfolog" + diff --git a/src/glShader.mli b/src/glShader.mli new file mode 100644 index 0000000..92e3d35 --- /dev/null +++ b/src/glShader.mli @@ -0,0 +1,81 @@ +(* $Id: glShader.mli,v 1.1 2010-03-11 08:30:02 garrigue Exp $ *) +(* Code contributed by Florent Monnier *) + +(** GLSL Shaders *) + +type shader_object +type shader_program + +val create: shader_type:[`vertex_shader|`fragment_shader] -> shader_object +val delete: shader:shader_object -> unit +val source: shader:shader_object -> string -> unit +val compile: shader:shader_object -> unit +val create_program: unit -> shader_program +val delete_program: program:shader_program -> unit +val attach: program:shader_program -> shader:shader_object -> unit +val detach: program:shader_program -> shader:shader_object -> unit +val link_program: program:shader_program -> unit +val use_program: program:shader_program -> unit +val unuse_program: unit -> unit +val shader_compile_status: shader:shader_object -> bool +val shader_compile_status_exn: shader:shader_object -> unit +val get_uniform_location: program:shader_program -> name:string -> int + + +val get_program_attached_shaders: program:shader_program -> int +val get_program_active_uniforms: program:shader_program -> int +val get_program_active_attributes: program:shader_program -> int + +val get_program_validate_status: program:shader_program -> bool +val get_program_link_status: program:shader_program -> bool +val get_program_delete_status: program:shader_program -> bool + + +val uniform1f: location:int -> v0:float -> unit +val uniform2f: location:int -> v0:float -> v1:float -> unit +val uniform3f: location:int -> v0:float -> v1:float -> v2:float -> unit +val uniform4f: location:int -> v0:float -> v1:float -> v2:float -> v3:float -> unit +val uniform1i: location:int -> v0:int -> unit +val uniform2i: location:int -> v0:int -> v1:int -> unit +val uniform3i: location:int -> v0:int -> v1:int -> v2:int -> unit +val uniform4i: location:int -> v0:int -> v1:int -> v2:int -> v3:int -> unit + +val uniform1fv: location:int -> value:float array -> unit +val uniform2fv: location:int -> count:int -> value:float array -> unit +val uniform3fv: location:int -> count:int -> value:float array -> unit +val uniform4fv: location:int -> count:int -> value:float array -> unit +val uniform1iv: location:int -> value:int array -> unit +val uniform2iv: location:int -> count:int -> value:int array -> unit +val uniform3iv: location:int -> count:int -> value:int array -> unit +val uniform4iv: location:int -> count:int -> value:int array -> unit + +val uniform_matrix2fv: location:int -> count:int -> transpose:bool -> value:float array -> unit +val uniform_matrix3fv: location:int -> count:int -> transpose:bool -> value:float array -> unit +val uniform_matrix4fv: location:int -> count:int -> transpose:bool -> value:float array -> unit + +val uniform_matrix2x3fv: location:int -> count:int -> transpose:bool -> value:float array -> unit +val uniform_matrix3x2fv: location:int -> count:int -> transpose:bool -> value:float array -> unit + +val uniform_matrix2x4fv: location:int -> count:int -> transpose:bool -> value:float array -> unit +val uniform_matrix4x2fv: location:int -> count:int -> transpose:bool -> value:float array -> unit + +val uniform_matrix3x4fv: location:int -> count:int -> transpose:bool -> value:float array -> unit +val uniform_matrix4x3fv: location:int -> count:int -> transpose:bool -> value:float array -> unit + + +val get_attrib_location: program:shader_program -> name:string -> int +val bind_attrib_location: program:shader_program -> index:int -> name:string -> unit + + +val vertex_attrib1s: index:int -> v:int -> unit +val vertex_attrib1d: index:int -> v:float -> unit +val vertex_attrib2s: index:int -> v0:int -> v1:int -> unit +val vertex_attrib2d: index:int -> v0:float -> v1:float -> unit +val vertex_attrib3s: index:int -> v0:int -> v1:int -> v2:int -> unit +val vertex_attrib3d: index:int -> v0:float -> v1:float -> v2:float -> unit +val vertex_attrib4s: index:int -> v0:int -> v1:int -> v2:int -> v3:int -> unit +val vertex_attrib4d: index:int -> v0:float -> v1:float -> v2:float -> v3:float -> unit + +val get_shader_infolog: shader:shader_object -> string +val get_program_infolog: program:shader_program -> string + diff --git a/src/glTex.ml b/src/glTex.ml new file mode 100644 index 0000000..71aefe1 --- /dev/null +++ b/src/glTex.ml @@ -0,0 +1,121 @@ +(* $Id: glTex.ml,v 1.14 2012-03-06 03:31:02 garrigue Exp $ *) + +open Gl +open GlPix + +external coord1 : float -> unit = "ml_glTexCoord1d" +external coord2 : float -> float -> unit = "ml_glTexCoord2d" +external coord3 : float -> float -> float -> unit = "ml_glTexCoord3d" +external coord4 : float -> float -> float -> float -> unit + = "ml_glTexCoord4d" + +(*external multi_coord2 : *) + +let default x = function Some x -> x | None -> x +let coord ~s ?t ?r ?q () = + match q with + Some q -> coord4 s (default 0.0 t) (default 0.0 r) q + | None -> match r with + Some r -> coord3 s (default 0.0 t) r + | None -> match t with + Some t -> coord2 s t + | None -> coord1 s +let coord2 (s,t) = coord2 s t +let coord3 (s,t,r) = coord3 s t r +let coord4 (s,t,r,q) = coord4 s t r q +type env_param = [ + `mode of [`modulate|`decal|`blend|`replace] + | `color of rgba +] +external env : env_param -> unit = "ml_glTexEnv" +type coord = [`s|`t|`r|`q] +type gen_param = [ + `mode of [`object_linear|`eye_linear|`sphere_map] + | `object_plane of point4 + | `eye_plane of point4 +] +external gen : coord:coord -> gen_param -> unit = "ml_glTexGen" + +let npot = ref None + +let check_pow2 n = + if !npot = None then + npot := Some (GlMisc.check_extension "GL_ARB_texture_non_power_of_two"); + (!npot = Some true) || (n land (n - 1) = 0) + +type format = [ + `color_index + | `red + | `green + | `blue + | `alpha + | `rgb + | `bgr + | `rgba + | `bgra + | `luminance + | `luminance_alpha +] + +external image1d : + proxy:bool -> level:int -> internal:int -> + width:int -> border:int -> format:[< format] -> [< kind] Raw.t -> unit + = "ml_glTexImage1D_bc""ml_glTexImage1D" +let image1d ?(proxy=false) ?(level=0) ?internal:i ?(border=false) img = + let internal = match i with None -> format_size (format img) | Some i -> i in + let border = if border then 1 else 0 in + if not (check_pow2 (width img - 2 * border)) then + raise (GLerror "Gl.image1d : bad width"); + if height img < 1 then raise (GLerror "Gl.image1d : bad height"); + image1d ~proxy ~level ~internal ~width:(width img) ~border + ~format:(format img) (to_raw img) +external image2d : + proxy:bool -> level:int -> internal:int -> width:int -> + height:int -> border:int -> format:[< format] -> [< kind] Raw.t -> unit + = "ml_glTexImage2D_bc""ml_glTexImage2D" +let image2d ?(proxy=false) ?(level=0) ?internal:i ?(border=false) img = + let internal = match i with None -> format_size (format img) | Some i -> i in + let border = if border then 1 else 0 in + if not (check_pow2 (width img - 2 * border)) then + raise (GLerror "Gl.image2d : bad width"); + if not (check_pow2 (height img - 2 * border)) then + raise (GLerror "Gl.image2d : bad height"); + image2d ~proxy ~level ~internal ~border + ~width:(width img) ~height:(height img) ~format:(format img) (to_raw img) +type filter = [ + `nearest + | `linear + | `nearest_mipmap_nearest + | `linear_mipmap_nearest + | `nearest_mipmap_linear + | `linear_mipmap_linear +] +type wrap = [`clamp|`repeat] +type parameter = [ + `min_filter of filter + | `mag_filter of [`nearest|`linear] + | `wrap_s of wrap + | `wrap_t of wrap + | `border_color of rgba + | `priority of clampf + | `generate_mipmap of bool +] +external parameter : target:[`texture_1d|`texture_2d] -> parameter -> unit + = "ml_glTexParameter" + +type texture_id = nativeint +external _gen_textures : int -> [`uint] Raw.t -> unit = "ml_glGenTextures" +let gen_textures ~len = + let raw = Raw.create `uint ~len in + _gen_textures len raw; + let arr = Array.create len Nativeint.zero in + for i = 0 to len - 1 do + arr.(i) <- Raw.get_long raw ~pos:i + done; + arr +let gen_texture () = (gen_textures 1).(0) + +external bind_texture : target:[`texture_1d|`texture_2d] -> texture_id -> unit + = "ml_glBindTexture" +external delete_texture : texture_id -> unit = "ml_glDeleteTexture" +let delete_textures a = Array.iter (fun id -> delete_texture id) a diff --git a/src/glTex.mli b/src/glTex.mli new file mode 100644 index 0000000..a779b26 --- /dev/null +++ b/src/glTex.mli @@ -0,0 +1,53 @@ +(* $Id: glTex.mli,v 1.8 2012-03-06 03:31:02 garrigue Exp $ *) + +open Gl + +val coord : s:float -> ?t:float -> ?r:float -> ?q:float -> unit -> unit +val coord2 : float * float -> unit +val coord3 : float * float * float -> unit +val coord4 : float * float * float * float -> unit + +type env_param = [ + `mode of [`modulate|`decal|`blend|`replace] + | `color of rgba] +val env : env_param -> unit + +type coord = [`s|`t|`r|`q] +type gen_param = [ + `mode of [`object_linear|`eye_linear|`sphere_map] + | `object_plane of point4 + | `eye_plane of point4 +] +val gen : coord:coord -> gen_param -> unit + +type format = + [`color_index|`red|`green|`blue|`alpha|`rgb|`bgr|`rgba|`bgra + |`luminance|`luminance_alpha] +val image1d : + ?proxy:bool -> ?level:int -> ?internal:int -> ?border:bool -> + ([< format], [< kind]) GlPix.t -> unit +val image2d : + ?proxy:bool -> ?level:int -> ?internal:int -> ?border:bool -> + ([< format], [< kind]) GlPix.t -> unit + +type filter = + [`nearest|`linear|`nearest_mipmap_nearest|`linear_mipmap_nearest + |`nearest_mipmap_linear|`linear_mipmap_linear] +type wrap = [`clamp|`repeat] +type parameter = [ + `min_filter of filter + | `mag_filter of [`nearest|`linear] + | `wrap_s of wrap + | `wrap_t of wrap + | `border_color of rgba + | `priority of clampf + | `generate_mipmap of bool +] +val parameter : target:[`texture_1d|`texture_2d] -> parameter -> unit + +type texture_id +val gen_texture : unit -> texture_id +val gen_textures : len:int -> texture_id array +val bind_texture : target:[`texture_1d|`texture_2d] -> texture_id -> unit +val delete_texture : texture_id -> unit +val delete_textures : texture_id array -> unit diff --git a/src/gl_tags.var b/src/gl_tags.var new file mode 100644 index 0000000..33f5c3e --- /dev/null +++ b/src/gl_tags.var @@ -0,0 +1,283 @@ +(* GLenum *) + +color +depth +accum +stencil +points +lines +polygon +triangles +quads +line_strip +line_loop +triangle_strip +triangle_fan +quad_strip + +front +back +both -> GL_FRONT_AND_BACK + +point +line +fill + +cw +ccw + +modelview +projection +texture + +modelview_matrix +projection_matrix +texture_matrix + +(* glEnable *) +alpha_test +auto_normal +blend +clip_plane0 +clip_plane1 +clip_plane2 +clip_plane3 +clip_plane4 +clip_plane5 +(* color_logic_op *) +color_material +cull_face +depth_test +dither +fog +(* index_logic_op *) +light0 +light1 +light2 +light3 +light4 +light5 +light6 +light7 +lighting +line_smooth +line_stipple +logic_op +index_logic_op +color_logic_op +map1_color_4 +map1_index +map1_normal +map1_texture_coord_1 +map1_texture_coord_2 +map1_texture_coord_3 +map1_texture_coord_4 +map1_vertex_3 +map1_vertex_4 +map2_color_4 +map2_index +map2_normal +map2_texture_coord_1 +map2_texture_coord_2 +map2_texture_coord_3 +map2_texture_coord_4 +map2_vertex_3 +map2_vertex_4 +normalize +point_smooth +polygon_offset_fill +polygon_offset_line +polygon_offset_point +polygon_smooth +polygon_stipple +scissor_test +stencil_test +texture_1d +texture_2d +texture_gen_q +texture_gen_r +texture_gen_s +texture_gen_t + +(* glShadeModel *) +flat +smooth + +(* glLight *) +ambient +diffuse +specular +position +spot_direction +spot_exponent +spot_cutoff +constant_attenuation +linear_attenuation +quadratic_attenuation + +(* glMaterial *) +(* ambient *) +(* diffuse *) +(* specular *) +emission +shininess +ambient_and_diffuse +color_indexes + +(* glDepthFunc, glAlphaFunc *) +never less equal lequal greater notequal gequal always + +(* glBlendFunc *) +zero +one +dst_color +one_minus_dst_color +src_alpha +one_minus_src_alpha +dst_alpha +one_minus_dst_alpha +src_alpha_saturate +src_color +one_minus_src_color + +(* glFog *) +linear exp exp2 + +(* glNewList *) +compile compile_and_execute + +(* data types *) +bitmap byte short int float double +ubyte -> GL_UNSIGNED_BYTE +ushort -> GL_UNSIGNED_SHORT +uint -> GL_UNSIGNED_INT + +(* glAccum *) +load add mult return + +(* glDrawPixels *) +color_index stencil_index depth_component rgb bgr rgba bgra +red green blue alpha luminance luminance_alpha + +(* glHint *) +dont_care fastest nicest + +(* glLogicOp *) +clear set copy copy_inverted noop invert And nand Or nor +xor equiv and_reverse and_inverted or_reverse or_inverted + +(* glPixelTransfer *) +alpha_bias +alpha_scale +blue_bias +blue_scale +depth_bias +depth_scale +green_bias +green_scale +index_offset +index_shift +map_color +map_stencil +red_bias +red_scale + +(* glPixelMap *) +i_to_i -> GL_PIXEL_MAP_I_TO_I +i_to_r -> GL_PIXEL_MAP_I_TO_R +i_to_g -> GL_PIXEL_MAP_I_TO_G +i_to_b -> GL_PIXEL_MAP_I_TO_B +i_to_a -> GL_PIXEL_MAP_I_TO_A +s_to_s -> GL_PIXEL_MAP_S_TO_S +r_to_r -> GL_PIXEL_MAP_R_TO_R +g_to_g -> GL_PIXEL_MAP_G_TO_G +b_to_b -> GL_PIXEL_MAP_B_TO_B +a_to_a -> GL_PIXEL_MAP_A_TO_A + +(* glPixelStore *) +pack_swap_bytes +pack_lsb_first +pack_row_length +pack_skip_pixels +pack_skip_rows +pack_alignment +unpack_swap_bytes +unpack_lsb_first +unpack_row_length +unpack_skip_pixels +unpack_skip_rows +unpack_alignment + +(* glReadBuffer *) +front_left front_right back_left back_right left right + +(* glDrawBuffer *) +none + +(* glStencilOp *) +keep replace incr decr + +(* glTexEnv *) +modulate decal + +(* glTexGen *) +s t r q +object_plane eye_plane +eye_linear object_linear sphere_map + +(* glTexParameter *) +min_filter -> GL_TEXTURE_MIN_FILTER +mag_filter -> GL_TEXTURE_MAG_FILTER +wrap_s -> GL_TEXTURE_WRAP_S +wrap_t -> GL_TEXTURE_WRAP_T +border_color -> GL_TEXTURE_BORDER_COLOR +priority -> GL_TEXTURE_PRIORITY +nearest nearest_mipmap_nearest linear_mipmap_nearest +nearest_mipmap_linear linear_mipmap_linear +generate_mipmap +clamp repeat + +(* glGetString *) +vendor renderer version extensions + +(* glRenderMode *) +render select feedback + +(* glFeedBackBuffer *) +_2d -> GL_2D +_3d -> GL_3D +_3d_color -> GL_3D_COLOR +_3d_color_texture -> GL_3D_COLOR_TEXTURE +_4d_color_texture -> GL_4D_COLOR_TEXTURE + +$$ +(* glLightModel *) +local_viewer two_side mode density start index End +color_control separate_specular_color single_color + +(* glHint *) +perspective_correction + +(* glMap1, glMap2 *) +vertex_3 vertex_4 color_4 normal texture_coord_1 texture_coord_2 +texture_coord_3 texture_coord_4 + +(* glPushAttrib *) +accum_buffer color_buffer current depth_buffer enable eval +hint list pixel_mode scissor stencil_buffer transform viewport + +(* glReadBuffer *) +aux + +(* glArray *) +edge_flag texture_coord vertex +two three four + +(* glGetError *) +no_error +invalid_enum invalid_value invalid_operation +stack_overflow stack_underflow +out_of_memory table_too_large + +(* glCreateShader *) +vertex_shader fragment_shader diff --git a/src/gluMat.ml b/src/gluMat.ml new file mode 100644 index 0000000..f66bcd3 --- /dev/null +++ b/src/gluMat.ml @@ -0,0 +1,28 @@ +(* $Id: gluMat.ml,v 1.2 2000-04-12 07:40:25 garrigue Exp $ *) + +open Gl + +external look_at : + eye:(float * float * float) -> + center:(float * float * float) -> + up:(float * float * float) -> unit + = "ml_gluLookAt" + +external ortho2d : + left:float -> right:float -> bottom:float -> top:float -> unit + = "ml_gluOrtho2D" +let ortho2d ~x:(left,right) ~y:(bottom,top) = + ortho2d ~left ~right ~bottom ~top + +external perspective : + fovy:float -> aspect:float -> znear:float -> zfar:float -> unit + = "ml_gluPerspective" +let perspective ~fovy ~aspect ~z:(znear,zfar) = + perspective ~fovy ~aspect ~znear ~zfar + +external pick_matrix : + x:float -> y:float -> width:float -> height:float -> unit + = "ml_gluPickMatrix" + +external project : point3 -> point3 = "ml_gluProject" +external unproject : point3 -> point3 = "ml_gluUnProject" diff --git a/src/gluMat.mli b/src/gluMat.mli new file mode 100644 index 0000000..18dad0d --- /dev/null +++ b/src/gluMat.mli @@ -0,0 +1,16 @@ +(* $Id: gluMat.mli,v 1.1 1998-01-29 11:46:06 garrigue Exp $ *) + +open Gl + +val look_at : + eye:point3 -> center:point3 -> up:vect3 -> unit + +val ortho2d : x:float * float -> y:float * float -> unit + +val perspective : fovy:float -> aspect:float -> z:float * float -> unit + +val pick_matrix : + x:float -> y:float -> width:float -> height:float -> unit + +val project : point3 -> point3 +val unproject : point3 -> point3 diff --git a/src/gluMisc.ml b/src/gluMisc.ml new file mode 100644 index 0000000..7a5c408 --- /dev/null +++ b/src/gluMisc.ml @@ -0,0 +1,38 @@ +(* $Id: gluMisc.ml,v 1.6 2003-02-06 18:19:12 furuse Exp $ *) + +open Gl +open GlPix + +external build_1d_mipmaps : + internal:int -> + width:int -> format:[< GlTex.format] -> [< kind] Raw.t -> unit + = "ml_gluBuild1DMipmaps" +let build_1d_mipmaps ?internal:i img = + let internal = match i with None -> format_size (format img) | Some i -> i in + if height img < 1 then + raise (GLerror "GluMisc.build_1d_mipmaps : bad height"); + build_1d_mipmaps ~internal + ~width:(width img) ~format:(format img) (to_raw img) + +external build_2d_mipmaps : + internal:int -> width:int -> + height:int -> format:[< GlTex.format] -> [< kind] Raw.t -> unit + = "ml_gluBuild2DMipmaps" +let build_2d_mipmaps ?internal:i img = + let internal = match i with None -> format_size (format img) | Some i -> i in + build_2d_mipmaps ~internal + ~width:(width img) ~height:(height img) ~format:(format img) (to_raw img) + +external get_string : [`version|`extensions] -> string = "ml_gluGetString" + +external scale_image : + format:[< Gl.format] -> + w:int -> h:int -> data:[< kind] Raw.t -> + w:int -> h:int -> data:[< kind] Raw.t -> unit + = "ml_gluScaleImage_bc" "ml_gluScaleImage" +let scale_image ~width ~height img = + let k = Raw.kind (to_raw img) and format = format img in + let new_img = GlPix.create k ~format ~height ~width in + scale_image ~format ~w:(GlPix.width img) ~h:(GlPix.height img) + ~data:(to_raw img) ~w:width ~h:height ~data:(to_raw new_img); + new_img diff --git a/src/gluMisc.mli b/src/gluMisc.mli new file mode 100644 index 0000000..ed5ba3c --- /dev/null +++ b/src/gluMisc.mli @@ -0,0 +1,15 @@ +(* $Id: gluMisc.mli,v 1.3 2001-10-01 02:59:13 garrigue Exp $ *) + +open Gl + +val get_string : [`extensions|`version] -> string + +val build_1d_mipmaps : + ?internal:int -> ([< GlTex.format], [< kind]) GlPix.t -> unit + +val build_2d_mipmaps : + ?internal:int -> ([< GlTex.format], [< kind]) GlPix.t -> unit + +val scale_image : + width:int -> height:int -> + ([< format] as 'a, [< kind] as 'b) GlPix.t -> ('a, 'b) GlPix.t diff --git a/src/gluNurbs.ml b/src/gluNurbs.ml new file mode 100644 index 0000000..e169b5d --- /dev/null +++ b/src/gluNurbs.ml @@ -0,0 +1,77 @@ +(* $Id: gluNurbs.ml,v 1.6 2001-10-01 02:59:13 garrigue Exp $ *) + +open Gl + +type t + +external begin_curve : t -> unit = "ml_gluBeginCurve" +external begin_surface : t -> unit = "ml_gluBeginSurface" +external begin_trim : t -> unit = "ml_gluBeginTrim" + +external end_curve : t -> unit = "ml_gluEndCurve" +external end_surface : t -> unit = "ml_gluEndSurface" +external end_trim : t -> unit = "ml_gluEndTrim" + +external load_sampling_matrices : + t -> model:[`float] Raw.t -> + persp:[`float] Raw.t -> view:[`int] Raw.t -> unit + = "ml_gluLoadSamplingMatrices" + +external create : unit -> t = "ml_gluNewNurbsRenderer" + +external curve : + t -> knots:[`float] Raw.t -> control:[`float] Raw.t -> + order:int -> kind:[< GlMap.target] -> unit + = "ml_gluNurbsCurve" +let curve nurb ~knots ~control ~order ~kind:t = + let arity = target_size t in + if (Array.length knots - order) * arity <> Array.length control + then invalid_arg "GluNurbs.curve"; + let knots = Raw.of_float_array ~kind:`float knots + and control = Raw.of_float_array ~kind:`float control in + curve nurb ~knots ~control ~order ~kind:t + +type property = [ + `sampling_method of [`path_length|`parametric_error|`domain_distance] + | `sampling_tolerance of int + | `parametric_tolerance of float + | `u_step of int + | `v_step of int + | `display_mode of [`fill|`polygon|`patch] + | `culling of bool + | `auto_load_matrix of bool +] +external property : t -> property -> unit + = "ml_gluNurbsProperty" + +external surface : + t -> sknots:[`float] Raw.t -> tknots:[`float] Raw.t -> + tstride:int -> control:[`float] Raw.t -> + sorder:int -> torder:int -> target:[< target] -> unit + = "ml_gluNurbsSurface_bc" "ml_gluNurbsSurface" +let surface t ~sknots ~tknots ~control ~sorder ~torder ~target = + let cl = Array.length control in + if cl = 0 then invalid_arg "GluNurb.curve"; + let tstride = Array.length control.(0) in + let sl = Array.length sknots and tl = Array.length tknots in + if tl <> cl + torder or (sl - sorder) * target_size target <> tstride + then invalid_arg "GluNurb.curve"; + let sknots = Raw.of_float_array ~kind:`float sknots in + let tknots = Raw.of_float_array ~kind:`float tknots in + let co = Raw.create `float ~len:(cl * tstride) in + for i = 0 to cl - 1 do + if Array.length control.(i) <> tstride then invalid_arg "GluNurb.curve"; + Raw.sets_float co ~pos:(i*tstride) control.(i) + done; + surface t ~sknots ~tknots ~tstride ~control:co + ~sorder ~torder ~target + +external pwl_curve : + t -> count:int -> [`float] Raw.t -> kind:[`trim_2|`trim_3] -> unit + = "ml_gluPwlCurve" +let pwl_curve nurb ~kind:t data = + let len = Array.length data + and raw = Raw.of_float_array ~kind:`float data + and stride = match t with `trim_2 -> 2 | `trim_3 -> 3 in + if len mod stride <> 0 then invalid_arg "GluNurb.pwl_curve"; + pwl_curve nurb ~count:(len/stride) raw ~kind:t diff --git a/src/gluNurbs.mli b/src/gluNurbs.mli new file mode 100644 index 0000000..d66235f --- /dev/null +++ b/src/gluNurbs.mli @@ -0,0 +1,42 @@ +(* $Id: gluNurbs.mli,v 1.5 2001-10-01 02:59:13 garrigue Exp $ *) + +type t + +val create : unit -> t + +val begin_curve : t -> unit +val begin_surface : t -> unit +val begin_trim : t -> unit + +val end_curve : t -> unit +val end_surface : t -> unit +val end_trim : t -> unit + +val load_sampling_matrices : + t -> + model:[`float] Raw.t -> persp:[`float] Raw.t -> view:[`int] Raw.t -> unit + +val curve : + t -> knots:float array -> + control:float array -> order:int -> kind:[< GlMap.target] -> unit + +val pwl_curve : t -> kind:[`trim_2|`trim_3] -> float array -> unit + +val surface : + t -> + sknots:float array -> + tknots:float array -> + control:float array array -> + sorder:int -> torder:int -> target:[< Gl.target] -> unit + +type property = [ + `sampling_method of [`path_length|`parametric_error|`domain_distance] + | `sampling_tolerance of int + | `parametric_tolerance of float + | `u_step of int + | `v_step of int + | `display_mode of [`fill|`polygon|`patch] + | `culling of bool + | `auto_load_matrix of bool +] +val property : t -> property -> unit diff --git a/src/gluQuadric.ml b/src/gluQuadric.ml new file mode 100644 index 0000000..7c1e641 --- /dev/null +++ b/src/gluQuadric.ml @@ -0,0 +1,40 @@ +(* $Id: gluQuadric.ml,v 1.5 2000-04-12 07:40:26 garrigue Exp $ *) + +type t + +external create : unit -> t = "ml_gluNewQuadric" + +external cylinder : + t -> base:float -> top:float -> height:float -> + slices:int -> stacks:int -> unit + = "ml_gluCylinder_bc" "ml_gluCylinder" +let cylinder ~base ~top ~height ~slices ~stacks ?(quad = create ()) () = + cylinder ~base ~top ~height ~slices ~stacks quad + +external disk : + t -> inner:float -> outer:float -> slices:int -> loops:int -> unit + = "ml_gluDisk" +let disk ~inner ~outer ~slices ~loops ?(quad = create ()) () = + disk ~inner ~outer ~slices ~loops quad + +external partial_disk : + t -> inner:float -> outer:float -> + slices:int -> loops:int -> start:float -> sweep:float -> unit + = "ml_gluPartialDisk_bc" "ml_gluPartialDisk" +let partial_disk ~inner ~outer ~slices ~loops ~start ~sweep + ?(quad = create ()) () = + partial_disk ~inner ~outer ~slices ~loops ~start ~sweep quad + +external draw_style : t -> [`fill|`line|`silhouette|`point] -> unit + = "ml_gluQuadricDrawStyle" +external normals : t -> [`none|`flat|`smooth] -> unit + = "ml_gluQuadricNormals" +external orientation : t -> [`inside|`outside] -> unit + = "ml_gluQuadricOrientation" +external texture : t -> bool -> unit + = "ml_gluQuadricTexture" + +external sphere : t -> radius:float -> slices:int -> stacks:int -> unit + = "ml_gluSphere" +let sphere ~radius ~slices ~stacks ?(quad = create ()) () = + sphere ~radius ~slices ~stacks quad diff --git a/src/gluQuadric.mli b/src/gluQuadric.mli new file mode 100644 index 0000000..22a4696 --- /dev/null +++ b/src/gluQuadric.mli @@ -0,0 +1,30 @@ +(* $Id: gluQuadric.mli,v 1.2 1999-11-15 14:32:14 garrigue Exp $ *) + +type t + +val create : unit -> t + +(* If you omit the quadric, a new one will be created *) + +val cylinder : + base:float -> top:float -> + height:float -> slices:int -> stacks:int -> ?quad:t -> unit -> unit + +val disk : + inner:float -> outer:float -> + slices:int -> loops:int -> ?quad:t -> unit -> unit + +val partial_disk : + inner:float -> + outer:float -> + slices:int -> + loops:int -> start:float -> sweep:float -> ?quad:t -> unit -> unit + +val sphere : + radius:float -> slices:int -> stacks:int -> ?quad:t -> unit -> unit + + +val draw_style : t -> [`fill|`line|`point|`silhouette] -> unit +val normals : t -> [`flat|`none|`smooth] -> unit +val orientation : t -> [`inside|`outside] -> unit +val texture : t -> bool -> unit diff --git a/src/gluTess.ml b/src/gluTess.ml new file mode 100644 index 0000000..ba484ad --- /dev/null +++ b/src/gluTess.ml @@ -0,0 +1,18 @@ +(* $Id: gluTess.ml,v 1.7 2004-07-13 07:55:18 garrigue Exp $ *) +(* Code contributed by Jon Harrop *) + +type winding_rule = [`odd|`nonzero|`positive|`negative|`abs_geq_two] + +type vertices = (float * float * float) list + +external tesselate : + ?winding:winding_rule -> ?boundary_only:bool -> ?tolerance:float -> + vertices list -> unit + = "ml_gluTesselate" + +type triangles = + { singles: vertices list; strips: vertices list; fans: vertices list } + +external tesselate_and_return : + ?winding:winding_rule -> ?tolerance:float -> vertices list -> triangles + = "ml_gluTesselateAndReturn" diff --git a/src/gluTess.mli b/src/gluTess.mli new file mode 100644 index 0000000..96ad5b4 --- /dev/null +++ b/src/gluTess.mli @@ -0,0 +1,20 @@ +(* $Id: gluTess.mli,v 1.8 2004-07-13 09:44:03 garrigue Exp $ *) +(* Code contributed by Jon Harrop *) + +type winding_rule = [`odd|`nonzero|`positive|`negative|`abs_geq_two] + +type vertices = (float * float * float) list + +val tesselate : + ?winding:winding_rule -> ?boundary_only:bool -> ?tolerance:float -> + vertices list -> unit +(** Render directly to current screen. + Each [vertices] in the input is a contour in the single polygon + represented by [vertices list]. *) + +type triangles = + { singles: vertices list; strips: vertices list; fans: vertices list } + +val tesselate_and_return : + ?winding:winding_rule -> ?tolerance:float -> vertices list -> triangles +(** Return 3 lists of triangles instead of rendering directly *) diff --git a/src/glu_tags.var b/src/glu_tags.var new file mode 100644 index 0000000..a8fe43d --- /dev/null +++ b/src/glu_tags.var @@ -0,0 +1,38 @@ +(* $Id: glu_tags.var,v 1.5 2002-05-01 03:35:00 garrigue Exp $: tags for GLU library *) + +(* gluGetString *) +version extensions + +(* gluNextContour *) +exterior interior unknown ccw cw + +(* gluNurbsProperty *) +sampling_method path_length parametric_error domain_distance +sampling_tolerance +parametric_tolerance +u_step v_step +display_mode fill +culling auto_load_matrix +polygon -> GLU_OUTLINE_POLYGON +patch -> GLU_OUTLINE_PATCH + +(* gluQuadricDrawStyle *) +line silhouette point +(* gluQuadricNormals *) +none flat smooth +(* gluQuadricOrientation *) +inside outside + +(* gluTessProperty *) +winding_rule -> GLU_TESS_WINDING_RULE +odd -> GLU_TESS_WINDING_ODD +nonzero -> GLU_TESS_WINDING_NONZERO +positive -> GLU_TESS_WINDING_POSITIVE +negative -> GLU_TESS_WINDING_NEGATIVE +abs_geq_two -> GLU_TESS_WINDING_ABS_GEQ_TWO +boundary_only -> GLU_TESS_BOUNDARY_ONLY +tolerance -> GLU_TESS_TOLERANCE + +$$ +(* gluNurbsCurve *) +trim_2 trim_3 diff --git a/src/ml_gl.c b/src/ml_gl.c new file mode 100644 index 0000000..c9b04ad --- /dev/null +++ b/src/ml_gl.c @@ -0,0 +1,730 @@ +/* $Id: ml_gl.c,v 1.51 2007-04-13 02:48:43 garrigue Exp $ */ + +#ifdef _WIN32 +#include +#endif +#include +#ifdef __APPLE__ +#include +#else +#include +#endif +#ifdef HAS_GLEXT_H +#include +#undef GL_VERSION_1_3 +#endif +#include +#include +#include +#include +#include +#include +#include "ml_raw.h" +#include "gl_tags.h" +#include "ml_gl.h" + +#if !defined(GL_VERSION_1_4) +#define GL_GENERATE_MIPMAP 0x8191 +#endif + +/* #include */ + +void ml_raise_gl(const char *errmsg) +{ + static value * gl_exn = NULL; + if (gl_exn == NULL) + gl_exn = caml_named_value("glerror"); + raise_with_string(*gl_exn, (char*)errmsg); +} + +value copy_string_check (const char *str) +{ + if (!str) ml_raise_gl("Null string"); + return copy_string ((char*) str); +} + +struct record { + value key; + GLenum data; +}; + +static struct record input_table[] = { +#include "gl_tags.c" +}; + +static struct record *tag_table = NULL; + +#define TABLE_SIZE (TAG_NUMBER*2+1) + +CAMLprim value ml_gl_make_table (value unit) +{ + int i; + unsigned int hash; + + tag_table = stat_alloc (TABLE_SIZE * sizeof(struct record)); + memset ((char *) tag_table, 0, TABLE_SIZE * sizeof(struct record)); + for (i = 0; i < TAG_NUMBER; i++) { + hash = (unsigned long) input_table[i].key % TABLE_SIZE; + while (tag_table[hash].key != 0) { + hash ++; + if (hash == TABLE_SIZE) hash = 0; + } + tag_table[hash].key = input_table[i].key; + tag_table[hash].data = input_table[i].data; + } + return Val_unit; +} + +GLenum GLenum_val(value tag) +{ + unsigned int hash = (unsigned long) tag % TABLE_SIZE; + + if (!tag_table) ml_gl_make_table (Val_unit); + while (tag_table[hash].key != tag) { + if (tag_table[hash].key == 0) ml_raise_gl ("Unknown tag"); + hash++; + if (hash == TABLE_SIZE) hash = 0; + } + /* + fprintf(stderr, "Converted %ld to %d", Int_val(tag), tag_table[hash].data); + */ + return tag_table[hash].data; +} + +/* +GLenum GLenum_val(value tag) +{ + switch(tag) + { +#include "gl_tags.c" + } + ml_raise_gl("Unknown tag"); +} +*/ + +ML_2 (glAccum, GLenum_val, Float_val) +ML_2 (glAlphaFunc, GLenum_val, Float_val) + +ML_1 (glBegin, GLenum_val) + +ML_5 (glBitmap, Int_val, Int_val, Pair(arg3,Float_val,Float_val), + Pair(arg4,Float_val,Float_val), Void_raw) + +ML_2 (glBlendFunc, GLenum_val, GLenum_val) + +CAMLprim value ml_glClipPlane(value plane, value equation) /* ML */ +{ + double eq[4]; + int i; + + for (i = 0; i < 4; i++) + eq[i] = Double_val (Field(equation,i)); + glClipPlane (GL_CLIP_PLANE0 + Int_val(plane), eq); + return Val_unit; +} + +CAMLprim value ml_glClear(value bit_list) /* ML */ +{ + GLbitfield accu = 0; + + while (bit_list != Val_int(0)) { + switch (Field (bit_list, 0)) { + case MLTAG_color: + accu |= GL_COLOR_BUFFER_BIT; break; + case MLTAG_depth: + accu |= GL_DEPTH_BUFFER_BIT; break; + case MLTAG_accum: + accu |= GL_ACCUM_BUFFER_BIT; break; + case MLTAG_stencil: + accu |= GL_STENCIL_BUFFER_BIT; break; + } + bit_list = Field (bit_list, 1); + } + glClear (accu); + return Val_unit; +} +ML_4 (glClearAccum, Float_val, Float_val, Float_val, Float_val) +ML_4 (glClearColor, Double_val, Double_val, Double_val, Double_val) +ML_1 (glClearDepth, Double_val) +ML_1 (glClearIndex, Float_val) +ML_1 (glClearStencil, Int_val) +ML_4 (glColor4d, Double_val, Double_val, Double_val, Double_val) +ML_4 (glColorMask, Int_val, Int_val, Int_val, Int_val) +ML_2 (glColorMaterial, GLenum_val, GLenum_val) +ML_5 (glCopyPixels, Int_val, Int_val, Int_val, Int_val, GLenum_val) +ML_1 (glCullFace, GLenum_val) + +ML_1 (glDisable, GLenum_val) +ML_1 (glDepthFunc, GLenum_val) +ML_1 (glDepthMask, Int_val) +ML_2 (glDepthRange, Double_val, Double_val) + +CAMLprim value ml_glDrawBuffer (value buffer) +{ + if (Is_block(buffer)) { + int n = Int_val (Field(buffer,1)); + if (n >= GL_AUX_BUFFERS) + ml_raise_gl ("GlFunc.draw_buffer : no such auxiliary buffer"); + glDrawBuffer (GL_AUX0 + n); + } + else glDrawBuffer (GLenum_val(buffer)); + return Val_unit; +} + +ML_4 (glDrawPixels, Int_val, Int_val, GLenum_val, Type_void_raw) + +ML_1 (glEdgeFlag, Int_val) +ML_1 (glEnable, GLenum_val) +ML_0 (glEnd) +ML_1 (glEvalCoord1d, Double_val) +ML_2 (glEvalCoord2d, Double_val, Double_val) +ML_3 (glEvalMesh1, GLenum_val, Int_val, Int_val) +ML_5 (glEvalMesh2, GLenum_val, Int_val, Int_val, Int_val, Int_val) +ML_1 (glEvalPoint1, Int_val) +ML_2 (glEvalPoint2, Int_val, Int_val) + + +ML_3 (glFeedbackBuffer, Int_val, GLenum_val, (GLfloat*)Addr_raw) + +CAMLprim value ml_glFog (value param) /* ML */ +{ + float params[4]; + int i; + + switch (Field(param,0)) + { + case MLTAG_mode: + glFogi(GL_FOG_MODE, GLenum_val(Field(param,1))); + break; + case MLTAG_density: + glFogf(GL_FOG_DENSITY, Float_val(Field(param,1))); + break; + case MLTAG_start: + glFogf(GL_FOG_START, Float_val(Field(param,1))); + break; + case MLTAG_End: + glFogf(GL_FOG_END, Float_val(Field(param,1))); + break; + case MLTAG_index: + glFogf(GL_FOG_INDEX, Float_val(Field(param,1))); + break; + case MLTAG_color: + for (i = 0; i < 4; i++) params[i] = Float_val(Field(Field(param,1),i)); + glFogfv(GL_FOG_COLOR, params); + break; + } + return Val_unit; +} + +ML_0 (glFlush) +ML_0 (glFinish) +ML_1 (glFrontFace, GLenum_val) +ML_3 (glFrustum, Pair(arg1,Double_val,Double_val), + Pair(arg2,Double_val,Double_val), Pair(arg3,Double_val,Double_val)) + +ML_1_ (glGetString, GLenum_val, copy_string_check) +ML_2 (glGetDoublev, GLenum_val, Double_raw) + +CAMLprim value ml_glGetError(value unit) +{ + switch (glGetError()) { + case GL_NO_ERROR: return MLTAG_no_error; + case GL_INVALID_ENUM: return MLTAG_invalid_enum; + case GL_INVALID_VALUE: return MLTAG_invalid_value; + case GL_INVALID_OPERATION: return MLTAG_invalid_operation; + case GL_STACK_OVERFLOW: return MLTAG_stack_overflow; + case GL_STACK_UNDERFLOW: return MLTAG_stack_underflow; + case GL_OUT_OF_MEMORY: return MLTAG_out_of_memory; +#if defined(GL_VERSION_1_2) || defined(GL_TABLE_TOO_LARGE) + case GL_TABLE_TOO_LARGE: return MLTAG_table_too_large; +#endif + default: ml_raise_gl("glGetError: unknown error"); + } +} + +CAMLprim value ml_glHint (value target, value hint) +{ + GLenum targ = 0U; + + switch (target) { + case MLTAG_fog: targ = GL_FOG_HINT; break; + case MLTAG_line_smooth: targ = GL_LINE_SMOOTH_HINT; break; + case MLTAG_perspective_correction: + targ = GL_PERSPECTIVE_CORRECTION_HINT; break; + case MLTAG_point_smooth: targ = GL_POINT_SMOOTH_HINT; break; + case MLTAG_polygon_smooth: targ = GL_POLYGON_SMOOTH_HINT; break; + } + glHint (targ, GLenum_val(hint)); + return Val_unit; +} + +ML_1 (glIndexMask, Int_val) +ML_1 (glIndexd, Double_val) +ML_0 (glInitNames) +ML_1_ (glIsEnabled, GLenum_val, Val_int) + +CAMLprim value ml_glLight (value n, value param) /* ML */ +{ + float params[4]; + int i; + + if (Int_val(n) >= GL_MAX_LIGHTS) invalid_argument ("Gl.light"); + switch (Field(param,0)) + { + case MLTAG_ambient: + case MLTAG_diffuse: + case MLTAG_specular: + case MLTAG_position: + for (i = 0; i < 4; i++) + params[i] = Float_val (Field(Field(param, 1), i)); + break; + case MLTAG_spot_direction: + for (i = 0; i < 3; i++) + params[i] = Float_val (Field(Field(param, 1), i)); + break; + default: + params[0] = Float_val (Field(param, 1)); + } + glLightfv (GL_LIGHT0 + Int_val(n), GLenum_val(Field(param,0)), params); + return Val_unit; +} + +CAMLprim value ml_glLightModel (value param) /* ML */ +{ + float params[4]; + int i; + + switch (Field(param,0)) + { + case MLTAG_ambient: + for (i = 0; i < 4; i++) + params[i] = Float_val (Field(Field(param,1),i)); + glLightModelfv (GL_LIGHT_MODEL_AMBIENT, params); + break; + case MLTAG_local_viewer: + glLightModelf (GL_LIGHT_MODEL_LOCAL_VIEWER, + Int_val(Field(param,1))); + break; + case MLTAG_two_side: + glLightModeli (GL_LIGHT_MODEL_TWO_SIDE, + Int_val(Field(param,1))); + break; + case MLTAG_color_control: +#ifdef GL_VERSION_1_2 + switch (Field(param,1)) + { + case MLTAG_separate_specular_color: + glLightModeli (GL_LIGHT_MODEL_COLOR_CONTROL, + GL_SEPARATE_SPECULAR_COLOR); + break; + case MLTAG_single_color: + glLightModeli (GL_LIGHT_MODEL_COLOR_CONTROL, + GL_SINGLE_COLOR); + break; + } +#else + ml_raise_gl ("Parameter: GL_LIGHT_MODEL_COLOR_CONTROL not available"); +#endif + break; + } + return Val_unit; +} + +ML_1 (glLineWidth, Float_val) +ML_2 (glLineStipple, Int_val, Int_val) +ML_1 (glLoadName, Int_val) +ML_0 (glLoadIdentity) +ML_1 (glLoadMatrixd, Double_raw) + +#ifdef GL_VERSION_1_3 +ML_1 (glLoadTransposeMatrixd, Double_raw) +#else +CAMLprim void ml_glLoadTransposeMatrixd (value raw) +{ + ml_raise_gl ("Function: glLoadTransposeMatrixd not available"); +} +#endif +ML_1 (glLogicOp, GLenum_val) + +CAMLprim value ml_glMap1d (value target, value *u, value order, value raw) +{ + int ustride = 0; + GLenum targ = 0U; + + switch (target) { + case MLTAG_vertex_3: + targ = GL_MAP1_VERTEX_3; ustride = 3; break; + case MLTAG_vertex_4: + targ = GL_MAP1_VERTEX_4; ustride = 4; break; + case MLTAG_index: + targ = GL_MAP1_INDEX; ustride = 1; break; + case MLTAG_color_4: + targ = GL_MAP1_COLOR_4; ustride = 4; break; + case MLTAG_normal: + targ = GL_MAP1_NORMAL; ustride = 3; break; + case MLTAG_texture_coord_1: + targ = GL_MAP1_TEXTURE_COORD_1; ustride = 1; break; + case MLTAG_texture_coord_2: + targ = GL_MAP1_TEXTURE_COORD_2; ustride = 2; break; + case MLTAG_texture_coord_3: + targ = GL_MAP1_TEXTURE_COORD_3; ustride = 3; break; + case MLTAG_texture_coord_4: + targ = GL_MAP1_TEXTURE_COORD_4; ustride = 4; break; + } + glMap1d (targ, Double_val(u[0]), Double_val(u[1]), + ustride, Int_val(order), Double_raw(raw)); + return Val_unit; +} + +CAMLprim value ml_glMap2d (value target, value u, value uorder, + value v, value vorder, value raw) +{ + int ustride = 0; + GLenum targ = 0U; + + switch (target) { + case MLTAG_vertex_3: + targ = GL_MAP2_VERTEX_3; ustride = 3; break; + case MLTAG_vertex_4: + targ = GL_MAP2_VERTEX_4; ustride = 4; break; + case MLTAG_index: + targ = GL_MAP2_INDEX; ustride = 1; break; + case MLTAG_color_4: + targ = GL_MAP2_COLOR_4; ustride = 4; break; + case MLTAG_normal: + targ = GL_MAP2_NORMAL; ustride = 3; break; + case MLTAG_texture_coord_1: + targ = GL_MAP2_TEXTURE_COORD_1; ustride = 1; break; + case MLTAG_texture_coord_2: + targ = GL_MAP2_TEXTURE_COORD_2; ustride = 2; break; + case MLTAG_texture_coord_3: + targ = GL_MAP2_TEXTURE_COORD_3; ustride = 3; break; + case MLTAG_texture_coord_4: + targ = GL_MAP2_TEXTURE_COORD_4; ustride = 4; break; + } + glMap2d (targ, Double_val(Field(u,0)), Double_val(Field(u,1)), ustride, + Int_val(uorder), Double_val(Field(v,0)), Double_val(Field(v,1)), + Int_val(uorder)*ustride, Int_val(vorder), Double_raw(raw)); + return Val_unit; +} + +ML_bc6 (ml_glMap2d) + +ML_2 (glMapGrid1d, Int_val, Pair(arg2,Double_val,Double_val)) +ML_4 (glMapGrid2d, Int_val, Pair(arg2,Double_val,Double_val), + Int_val, Pair(arg4,Double_val,Double_val)) + +CAMLprim value ml_glMaterial (value face, value param) /* ML */ +{ + float params[4]; + int i; + + switch (Field(param,0)) + { + case MLTAG_shininess: + params[0] = Float_val (Field(param, 1)); + break; + case MLTAG_color_indexes: + for (i = 0; i < 3; i++) + params[i] = Float_val (Field(Field(param, 1), i)); + break; + default: + for (i = 0; i < 4; i++) + params[i] = Float_val (Field(Field(param, 1), i)); + break; + } + glMaterialfv (GLenum_val(face), GLenum_val(Field(param,0)), params); + return Val_unit; +} + +ML_1 (glMatrixMode, GLenum_val) +ML_1 (glMultMatrixd, Double_raw) + +#ifdef GL_VERSION_1_3 +ML_1 (glMultTransposeMatrixd, Double_raw) +#else +CAMLprim void ml_glMultTransposeMatrixd (value raw) +{ + ml_raise_gl ("Function: glMultTransposeMatrixd not available"); +} +#endif + +ML_3 (glNormal3d, Double_val, Double_val, Double_val) + +ML_1 (glPassThrough, Float_val) + +CAMLprim value ml_glPixelMapfv (value map, value raw) +{ + glPixelMapfv (GLenum_val(map), Int_val(Size_raw(raw))/sizeof(GLfloat), + Float_raw(raw)); + return Val_unit; +} + +ML_3 (glOrtho, Pair(arg1,Double_val,Double_val), + Pair(arg2,Double_val,Double_val), Pair(arg3,Double_val,Double_val)) + +ML_1 (glPixelStorei, Pair(arg1,GLenum_val,Int_val)) + +CAMLprim value ml_glPixelTransfer (value param) +{ + GLenum pname = GLenum_val (Field(param,0)); + + switch (pname) { + case GL_MAP_COLOR: + case GL_MAP_STENCIL: + case GL_INDEX_SHIFT: + case GL_INDEX_OFFSET: + glPixelTransferi (pname, Int_val (Field(param,1))); + break; + default: + glPixelTransferf (pname, Float_val (Field(param,1))); + } + return Val_unit; +} + +ML_2 (glPixelZoom, Float_val, Float_val) +ML_1 (glPointSize, Float_val) +ML_2 (glPolygonOffset, Float_val, Float_val) +ML_2 (glPolygonMode, GLenum_val, GLenum_val) +ML_1 (glPolygonStipple, (unsigned char *)Byte_raw) +ML_0 (glPopAttrib) +ML_0 (glPopMatrix) +ML_0 (glPopName) + +CAMLprim value ml_glPushAttrib (value list) +{ + GLbitfield mask = 0; + + while (list != Val_int(0)) { + switch (Field(list,0)) { + case MLTAG_accum_buffer:mask |= GL_ACCUM_BUFFER_BIT; break; + case MLTAG_color_buffer:mask |= GL_COLOR_BUFFER_BIT; break; + case MLTAG_current: mask |= GL_CURRENT_BIT; break; + case MLTAG_depth_buffer:mask |= GL_DEPTH_BUFFER_BIT; break; + case MLTAG_enable: mask |= GL_ENABLE_BIT; break; + case MLTAG_eval: mask |= GL_EVAL_BIT; break; + case MLTAG_fog: mask |= GL_FOG_BIT; break; + case MLTAG_hint: mask |= GL_HINT_BIT; break; + case MLTAG_lighting: mask |= GL_LIGHTING_BIT; break; + case MLTAG_line: mask |= GL_LINE_BIT; break; + case MLTAG_list: mask |= GL_LIST_BIT; break; + case MLTAG_pixel_mode: mask |= GL_PIXEL_MODE_BIT; break; + case MLTAG_point: mask |= GL_POINT_BIT; break; + case MLTAG_polygon: mask |= GL_POLYGON_BIT; break; + case MLTAG_polygon_stipple:mask |= GL_POLYGON_STIPPLE_BIT; break; + case MLTAG_scissor: mask |= GL_SCISSOR_BIT; break; + case MLTAG_stencil_buffer:mask |= GL_STENCIL_BUFFER_BIT; break; + case MLTAG_texture: mask |= GL_TEXTURE_BIT; break; + case MLTAG_transform: mask |= GL_TRANSFORM_BIT; break; + case MLTAG_viewport: mask |= GL_VIEWPORT_BIT; break; + } + list = Field(list,1); + } + glPushAttrib (mask); + return Val_unit; +} + +ML_0 (glPushMatrix) +ML_1 (glPushName, Int_val) + +CAMLprim value ml_glRasterPos(value x, value y, value z, value w) /* ML */ +{ + if (z == Val_int(0)) glRasterPos2d (Double_val(x), Double_val(y)); + else if (w == Val_int(0)) + glRasterPos3d (Double_val(x), Double_val(y), Double_val(Field(z, 0))); + else + glRasterPos4d (Double_val(x), Double_val(y), Double_val(Field(z, 0)), + Double_val(Field(w, 0))); + return Val_unit; +} + +CAMLprim value ml_glReadBuffer (value buffer) +{ + if (Is_block(buffer)) { + int n = Int_val (Field(buffer,1)); + if (n >= GL_AUX_BUFFERS) + ml_raise_gl ("GlFunc.read_buffer : no such auxiliary buffer"); + glReadBuffer (GL_AUX0 + n); + } + else glReadBuffer (GLenum_val(buffer)); + return Val_unit; +} + +CAMLprim value ml_glReadPixels(value x, value y, value w, value h, value format , value raw) /* ML */ +{ + glPixelStorei(GL_PACK_SWAP_BYTES, 0); + glPixelStorei(GL_PACK_ALIGNMENT, 1); + glReadPixels(Int_val(x),Int_val(y),Int_val(w),Int_val(h),GLenum_val(format), + Type_void_raw(raw)); + return Val_unit; +} + +ML_bc6 (ml_glReadPixels) +ML_2 (glRectd, Pair(arg1,Double_val,Double_val), + Pair(arg2,Double_val,Double_val)) +ML_1_ (glRenderMode, GLenum_val, Val_int) +ML_4 (glRotated, Double_val, Double_val, Double_val, Double_val) +ML_3 (glScaled, Double_val, Double_val, Double_val) + +ML_4 (glScissor, Int_val, Int_val, Int_val, Int_val) +ML_2 (glSelectBuffer, Int_val, (GLuint*)Addr_raw) +ML_1 (glShadeModel, GLenum_val) +ML_3 (glStencilFunc, GLenum_val, Int_val, Int_val) +ML_1 (glStencilMask, Int_val) +ML_3 (glStencilOp, GLenum_val, GLenum_val, GLenum_val) + +ML_1 (glTexCoord1d, Double_val) +ML_2 (glTexCoord2d, Double_val, Double_val) +ML_3 (glTexCoord3d, Double_val, Double_val, Double_val) +ML_4 (glTexCoord4d, Double_val, Double_val, Double_val, Double_val) + +CAMLprim value ml_glTexEnv (value param) +{ + value params = Field(param,1); + GLfloat color[4]; + int i; + + switch (Field(param,0)) { + case MLTAG_mode: + glTexEnvi (GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GLenum_val(params)); + break; + case MLTAG_color: + for (i = 0; i < 4; i++) color[i] = Float_val(Field(params,i)); + glTexEnvfv (GL_TEXTURE_ENV, GL_TEXTURE_ENV_COLOR, color); + break; + } + return Val_unit; +} + +CAMLprim value ml_glTexGen (value coord, value param) +{ + value params = Field(param,1); + GLdouble point[4]; + int i; + + if (Field(param,0) == MLTAG_mode) + glTexGeni (GLenum_val(coord), GL_TEXTURE_GEN_MODE, GLenum_val(params)); + else { + for (i = 0; i < 4; i++) point[i] = Double_val(Field(params,i)); + glTexGendv (GLenum_val(coord), GLenum_val(Field(param,0)), point); + } + return Val_unit; +} + +CAMLprim value ml_glTexImage1D (value proxy, value level, value internal, + value width, value border, value format, + value data) +{ + glTexImage1D (proxy == Val_int(1) + ? GL_PROXY_TEXTURE_1D : GL_TEXTURE_1D, + Int_val(level), Int_val(internal), Int_val(width), + Int_val(border), GLenum_val(format), + Type_raw(data), Void_raw(data)); + return Val_unit; +} + +ML_bc7 (ml_glTexImage1D) + +CAMLprim value ml_glTexImage2D (value proxy, value level, value internal, + value width, value height, value border, + value format, value data) +{ + /* printf("p=%x,l=%d,i=%d,w=%d,h=%d,b=%d,f=%x,t=%x,d=%x\n", */ + glTexImage2D (proxy == Val_int(1) + ? GL_PROXY_TEXTURE_2D : GL_TEXTURE_2D, + Int_val(level), Int_val(internal), Int_val(width), + Int_val(height), Int_val(border), GLenum_val(format), + Type_raw(data), Void_raw(data)); + /* flush(stdout); */ + return Val_unit; +} + +ML_bc8 (ml_glTexImage2D) + +CAMLprim value ml_glTexParameter (value target, value param) +{ + GLenum targ = GLenum_val(target); + GLenum pname = GLenum_val(Field(param,0)); + value params = Field(param,1); + GLfloat color[4]; + int i; + + switch (pname) { + case GL_TEXTURE_BORDER_COLOR: + for (i = 0; i < 4; i++) color[i] = Float_val(Field(params,i)); + glTexParameterfv (targ, pname, color); + break; + case GL_TEXTURE_PRIORITY: + glTexParameterf (targ, pname, Float_val(params)); + break; + case GL_GENERATE_MIPMAP: +#ifdef GL_VERSION_1_4 + glTexParameteri (targ, pname, Int_val(params)); +#else + ml_raise_gl ("Parameter: GL_GENERATE_MIPMAP not available"); +#endif + break; + default: + glTexParameteri (targ, pname, GLenum_val(params)); + break; + } + return Val_unit; +} + +ML_2 (glGenTextures, Int_val, Int_raw) +ML_2 (glBindTexture, GLenum_val, Nativeint_val) + +CAMLprim value ml_glDeleteTexture (value texture_id) +{ + GLuint id = Nativeint_val(texture_id); + glDeleteTextures(1,&id); + return Val_unit; +} + +ML_3 (glTranslated, Double_val, Double_val, Double_val) + +CAMLprim value ml_glVertex(value x, value y, value z, value w) /* ML */ +{ + if (z == Val_int(0)) glVertex2d (Double_val(x), Double_val(y)); + else if (w == Val_int(0)) + glVertex3d (Double_val(x), Double_val(y), Double_val(Field(z, 0))); + else + glVertex4d (Double_val(x), Double_val(y), Double_val(Field(z, 0)), + Double_val(Field(w, 0))); + return Val_unit; +} + +ML_4 (glViewport, Int_val, Int_val, Int_val, Int_val) + + +/* List functions */ + +ML_1_ (glIsList, Int_val, Val_int) +ML_2 (glDeleteLists, Int_val, Int_val) +ML_1_ (glGenLists, Int_val, Val_int) +ML_2 (glNewList, Int_val, GLenum_val) +ML_0 (glEndList) +ML_1 (glCallList, Int_val) +ML_1 (glListBase, Int_val) + +CAMLprim value ml_glCallLists (value indexes) /* ML */ +{ + int len,i; + int * table; + + switch (Field(indexes,0)) { + case MLTAG_byte: + glCallLists (string_length(Field(indexes,1)), + GL_UNSIGNED_BYTE, + String_val(Field(indexes,1))); + break; + case MLTAG_int: + len = Wosize_val (indexes); + table = calloc (len, sizeof (GLint)); + for (i = 0; i < len; i++) table[i] = Int_val (Field(indexes,i)); + glCallLists (len, GL_INT, table); + free (table); + break; + } + return Val_unit; +} diff --git a/src/ml_gl.h b/src/ml_gl.h new file mode 100644 index 0000000..8053cf4 --- /dev/null +++ b/src/ml_gl.h @@ -0,0 +1,133 @@ +/* $Id: ml_gl.h,v 1.21 2003-10-03 04:27:19 garrigue Exp $ */ + +#ifndef _ml_gl_ +#define _ml_gl_ + +#include "ml_raw.h" + +void ml_raise_gl (const char *errmsg) Noreturn; +#define copy_string_check lablgl_copy_string_check +value copy_string_check (const char *str); + +GLenum GLenum_val (value); + +#define Float_val(dbl) ((GLfloat) Double_val(dbl)) +#define Addr_val(addr) ((GLvoid *) addr) +#define Val_addr(addr) ((value) addr) +#define Type_raw(raw) (GLenum_val(Kind_raw(raw))) +#define Type_void_raw(raw) Type_raw(raw), Void_raw(raw) + +#define ML_0(cname) \ +CAMLprim value ml_##cname (value unit) \ +{ cname (); return Val_unit; } +#define ML_1(cname, conv1) \ +CAMLprim value ml_##cname (value arg1) \ +{ cname (conv1(arg1)); return Val_unit; } +#define ML_2(cname, conv1, conv2) \ +CAMLprim value ml_##cname (value arg1, value arg2) \ +{ cname (conv1(arg1), conv2(arg2)); return Val_unit; } +#define ML_3(cname, conv1, conv2, conv3) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3) \ +{ cname (conv1(arg1), conv2(arg2), conv3(arg3)); return Val_unit; } +#define ML_4(cname, conv1, conv2, conv3, conv4) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4) \ +{ cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4)); \ + return Val_unit; } +#define ML_5(cname, conv1, conv2, conv3, conv4, conv5) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ + value arg5) \ +{ cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), conv5(arg5)); \ + return Val_unit; } +#define ML_6(cname, conv1, conv2, conv3, conv4, conv5, conv6) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ + value arg5, value arg6) \ +{ cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), conv5(arg5), \ + conv6(arg6)); \ + return Val_unit; } +#define ML_7(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ + value arg5, value arg6, value arg7) \ +{ cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), conv5(arg5), \ + conv6(arg6), conv7(arg7)); \ + return Val_unit; } +#define ML_8(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv8) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ + value arg5, value arg6, value arg7, value arg8) \ +{ cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), conv5(arg5), \ + conv6(arg6), conv7(arg7), conv8(arg8)); \ + return Val_unit; } + +#define ML_0_(cname, conv) \ +CAMLprim value ml_##cname (value unit) \ +{ return conv (cname ()); } +#define ML_1_(cname, conv1, conv) \ +CAMLprim value ml_##cname (value arg1) \ +{ return conv (cname (conv1(arg1))); } +#define ML_2_(cname, conv1, conv2, conv) \ +CAMLprim value ml_##cname (value arg1, value arg2) \ +{ return conv (cname (conv1(arg1), conv2(arg2))); } +#define ML_3_(cname, conv1, conv2, conv3, conv) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3) \ +{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3))); } +#define ML_4_(cname, conv1, conv2, conv3, conv4, conv) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4) \ +{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4))); } +#define ML_5_(cname, conv1, conv2, conv3, conv4, conv5, conv) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ + value arg5) \ +{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \ + conv5(arg5))); } +#define ML_6_(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ + value arg5, value arg6) \ +{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \ + conv5(arg5), conv6(arg6))); } +#define ML_7_(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ + value arg5, value arg6, value arg7) \ +{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \ + conv5(arg5), conv6(arg6), conv7(arg7))); } +#define ML_8_(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv8, \ + conv) \ +CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ + value arg5, value arg6, value arg7, value arg8) \ +{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \ + conv5(arg5), conv6(arg6), conv7(arg7), conv8(arg8))); } + +/* Use with care: needs the argument index */ +#define Ignore(x) +#define Split(x,f,g) f(x), g(x) Ignore +#define Split3(x,f,g,h) f(x), g(x), h(x) Ignore +#define Pair(x,f,g) f(Field(x,0)), g(Field(x,1)) Ignore +#define Triple(x,f,g,h) f(Field(x,0)), g(Field(x,1)), h(Field(x,2)) Ignore + +/* For more than 5 arguments */ +#define ML_bc6(cname) \ +CAMLprim value cname##_bc (value *argv, int argn) \ +{ return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5]); } + +#define ML_bc7(cname) \ +CAMLprim value cname##_bc (value *argv, int argn) \ +{ return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6]); } + +#define ML_bc8(cname) \ +CAMLprim value cname##_bc (value *argv, int argn) \ +{ return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6], \ + argv[7]); } + + +/* subtleties of openGL 1.1 vs 1.2 */ +#if !defined(GL_DOUBLE) && defined(GL_DOUBLE_EXT) +#define GL_DOUBLE GL_DOUBLE_EXT +#endif +#if !defined(GL_TEXTURE_PRIORITY) && defined(GL_TEXTURE_PRIORITY_EXT) +#define GL_TEXTURE_PRIORITY GL_TEXTURE_PRIORITY_EXT +#endif +#if !defined(GL_PROXY_TEXTURE_1D) && defined(GL_PROXY_TEXTURE_1D_EXT) +#define GL_PROXY_TEXTURE_1D GL_PROXY_TEXTURE_1D_EXT +#endif +#if !defined(GL_PROXY_TEXTURE_2D) && defined(GL_PROXY_TEXTURE_2D_EXT) +#define GL_PROXY_TEXTURE_2D GL_PROXY_TEXTURE_2D_EXT +#endif + +#endif diff --git a/src/ml_glarray.c b/src/ml_glarray.c new file mode 100644 index 0000000..275a262 --- /dev/null +++ b/src/ml_glarray.c @@ -0,0 +1,113 @@ + +#ifdef _WIN32 +#include +#endif +#include +#include +#include +#include +#include +#include +#ifdef __APPLE__ +#include +#else +#include +#endif +#include "ml_gl.h" +#include "gl_tags.h" +#include "raw_tags.h" +#include "ml_raw.h" + +int ml_glSizeOfValue(value v) { + switch(v) { + case MLTAG_one: return(1); + case MLTAG_two: return(2); + case MLTAG_three: return(3); + case MLTAG_four: return(4); + default: ml_raise_gl("ml_glSizeOfValue: invalid size"); + } +} + + +CAMLprim value ml_glEdgeFlagPointer(value raw) +{ + glEdgeFlagPointer(0, (GLboolean*)Addr_raw(raw)); + return Val_unit; +} + +CAMLprim value ml_glTexCoordPointer(value size, value raw) +{ + glTexCoordPointer (ml_glSizeOfValue(size), + GLenum_val(Kind_raw(raw)), 0, Void_raw(raw)); + return Val_unit; +} + +CAMLprim value ml_glColorPointer(value size, value raw) +{ + glColorPointer (ml_glSizeOfValue(size), + GLenum_val(Kind_raw(raw)), 0, Void_raw(raw)); + return Val_unit; +} + +CAMLprim value ml_glIndexPointer(value raw) +{ + glIndexPointer (GLenum_val(Kind_raw(raw)), 0, Void_raw(raw)); + return Val_unit; +} + +CAMLprim value ml_glNormalPointer(value raw) +{ + glNormalPointer (GLenum_val(Kind_raw(raw)), 0, Void_raw(raw)); + return Val_unit; +} + +CAMLprim value ml_glVertexPointer(value size, value raw) +{ + glVertexPointer (ml_glSizeOfValue(size), + GLenum_val(Kind_raw(raw)), 0, Void_raw(raw)); + return Val_unit; +} + +CAMLprim value ml_glEnableClientState(value kl) +{ + GLenum a; + + switch(kl) { + case MLTAG_edge_flag: a = GL_EDGE_FLAG_ARRAY; break; + case MLTAG_texture_coord: a = GL_TEXTURE_COORD_ARRAY; break; + case MLTAG_color: a = GL_COLOR_ARRAY; break; + case MLTAG_index: a = GL_INDEX_ARRAY; break; + case MLTAG_normal: a = GL_NORMAL_ARRAY; break; + case MLTAG_vertex: a = GL_VERTEX_ARRAY; break; + default: ml_raise_gl("ml_glEnableClientState: invalid array"); + } + glEnableClientState(a); + return Val_unit; +} + +CAMLprim value ml_glDisableClientState(value kl) +{ + GLenum a; + + switch(kl) { + case MLTAG_edge_flag: a = GL_EDGE_FLAG_ARRAY; break; + case MLTAG_texture_coord: a = GL_TEXTURE_COORD_ARRAY; break; + case MLTAG_color: a = GL_COLOR_ARRAY; break; + case MLTAG_index: a = GL_INDEX_ARRAY; break; + case MLTAG_normal: a = GL_NORMAL_ARRAY; break; + case MLTAG_vertex: a = GL_VERTEX_ARRAY; break; + default: ml_raise_gl("ml_glDisableClientState: invalid array"); + } + glDisableClientState(a); + return Val_unit; +} + +ML_1 (glArrayElement, Int_val); +ML_3 (glDrawArrays, GLenum_val, Int_val, Int_val); + +CAMLprim value ml_glDrawElements(value mode, value count, value raw) +{ + glDrawElements (GLenum_val(mode), Int_val(count), + GLenum_val(Kind_raw(raw)), Void_raw(raw)); + return Val_unit; +} diff --git a/src/ml_glu.c b/src/ml_glu.c new file mode 100644 index 0000000..2efcaff --- /dev/null +++ b/src/ml_glu.c @@ -0,0 +1,307 @@ +/* $Id: ml_glu.c,v 1.28 2004-11-02 07:03:34 garrigue Exp $ */ + +#ifdef _WIN32 +#include +#endif +#ifdef __APPLE__ +#include +#include +#else +#include +#include +#endif +#include +#include +#include +#include +#include "gl_tags.h" +#include "glu_tags.h" +#include "ml_gl.h" +#include "ml_glu.h" + +GLenum GLUenum_val(value tag) +{ + switch(tag) + { +#include "glu_tags.c" + } + ml_raise_gl ("Unknown GLU tag"); +} + +/* Does not register the structure with Caml ! +static value Val_addr (void *addr) +{ + value wrapper; + if (!addr) ml_raise_gl ("Bad address"); + wrapper = alloc(1,No_scan_tag); + Field(wrapper,0) = (value) addr; + return wrapper; +} +*/ + +#define Nurb_val(struc) ((GLUnurbsObj *) Field(struc,1)) +#define Quad_val(struc) ((GLUquadricObj *) Field(struc,1)) + +#define Store_addr(struc, addr) Field(struc,1) = (value) addr + + +#define ML_final(cname) \ +static void ml_##cname (value struc) \ +{ cname ((GLvoid *) Field(struc,1)); } + +ML_final (gluDeleteNurbsRenderer) +ML_final (gluDeleteQuadric) + +/* Called from ML */ + +ML_1 (gluBeginCurve, Nurb_val) +ML_1 (gluBeginSurface, Nurb_val) +ML_1 (gluBeginTrim, Nurb_val) + +CAMLprim value ml_gluBuild1DMipmaps (value internal, value width, + value format, value data) +{ + GLenum error; + + error = gluBuild1DMipmaps (GL_TEXTURE_1D, Int_val(internal), + Int_val(width), GLenum_val(format), + Type_raw(data), Void_raw(data)); + if (error) ml_raise_gl((char*)gluErrorString(error)); + return Val_unit; +} + +CAMLprim value ml_gluBuild2DMipmaps (value internal, value width, value height, + value format, value data) +{ + GLint error; + + error = gluBuild2DMipmaps (GL_TEXTURE_2D, Int_val(internal), + Int_val(width), Int_val(height), + GLenum_val(format), + Type_raw(data), Void_raw(data)); + if (error) ml_raise_gl((char*)gluErrorString(error)); + return Val_unit; +} + +ML_6 (gluCylinder, Quad_val, Double_val, Double_val, Double_val, + Int_val, Int_val) +ML_bc6 (ml_gluCylinder) + +ML_5 (gluDisk, Quad_val, Double_val, Double_val, Int_val, Int_val) + +ML_1 (gluEndCurve, Nurb_val) +ML_1 (gluEndSurface, Nurb_val) +ML_1 (gluEndTrim, Nurb_val) + +ML_1_ (gluGetString, GLUenum_val, copy_string_check) + +ML_4 (gluLoadSamplingMatrices, Nurb_val, Float_raw, Float_raw, (GLint*)Int_raw) +ML_3 (gluLookAt, Triple(arg1,Double_val,Double_val,Double_val), + Triple(arg2,Double_val,Double_val,Double_val), + Triple(arg3,Double_val,Double_val,Double_val)) + +CAMLprim value ml_gluNewNurbsRenderer (void) +{ + value struc = alloc_final (2, ml_gluDeleteNurbsRenderer, 1, 32); + Store_addr(struc, gluNewNurbsRenderer()); + return struc; +} + +CAMLprim value ml_gluNewQuadric (void) +{ + value struc = alloc_final (2, ml_gluDeleteQuadric, 1, 32); + Store_addr(struc, gluNewQuadric()); + return struc; +} + +#define Fsize_raw(raw) (Int_val(Size_raw(raw))/sizeof(GLfloat)) + +CAMLprim value ml_gluNurbsCurve (value nurb, value knots, value control, + value order, value type) +{ + GLenum targ = 0U; + int ustride = 0; + + switch (type) { + case MLTAG_vertex_3: + targ = GL_MAP1_VERTEX_3; ustride = 3; break; + case MLTAG_vertex_4: + targ = GL_MAP1_VERTEX_4; ustride = 4; break; + case MLTAG_index: + targ = GL_MAP1_INDEX; ustride = 1; break; + case MLTAG_color_4: + targ = GL_MAP1_COLOR_4; ustride = 4; break; + case MLTAG_normal: + targ = GL_MAP1_NORMAL; ustride = 3; break; + case MLTAG_texture_coord_1: + targ = GL_MAP1_TEXTURE_COORD_1; ustride = 1; break; + case MLTAG_texture_coord_2: + targ = GL_MAP1_TEXTURE_COORD_2; ustride = 2; break; + case MLTAG_texture_coord_3: + targ = GL_MAP1_TEXTURE_COORD_3; ustride = 3; break; + case MLTAG_texture_coord_4: + targ = GL_MAP1_TEXTURE_COORD_4; ustride = 4; break; + case MLTAG_trim_2: + targ = GLU_MAP1_TRIM_2; ustride = 2; break; + case MLTAG_trim_3: + targ = GLU_MAP1_TRIM_3; ustride = 3; break; + } + gluNurbsCurve (Nurb_val(nurb), Fsize_raw(knots), Float_raw(knots), + ustride, Float_raw(control), Int_val(order), targ); + return Val_unit; +} + +CAMLprim value ml_gluNurbsProperty (value nurb, value prop) +{ + GLfloat val; + GLenum property = GLUenum_val (Field(prop,0)); + + switch (property) { + case GLU_SAMPLING_METHOD: + case GLU_DISPLAY_MODE: + val = GLUenum_val (Field(prop,1)); + break; + case GLU_PARAMETRIC_TOLERANCE: + val = Float_val (Field(prop,1)); + break; + default: + val = Int_val (Field(prop,1)); + break; + } + gluNurbsProperty (Nurb_val(nurb), property, val); + return Val_unit; +} + +CAMLprim value ml_gluNurbsSurface (value nurb, value sKnots, value tKnots, + value tStride, value control, value sOrder, + value tOrder, value tag) +{ + GLenum type = 0U; + GLint sStride = 0; + + switch (tag) { + case MLTAG_vertex_3: + type = GL_MAP2_VERTEX_3; sStride = 3; break; + case MLTAG_vertex_4: + type = GL_MAP2_VERTEX_4; sStride = 4; break; + case MLTAG_index: + type = GL_MAP2_INDEX; sStride = 1; break; + case MLTAG_color_4: + type = GL_MAP2_COLOR_4; sStride = 4; break; + case MLTAG_normal: + type = GL_MAP2_NORMAL; sStride = 3; break; + case MLTAG_texture_coord_1: + type = GL_MAP2_TEXTURE_COORD_1; sStride = 1; break; + case MLTAG_texture_coord_2: + type = GL_MAP2_TEXTURE_COORD_2; sStride = 2; break; + case MLTAG_texture_coord_3: + type = GL_MAP2_TEXTURE_COORD_3; sStride = 3; break; + case MLTAG_texture_coord_4: + type = GL_MAP2_TEXTURE_COORD_4; sStride = 4; break; + } + gluNurbsSurface (Nurb_val(nurb), Fsize_raw(sKnots), Float_raw(sKnots), + Fsize_raw(tKnots), Float_raw(tKnots), sStride, + Int_val(tStride), Float_raw(control), + Int_val(sOrder), Int_val(tOrder), type); + return Val_unit; +} + +ML_bc8 (ml_gluNurbsSurface) + +ML_4 (gluOrtho2D, Double_val, Double_val, Double_val, Double_val) + +ML_7 (gluPartialDisk, Quad_val, Double_val, Double_val, Int_val, Int_val, + Double_val, Double_val) +ML_bc7 (ml_gluPartialDisk) +ML_4 (gluPerspective, Double_val, Double_val, Double_val, Double_val) + +CAMLprim value ml_gluPickMatrix (value x, value y, value delX, value delY) +{ + GLint viewport[4]; + + glGetIntegerv (GL_VIEWPORT, viewport); + gluPickMatrix (Double_val(x), Double_val(y), Double_val(delX), + Double_val(delY), viewport); + return Val_unit; +} + +CAMLprim value ml_gluProject (value object) +{ + CAMLparam0(); + GLdouble model[16]; + GLdouble proj[16]; + GLint viewport[4]; + GLdouble winX, winY, winZ; + CAMLlocal3(win0, win1, win2); + value win; + + glGetDoublev (GL_MODELVIEW_MATRIX, model); + glGetDoublev (GL_PROJECTION_MATRIX, proj); + glGetIntegerv (GL_VIEWPORT, viewport); + gluProject (Double_val(Field(object,0)), Double_val(Field(object,1)), + Double_val(Field(object,2)), model, proj, viewport, + &winX, &winY, &winZ); + win0 = copy_double(winX); + win1 = copy_double(winY); + win2 = copy_double(winZ); + win = alloc_small(3, 0); + Field(win,0) = win0; + Field(win,1) = win1; + Field(win,2) = win2; + CAMLreturn(win); +} + +CAMLprim value ml_gluPwlCurve (value nurbs, value count, value data, value tag) +{ + GLenum type = 0U; + GLint stride = 0; + + switch (tag) { + case MLTAG_trim_2: + type = GLU_MAP1_TRIM_2; stride = 2; break; + case MLTAG_trim_3: + type = GLU_MAP1_TRIM_3; stride = 3; break; + } + gluPwlCurve (Nurb_val(nurbs), Int_val(count), Float_raw(data), + stride, type); + return Val_unit; +} + +ML_2 (gluQuadricDrawStyle, Quad_val, GLUenum_val) +ML_2 (gluQuadricNormals, Quad_val, GLUenum_val) +ML_2 (gluQuadricOrientation, Quad_val, GLUenum_val) +ML_2 (gluQuadricTexture, Quad_val, Int_val) + +ML_7 (gluScaleImage, GLenum_val, Int_val, Int_val, + Split(arg4,Type_raw,Void_raw), Int_val, Int_val, + Split(arg7,Type_raw,Void_raw)) +ML_bc7 (ml_gluScaleImage) +ML_4 (gluSphere, Quad_val, Double_val, Int_val, Int_val) + +CAMLprim value ml_gluUnProject (value win) +{ + CAMLparam0(); + GLdouble model[16]; + GLdouble proj[16]; + GLint viewport[4]; + GLdouble objX, objY, objZ; + GLint ok; + CAMLlocal3(obj0,obj1,obj2); + value obj; + + glGetDoublev (GL_MODELVIEW_MATRIX, model); + glGetDoublev (GL_PROJECTION_MATRIX, proj); + glGetIntegerv (GL_VIEWPORT, viewport); + ok = gluUnProject (Double_val(Field(win,0)), Double_val(Field(win,1)), + Double_val(Field(win,2)), model, proj, viewport, + &objX, &objY, &objZ); + if (!ok) ml_raise_gl ("Glu.unproject : point out of window"); + obj0 = copy_double(objX); + obj1 = copy_double(objY); + obj2 = copy_double(objZ); + obj = alloc_small (3, 0); + Field(obj,0) = obj0; + Field(obj,1) = obj1; + Field(obj,2) = obj2; + CAMLreturn(obj); +} diff --git a/src/ml_glu.h b/src/ml_glu.h new file mode 100644 index 0000000..cc5a03d --- /dev/null +++ b/src/ml_glu.h @@ -0,0 +1,17 @@ +#ifndef _ml_glu_ +#define _ml_glu_ + +GLenum GLUenum_val(value tag); + +#if !defined(GLU_VERSION_1_2) && !defined(GLU_TESS_WINDING_RULE) +#define GLU_TESS_WINDING_RULE +#define GLU_TESS_WINDING_ODD +#define GLU_TESS_WINDING_NONZERO +#define GLU_TESS_WINDING_POSITIVE +#define GLU_TESS_WINDING_NEGATIVE +#define GLU_TESS_WINDING_ABS_GEQ_TWO +#define GLU_TESS_BOUNDARY_ONLY +#define GLU_TESS_TOLERANCE +#endif + +#endif diff --git a/src/ml_glutess.c b/src/ml_glutess.c new file mode 100644 index 0000000..ac8ee25 --- /dev/null +++ b/src/ml_glutess.c @@ -0,0 +1,230 @@ +/* $Id: ml_glutess.c,v 1.7 2008-02-25 01:52:20 garrigue Exp $ */ +/* Code contributed by Jon Harrop */ + +#include +#include +#ifdef _WIN32 +#include +#endif +#ifdef __APPLE__ +#include +#include +#else +#include +#include +#endif +#include +#include +#include +#include +#include "gl_tags.h" +#include "glu_tags.h" +#include "ml_gl.h" +#include "ml_glu.h" + +#ifndef GLU_VERSION_1_2 +#define ML_fail(cname) \ +CAMLprim value ml_##cname (value any) \ +{ ml_raise_gl ("Function not available: "#cname); } +ML_fail (gluTesselate) +ML_fail (gluTesselateAndReturn) + +#else + +/* Apparently this is used under Windows, according to the Red Book. */ +#ifndef CALLBACK +#define CALLBACK +#endif +#define AS_CB (GLvoid(CALLBACK *)()) + +static void CALLBACK errorCallback(GLenum error) +{ + ml_raise_gl((char*)gluErrorString(error)); +} + +typedef struct chunklist +{ + struct chunklist *next; + int current; + int size; + GLdouble data[32][3]; +} chunklist; + +static chunklist *rootchunk=NULL; + +static GLdouble *new_vertex(GLdouble x, GLdouble y, GLdouble z) +{ + GLdouble *vert; + if (rootchunk == NULL || rootchunk->current >= rootchunk->size) { + chunklist *tmp = rootchunk; + rootchunk = (chunklist*)malloc(sizeof(chunklist)); + rootchunk->next = tmp; + rootchunk->current = 0; + rootchunk->size = 32; + } + vert = rootchunk->data[rootchunk->current++]; + vert[0] = x; + vert[1] = y; + vert[2] = z; + return vert; +} + +static void free_chunks() +{ + while (rootchunk != NULL) { + chunklist *next = rootchunk->next; + free(rootchunk); + rootchunk = next; + } +} + +static void CALLBACK combineCallback(GLdouble coords[3], + GLdouble *vertex_data[4], + GLfloat weight[4], + GLdouble **data) +{ + *data = new_vertex(coords[0],coords[1],coords[2]); +} + +/* prim is only valid during callbacks */ +static value *prim; +static int kind = 0; + +static void push_vert(value root, double x, double y, double z) +{ + CAMLparam1(root); + CAMLlocal4(vert, xx, yy, zz); + value cons; + xx = copy_double(x); yy = copy_double(y); zz = copy_double(z); + vert = alloc_tuple(3); + Field(vert,0) = xx; + Field(vert,1) = yy; + Field(vert,2) = zz; + cons = alloc_tuple(2); + Field(cons, 0) = vert; + Field(cons, 1) = Field(root,0); + modify(&Field(root,0), cons); + CAMLreturn0; +} + +static void push_list() +{ + value cons = alloc_tuple(2); + Field(cons,0) = Val_unit; + Field(cons,1) = Field(*prim,kind); + modify(&Field(*prim,kind), cons); +} + +static void CALLBACK beginCallback(GLenum type) +{ + switch (type) + { + case GL_TRIANGLES : kind = 0; break; + case GL_TRIANGLE_FAN : kind = 1; break; + case GL_TRIANGLE_STRIP : kind = 2; break; + default: { + char msg[80]; + sprintf(msg, "Unknown primitive format %d in tesselation.\n", (int)type); + ml_raise_gl(msg); + } + } + push_list(); +} + +static void CALLBACK vertexCallback(void *vertex_data) +{ + GLdouble *verts=(GLdouble *)vertex_data; + push_vert(Field(*prim,kind), verts[0], verts[1], verts[2]); +} + +static void CALLBACK endCallback() +{ + kind = 0; +} + +static GLUtesselator *tobj=NULL; + + +static void iniTesselator(value winding, value by_only, value tolerance) +{ + if (!tobj) { + tobj=gluNewTess(); + if (!tobj) ml_raise_gl("Failed to initialise the GLU tesselator."); + } + gluTessNormal(tobj, 0.0, 0.0, 1.0); + gluTessProperty(tobj, GLU_TESS_WINDING_RULE, + (winding != Val_unit ? GLUenum_val(Field(winding,0)) + : GLU_TESS_WINDING_ODD)); + gluTessProperty(tobj, GLU_TESS_BOUNDARY_ONLY, + (by_only != Val_unit && Field(by_only,0) != Val_unit)); + gluTessProperty(tobj, GLU_TESS_TOLERANCE, + (tolerance != Val_unit ? Float_val(Field(by_only,0)) : 0)); +} + +static void runTesselator(value contours) +{ + CAMLparam1(contours); + + gluTessBeginPolygon(tobj, NULL); + while (contours != Val_int(0)) { + value contour=Field(contours, 0); + gluTessBeginContour(tobj); + while (contour != Val_int(0)) { + value v=Field(contour, 0); + GLdouble *r = + new_vertex(Double_val(Field(v, 0)), + Double_val(Field(v, 1)), + Double_val(Field(v, 2))); + gluTessVertex(tobj, r, (void *)r); + contour = Field(contour, 1); + } + contours = Field(contours, 1); + gluTessEndContour(tobj); + } + gluTessEndPolygon(tobj); + + gluDeleteTess(tobj); + tobj = NULL; + free_chunks(); + CAMLreturn0; +} + +CAMLprim value ml_gluTesselateAndReturn(value winding, value tolerance, + value contours) +{ + CAMLparam1(contours); + CAMLlocal1(res); + + res = alloc_tuple(3); + Field(res,0) = Field(res,1) = Field(res,2) = Val_unit; + prim = &res; + + iniTesselator(winding, Val_unit, tolerance); + gluTessCallback(tobj, GLU_TESS_BEGIN, AS_CB beginCallback); + gluTessCallback(tobj, GLU_TESS_VERTEX, AS_CB vertexCallback); + gluTessCallback(tobj, GLU_TESS_END, AS_CB endCallback); + gluTessCallback(tobj, GLU_TESS_ERROR, AS_CB errorCallback); + gluTessCallback(tobj, GLU_TESS_COMBINE, AS_CB combineCallback); + + runTesselator(contours); + + CAMLreturn (res); +} + +CAMLprim value ml_gluTesselate (value winding, value by_only, + value tolerance, value contours) +{ + iniTesselator(winding, by_only, tolerance); + + gluTessCallback(tobj, GLU_TESS_BEGIN, AS_CB glBegin); + gluTessCallback(tobj, GLU_TESS_VERTEX, AS_CB glVertex3dv); + gluTessCallback(tobj, GLU_TESS_END, AS_CB glEnd); + gluTessCallback(tobj, GLU_TESS_ERROR, AS_CB errorCallback); + gluTessCallback(tobj, GLU_TESS_COMBINE, AS_CB combineCallback); + + runTesselator(contours); + + return Val_unit; +} + +#endif diff --git a/src/ml_raw.c b/src/ml_raw.c new file mode 100644 index 0000000..35d163b --- /dev/null +++ b/src/ml_raw.c @@ -0,0 +1,507 @@ +/* $Id: ml_raw.c,v 1.16 2007-04-13 02:48:43 garrigue Exp $ */ + +#include +#include +#include +#include +#include +#include +#include "raw_tags.h" +#include "ml_raw.h" + +#define SIZE_BYTE sizeof(char) +#define SIZE_SHORT sizeof(short) +#define SIZE_INT sizeof(int) +#define SIZE_LONG sizeof(long) +#define SIZE_FLOAT sizeof(float) +#define SIZE_DOUBLE sizeof(double) + +extern void invalid_argument (char *) Noreturn; +extern void raise_out_of_memory (void) Noreturn; + +static int raw_sizeof (value kind) +{ + switch (kind) { + case MLTAG_bitmap: + case MLTAG_byte: + case MLTAG_ubyte: + return SIZE_BYTE; + case MLTAG_short: + case MLTAG_ushort: + return SIZE_SHORT; + case MLTAG_int: + case MLTAG_uint: + return SIZE_INT; + case MLTAG_long: + case MLTAG_ulong: + return SIZE_LONG; + case MLTAG_float: + return SIZE_FLOAT; + case MLTAG_double: + return SIZE_DOUBLE; + } + return 0; +} + +CAMLprim value ml_raw_sizeof (value kind) /* ML */ +{ + return Val_int(raw_sizeof(kind)); +} + +static void check_size (value raw, long pos, char *msg) +{ + if (pos < 0 || + (pos+1) * raw_sizeof(Kind_raw(raw)) > Int_val(Size_raw(raw))) + invalid_argument (msg); +} + +CAMLprim value ml_raw_get (value raw, value pos) /* ML */ +{ + long i = Long_val(pos); + + check_size (raw,i,"Raw.get"); + switch (Kind_raw(raw)) { + case MLTAG_bitmap: + case MLTAG_ubyte: + return Val_long ((unsigned char) Byte_raw(raw)[i]); + case MLTAG_byte: + return Val_long (Byte_raw(raw)[i]); + case MLTAG_short: + return Val_long (Short_raw(raw)[i]); + case MLTAG_ushort: + return Val_long ((unsigned short) Short_raw(raw)[i]); + case MLTAG_int: + return Val_long (Int_raw(raw)[i]); + case MLTAG_uint: + return Val_long ((unsigned int) Int_raw(raw)[i]); + case MLTAG_long: + return Val_long (Long_raw(raw)[i]); + case MLTAG_ulong: + return Val_long ((unsigned long) Long_raw(raw)[i]); + } + return Val_unit; +} + +CAMLprim value ml_raw_read (value raw, value pos, value len) /* ML */ +{ + int s = Int_val(pos); + int i, l = Int_val(len); + value ret; + + check_size (raw,s+l-1,"Raw.read"); + if (l<0 || s<0) invalid_argument("Raw.read"); + ret = alloc_shr (l, 0); + switch (Kind_raw(raw)) { + case MLTAG_bitmap: + case MLTAG_ubyte: + { + unsigned char *byte_raw = (unsigned char *)Byte_raw(raw)+s; + for (i = 0; i < l; i++) + Field(ret,i) = Val_long (*byte_raw++); + break; + } + case MLTAG_byte: + { + char *byte_raw = Byte_raw(raw)+s; + for (i = 0; i < l; i++) + Field(ret,i) = Val_long (*byte_raw++); + break; + } + case MLTAG_short: + { + short *short_raw = Short_raw(raw)+s; + for (i = 0; i < l; i++) + Field(ret,i) = Val_long (*short_raw++); + break; + } + case MLTAG_ushort: + { + unsigned short *short_raw = (unsigned short *)Short_raw(raw)+s; + for (i = 0; i < l; i++) + Field(ret,i) = Val_long (*short_raw++); + break; + } + case MLTAG_int: + { + int *int_raw = Int_raw(raw)+s; + for (i = 0; i < l; i++) + Field(ret,i) = Val_long (*int_raw++); + break; + } + case MLTAG_uint: + { + unsigned int *int_raw = (unsigned int *)Int_raw(raw)+s; + for (i = 0; i < l; i++) + Field(ret,i) = Val_long (*int_raw++); + break; + } + case MLTAG_long: + { + long *long_raw = Long_raw(raw)+s; + for (i = 0; i < l; i++) + Field(ret,i) = Val_long (*long_raw++); + break; + } + case MLTAG_ulong: + { + unsigned long *long_raw = (unsigned long *)Long_raw(raw)+s; + for (i = 0; i < l; i++) + Field(ret,i) = Val_long (*long_raw++); + break; + } + } + return ret; +} + +CAMLprim value ml_raw_read_string (value raw, value pos, value len) /* ML */ +{ + CAMLparam1(raw); + int s = Int_val(pos); + int l = Int_val(len); + value ret; + + if (l<0 || s<0 || s+l > Int_val(Size_raw(raw))) + invalid_argument("Raw.read_string"); + ret = alloc_string (l); + memcpy (String_val(ret), Bp_val(Addr_raw(raw))+s, l); + CAMLreturn(ret); +} + +CAMLprim value ml_raw_write_string (value raw, value pos, value data) /* ML */ +{ + int s = Int_val(pos); + int l = string_length(data); + + if (s<0 || s+l > Int_val(Size_raw(raw))) + invalid_argument("Raw.write_string"); + memcpy (Bp_val(Addr_raw(raw))+s, String_val(data), l); + return Val_unit; +} + +CAMLprim value ml_raw_set (value raw, value pos, value data) /* ML */ +{ + long i = Long_val(pos); + + check_size (raw,i,"Raw.set"); + switch (Kind_raw(raw)) { + case MLTAG_bitmap: + case MLTAG_ubyte: + case MLTAG_byte: + Byte_raw(raw)[i] = Long_val(data); + break; + case MLTAG_short: + case MLTAG_ushort: + Short_raw(raw)[i] = Long_val(data); + break; + case MLTAG_int: + Int_raw(raw)[i] = Long_val(data); + break; + case MLTAG_uint: + Int_raw(raw)[i] = Long_val((unsigned long) data); + break; + case MLTAG_long: + Long_raw(raw)[i] = Long_val(data); + break; + case MLTAG_ulong: + Long_raw(raw)[i] = Long_val((unsigned long) data); + break; + } + return Val_unit; +} + +CAMLprim value ml_raw_write (value raw, value pos, value data) /* ML */ +{ + int s = Int_val(pos); + int i, l = Wosize_val(data); + + check_size (raw,s+l-1,"Raw.write"); + if (s<0) invalid_argument("Raw.write"); + + switch (Kind_raw(raw)) { + case MLTAG_bitmap: + case MLTAG_ubyte: + case MLTAG_byte: + { + char *byte_raw = Byte_raw(raw)+s; + for (i = 0; i < l; i++) + *byte_raw++ = Long_val(Field(data,i)); + break; + } + case MLTAG_short: + case MLTAG_ushort: + { + short *short_raw = Short_raw(raw)+s; + for (i = 0; i < l; i++) + *short_raw++ = Long_val(Field(data,i)); + break; + } + case MLTAG_int: + { + int *int_raw = Int_raw(raw)+s; + for (i = 0; i < l; i++) + *int_raw++ = Long_val(Field(data,i)); + break; + } + case MLTAG_uint: + { + int *int_raw = Int_raw(raw)+s; + for (i = 0; i < l; i++) + *int_raw++ = Long_val((unsigned long) Field(data,i)); + break; + } + case MLTAG_long: + { + long *long_raw = Long_raw(raw)+s; + for (i = 0; i < l; i++) + *long_raw++ = Long_val(Field(data,i)); + break; + } + case MLTAG_ulong: + { + long *long_raw = Long_raw(raw)+s; + for (i = 0; i < l; i++) + *long_raw++ = Long_val((unsigned long) Field(data,i)); + break; + } + } + return Val_unit; +} + +CAMLprim value ml_raw_get_float (value raw, value pos) /* ML */ +{ + long i = Long_val(pos); + + check_size (raw,i,"Raw.get_float"); + if (Kind_raw(raw) == MLTAG_float) + return copy_double ((double) Float_raw(raw)[i]); + else + return copy_double (Double_raw(raw)[i]); +} + +CAMLprim value ml_raw_read_float (value raw, value pos, value len) /* ML */ +{ + int s = Int_val(pos); + int i, l = Int_val(len); + value ret = Val_unit; + + check_size (raw,s+l-1,"Raw.read_float"); + if (l<0 || s<0) invalid_argument("Raw.read_float"); + ret = alloc_shr (l*sizeof(double)/sizeof(value), Double_array_tag); + if (Kind_raw(raw) == MLTAG_float) { + float *float_raw = Float_raw(raw)+s; + for (i = 0; i < l; i++) + Store_double_field(ret, i, (double) *float_raw++); + } else { + double *double_raw = Double_raw(raw)+s; + for (i = 0; i < l; i++) + Store_double_field(ret, i, *double_raw++); + } + return ret; +} + +CAMLprim value ml_raw_set_float (value raw, value pos, value data) /* ML */ +{ + long i = Long_val(pos); + + check_size (raw,i,"Raw.set_float"); + if (Kind_raw(raw) == MLTAG_float) + Float_raw(raw)[i] = (float) Double_val(data); + else + Double_raw(raw)[i] = Double_val(data); + return Val_unit; +} + +CAMLprim value ml_raw_write_float (value raw, value pos, value data) /* ML */ +{ + int s = Int_val(pos); + int i, l = Wosize_val(data)*sizeof(value)/sizeof(double); + + check_size (raw,s+l-1,"Raw.write_float"); + if (s<0) invalid_argument("Raw.write_float"); + if (Kind_raw(raw) == MLTAG_float) { + float *float_raw = Float_raw(raw)+s; + for (i = 0; i < l; i++) + *float_raw++ = (float) Double_field(data,i); + } else { + double *double_raw = Double_raw(raw)+s; + for (i = 0; i < l; i++) + *double_raw++ = Double_field(data,i); + } + return Val_unit; +} + +#ifdef ARCH_BIG_ENDIAN +#define HI_OFFSET 1 +#define LO_OFFSET 0 +#else +#define HI_OFFSET 0 +#define LO_OFFSET 1 +#endif + +/* Here we suppose that: + * sizeof(int) == 2*sizeof(short) + * sizeof(long) == 2*sizeof(int) (64-bit architectures) + * sizeof(long) == 2*sizeof(short) (otherwise) + */ + +#define Hint_raw(raw) ((unsigned short *) Short_raw(raw)) + +#ifdef ARCH_SIXTYFOUR +#define Hlong_raw(raw) ((unsigned int *) Int_raw(raw)) +#else +#define Hlong_raw(raw) ((unsigned short *) Short_raw(raw)) +#endif + +CAMLprim value ml_raw_get_hi (value raw, value pos) /* ML */ +{ + long i = Long_val(pos); + + check_size (raw,i,"Raw.get_hi"); + switch (Kind_raw(raw)) { + case MLTAG_int: + case MLTAG_uint: + return Val_long (Hint_raw(raw)[2*i+HI_OFFSET]); + case MLTAG_long: + case MLTAG_ulong: + return Val_long (Hlong_raw(raw)[2*i+HI_OFFSET]); + } + return Val_unit; +} + +CAMLprim value ml_raw_get_lo (value raw, value pos) /* ML */ +{ + long i = Long_val(pos); + + check_size (raw,i,"Raw.get_lo"); + switch (Kind_raw(raw)) { + case MLTAG_int: + case MLTAG_uint: + return Val_long ((unsigned long) Hint_raw(raw)[2*i+LO_OFFSET]); + case MLTAG_long: + case MLTAG_ulong: + return Val_long ((unsigned long) Hlong_raw(raw)[2*i+LO_OFFSET]); + } + return Val_unit; +} + +CAMLprim value ml_raw_set_hi (value raw, value pos, value data) /* ML */ +{ + long i = Long_val(pos); + + check_size (raw,i,"Raw.set_hi"); + switch (Kind_raw(raw)) { + case MLTAG_int: + case MLTAG_uint: + Hint_raw(raw)[2*i+HI_OFFSET] = Long_val(data); + break; + case MLTAG_long: + case MLTAG_ulong: + Hlong_raw(raw)[2*i+HI_OFFSET] = Long_val(data); + break; + } + return Val_unit; +} + +CAMLprim value ml_raw_set_lo (value raw, value pos, value data) /* ML */ +{ + long i = Long_val(pos); + + check_size (raw,i,"Raw.set_lo"); + switch (Kind_raw(raw)) { + case MLTAG_int: + case MLTAG_uint: + Hint_raw(raw)[2*i+LO_OFFSET] = Long_val(data); + break; + case MLTAG_long: + case MLTAG_ulong: + Hlong_raw(raw)[2*i+LO_OFFSET] = Long_val(data); + break; + } + return Val_unit; +} + +CAMLprim value ml_raw_get_long (value raw, value pos) /* ML */ +{ + long i = Long_val(pos); + + check_size (raw,i,"Raw.get_long"); + switch (Kind_raw(raw)) { + case MLTAG_int: + case MLTAG_uint: + return copy_nativeint (Int_raw(raw)[i]); + case MLTAG_long: + case MLTAG_ulong: + return copy_nativeint (Long_raw(raw)[i]); + } + return Val_unit; +} + +CAMLprim value ml_raw_set_long (value raw, value pos, value data) /* ML */ +{ + long i = Long_val(pos); + + check_size (raw,i,"Raw.set_long"); + switch (Kind_raw(raw)) { + case MLTAG_int: + case MLTAG_uint: + Int_raw(raw)[i] = Nativeint_val(data); + break; + case MLTAG_long: + case MLTAG_ulong: + Long_raw(raw)[i] = Nativeint_val(data); + break; + } + return Val_unit; +} + +CAMLprim value ml_raw_alloc (value kind, value len) /* ML */ +{ + CAMLparam0(); + CAMLlocal1(data); + value raw; + int size = raw_sizeof(kind) * Int_val(len); + int offset = 0; + + if (kind == MLTAG_double && sizeof(double) > sizeof(value)) { + data = alloc_shr ((size-1)/sizeof(value)+2, Abstract_tag); + offset = (data % sizeof(double) ? sizeof(value) : 0); + } else data = alloc_shr ((size-1)/sizeof(value)+1, Abstract_tag); + raw = alloc_small (SIZE_RAW,0); + Kind_raw(raw) = kind; + Size_raw(raw) = Val_int(size); + Base_raw(raw) = data; + Offset_raw(raw) = Val_int(offset); + Static_raw(raw) = Val_false; + CAMLreturn(raw); +} + +CAMLprim value ml_raw_alloc_static (value kind, value len) /* ML */ +{ + value raw; + void *data; + int size = raw_sizeof(kind) * Int_val(len); + int offset = 0; + + if (kind == MLTAG_double && sizeof(double) > sizeof(long)) { + data = stat_alloc (size+sizeof(long)); + offset = ((long)data % sizeof(double) ? sizeof(value) : 0); + } else data = stat_alloc (size); + raw = alloc_small (SIZE_RAW, 0); + Kind_raw(raw) = kind; + Size_raw(raw) = Val_int(size); + Base_raw(raw) = (value) data; + Offset_raw(raw) = Val_int(offset); + Static_raw(raw) = Val_true; + return raw; +} + +CAMLprim value ml_raw_free_static (value raw) /* ML */ +{ + if (Static_raw(raw) != Val_int(1)) invalid_argument ("Raw.free_static"); + stat_free (Void_raw(raw)); + Base_raw(raw) = Val_unit; + Size_raw(raw) = Val_unit; + Offset_raw(raw) = Val_unit; + Static_raw(raw) = Val_false; + return Val_unit; +} diff --git a/src/ml_raw.h b/src/ml_raw.h new file mode 100644 index 0000000..da94c93 --- /dev/null +++ b/src/ml_raw.h @@ -0,0 +1,23 @@ +/* $Id: ml_raw.h,v 1.3 1999-04-14 14:05:52 garrigue Exp $ */ + +#ifndef _ml_raw_ +#define _ml_raw_ + +#define SIZE_RAW 5 +#define Kind_raw(raw) (Field(raw,0)) +#define Base_raw(raw) (Field(raw,1)) +#define Offset_raw(raw) (Field(raw,2)) +#define Size_raw(raw) (Field(raw,3)) +#define Static_raw(raw) (Field(raw,4)) + +#define Addr_raw(raw) (Base_raw(raw)+Long_val(Offset_raw(raw))) + +#define Void_raw(raw) ((void *) Addr_raw(raw)) +#define Byte_raw(raw) ((char *) Addr_raw(raw)) +#define Short_raw(raw) ((short *) Addr_raw(raw)) +#define Int_raw(raw) ((int *) Addr_raw(raw)) +#define Long_raw(raw) ((long *) Addr_raw(raw)) +#define Float_raw(raw) ((float *) Addr_raw(raw)) +#define Double_raw(raw) ((double *) Addr_raw(raw)) + +#endif diff --git a/src/ml_shader.c b/src/ml_shader.c new file mode 100644 index 0000000..1fe374f --- /dev/null +++ b/src/ml_shader.c @@ -0,0 +1,1251 @@ +/* $Id: ml_shader.c,v 1.1 2010-03-11 08:30:02 garrigue Exp $ */ +/* Code contributed by Florent Monnier */ + +#define GL_GLEXT_PROTOTYPES + +#ifdef _WIN32 +#include +#endif +#include +#ifdef __APPLE__ +#include +#include +#else +#include +#include +#endif + +#include +#include +#include +#include +#include +#include + +#include "gl_tags.h" +#include "ml_gl.h" + + +#ifdef _WIN32 +#include + +// if the PFNGL*PROC types are not defined in gl.h or glext.h add these lines: + +#if 0 +typedef GLuint (APIENTRYP PFNGLCREATESHADERPROC) (GLenum type); +typedef void (APIENTRYP PFNGLDELETESHADERPROC) (GLuint shader); +typedef GLboolean (APIENTRYP PFNGLISSHADERPROC) (GLuint shader); +typedef void (APIENTRYP PFNGLSHADERSOURCEPROC) (GLuint shader, GLsizei count, const GLchar* *string, const GLint *length); +typedef void (APIENTRYP PFNGLCOMPILESHADERPROC) (GLuint shader); +typedef void (APIENTRYP PFNGLGETSHADERIVPROC) (GLuint shader, GLenum pname, GLint *params); + +typedef GLuint (APIENTRYP PFNGLCREATEPROGRAMPROC) (void); +typedef void (APIENTRYP PFNGLDELETEPROGRAMPROC) (GLuint program); +typedef GLboolean (APIENTRYP PFNGLISPROGRAMPROC) (GLuint program); +typedef void (APIENTRYP PFNGLUSEPROGRAMPROC) (GLuint program); +typedef void (APIENTRYP PFNGLATTACHSHADERPROC) (GLuint program, GLuint shader); +typedef void (APIENTRYP PFNGLDETACHSHADERPROC) (GLuint program, GLuint shader); +typedef void (APIENTRYP PFNGLLINKPROGRAMPROC) (GLuint program); +typedef void (APIENTRYP PFNGLGETPROGRAMIVPROC) (GLuint program, GLenum pname, GLint *params); + +typedef void (APIENTRYP PFNGLGETPROGRAMINFOLOGPROC) (GLuint program, GLsizei bufSize, GLsizei *length, GLchar *infoLog); +typedef void (APIENTRYP PFNGLGETSHADERINFOLOGPROC) (GLuint shader, GLsizei bufSize, GLsizei *length, GLchar *infoLog); +typedef GLint (APIENTRYP PFNGLGETUNIFORMLOCATIONPROC) (GLuint program, const GLchar *name); + +typedef void (APIENTRYP PFNGLUNIFORM1IPROC) (GLint location, GLint v0); +typedef void (APIENTRYP PFNGLUNIFORM2IPROC) (GLint location, GLint v0, GLint v1); +typedef void (APIENTRYP PFNGLUNIFORM3IPROC) (GLint location, GLint v0, GLint v1, GLint v2); +typedef void (APIENTRYP PFNGLUNIFORM4IPROC) (GLint location, GLint v0, GLint v1, GLint v2, GLint v3); +typedef void (APIENTRYP PFNGLUNIFORM1IVPROC) (GLint location, GLsizei count, const GLint *value); +typedef void (APIENTRYP PFNGLUNIFORM2IVPROC) (GLint location, GLsizei count, const GLint *value); +typedef void (APIENTRYP PFNGLUNIFORM3IVPROC) (GLint location, GLsizei count, const GLint *value); +typedef void (APIENTRYP PFNGLUNIFORM4IVPROC) (GLint location, GLsizei count, const GLint *value); +typedef void (APIENTRYP PFNGLUNIFORM1FPROC) (GLint location, GLfloat v0); +typedef void (APIENTRYP PFNGLUNIFORM2FPROC) (GLint location, GLfloat v0, GLfloat v1); +typedef void (APIENTRYP PFNGLUNIFORM3FPROC) (GLint location, GLfloat v0, GLfloat v1, GLfloat v2); +typedef void (APIENTRYP PFNGLUNIFORM4FPROC) (GLint location, GLfloat v0, GLfloat v1, GLfloat v2, GLfloat v3); +typedef void (APIENTRYP PFNGLUNIFORM1FVPROC) (GLint location, GLsizei count, const GLfloat *value); +typedef void (APIENTRYP PFNGLUNIFORM2FVPROC) (GLint location, GLsizei count, const GLfloat *value); +typedef void (APIENTRYP PFNGLUNIFORM3FVPROC) (GLint location, GLsizei count, const GLfloat *value); +typedef void (APIENTRYP PFNGLUNIFORM4FVPROC) (GLint location, GLsizei count, const GLfloat *value); + +typedef void (APIENTRYP PFNGLUNIFORMMATRIX2FVPROC) (GLint location, GLsizei count, GLboolean transpose, const GLfloat *value); +typedef void (APIENTRYP PFNGLUNIFORMMATRIX3FVPROC) (GLint location, GLsizei count, GLboolean transpose, const GLfloat *value); +typedef void (APIENTRYP PFNGLUNIFORMMATRIX4FVPROC) (GLint location, GLsizei count, GLboolean transpose, const GLfloat *value); + +typedef void (APIENTRYP PFNGLUNIFORMMATRIX2X3FVPROC) (GLint location, GLsizei count, GLboolean transpose, const GLfloat *value); +typedef void (APIENTRYP PFNGLUNIFORMMATRIX3X2FVPROC) (GLint location, GLsizei count, GLboolean transpose, const GLfloat *value); +typedef void (APIENTRYP PFNGLUNIFORMMATRIX2X4FVPROC) (GLint location, GLsizei count, GLboolean transpose, const GLfloat *value); +typedef void (APIENTRYP PFNGLUNIFORMMATRIX4X2FVPROC) (GLint location, GLsizei count, GLboolean transpose, const GLfloat *value); +typedef void (APIENTRYP PFNGLUNIFORMMATRIX3X4FVPROC) (GLint location, GLsizei count, GLboolean transpose, const GLfloat *value); +typedef void (APIENTRYP PFNGLUNIFORMMATRIX4X3FVPROC) (GLint location, GLsizei count, GLboolean transpose, const GLfloat *value); + +typedef GLint (APIENTRYP PFNGLGETATTRIBLOCATIONPROC) (GLuint program, const GLchar *name); + +typedef void (APIENTRYP PFNGLVERTEXATTRIB1SPROC) (GLuint index, GLshort x); +typedef void (APIENTRYP PFNGLVERTEXATTRIB1DPROC) (GLuint index, GLdouble x); +typedef void (APIENTRYP PFNGLVERTEXATTRIB2SPROC) (GLuint index, GLshort x, GLshort y); +typedef void (APIENTRYP PFNGLVERTEXATTRIB2DPROC) (GLuint index, GLdouble x, GLdouble y); +typedef void (APIENTRYP PFNGLVERTEXATTRIB3SPROC) (GLuint index, GLshort x, GLshort y, GLshort z); +typedef void (APIENTRYP PFNGLVERTEXATTRIB3DPROC) (GLuint index, GLdouble x, GLdouble y, GLdouble z); +typedef void (APIENTRYP PFNGLVERTEXATTRIB4SPROC) (GLuint index, GLshort x, GLshort y, GLshort z, GLshort w); +typedef void (APIENTRYP PFNGLVERTEXATTRIB4DPROC) (GLuint index, GLdouble x, GLdouble y, GLdouble z, GLdouble w); + +typedef void (APIENTRYP PFNGLBINDATTRIBLOCATIONPROC) (GLuint program, GLuint index, const GLchar *name); +#endif + + +#define LOAD_FUNC(func, f_type) \ + static f_type func = NULL; \ + static unsigned int func##_is_loaded = 0; \ + if (!func##_is_loaded) { \ + func = (f_type) wglGetProcAddress(#func); \ + if (func == NULL) caml_failwith("Unable to load " #func); \ + else func##_is_loaded = 1; \ + } + +#else +#define LOAD_FUNC(func, f_type) +#endif +/* end of ifdef _WIN32 */ + + + +/* GLSL Shaders */ + +#ifdef GL_VERSION_2_0 + +/* wrap as abstract */ +//define Val_shader_object(v) ((value)(v)) +//define Shader_object_val(v) ((GLuint)(v)) + +//define Val_shader_program(v) ((value)(v)) +//define Shader_program_val(v) ((GLuint)(v)) + +/* wrap as ints */ +#define Val_shader_object Val_long +#define Shader_object_val Long_val + +#define Val_shader_program Val_long +#define Shader_program_val Long_val + + +CAMLprim value ml_glcreateshader( value shaderType ) +{ + GLuint s = 0; + LOAD_FUNC(glCreateShader, PFNGLCREATESHADERPROC) + switch (shaderType) { + case MLTAG_vertex_shader: s = glCreateShader(GL_VERTEX_SHADER); break; + case MLTAG_fragment_shader: s = glCreateShader(GL_FRAGMENT_SHADER); break; + default: caml_failwith("glShader.create"); + } + if (s == 0) caml_failwith("glShader.create"); + return Val_shader_object(s); +} + +CAMLprim value ml_gldeleteshader( value shader ) +{ + LOAD_FUNC(glDeleteShader, PFNGLDELETESHADERPROC) + glDeleteShader( Shader_object_val(shader) ); + return Val_unit; +} + +CAMLprim value ml_glisshader( value shader ) +{ + LOAD_FUNC(glIsShader, PFNGLISSHADERPROC) + return (glIsShader( Shader_object_val(shader) ) == GL_TRUE ? Val_true : Val_false); +} + +CAMLprim value ml_glshadersource( value shader, value str ) +{ + const char * vp = String_val(str); + LOAD_FUNC(glShaderSource, PFNGLSHADERSOURCEPROC) + glShaderSource(Shader_object_val(shader), 1, &vp, NULL); + return Val_unit; +} + +CAMLprim value ml_glcompileshader( value shader ) +{ + LOAD_FUNC(glCompileShader, PFNGLCOMPILESHADERPROC) + glCompileShader( Shader_object_val(shader) ); + return Val_unit; +} + +CAMLprim value ml_glcreateprogram( value unit ) +{ + LOAD_FUNC(glCreateProgram, PFNGLCREATEPROGRAMPROC) + GLuint p = glCreateProgram(); + if (p == 0) caml_failwith("glShader.create_program"); + return Val_shader_program(p); +} + +CAMLprim value ml_gldeleteprogram( value program ) +{ + LOAD_FUNC(glDeleteProgram, PFNGLDELETEPROGRAMPROC) + glDeleteProgram( Shader_program_val(program) ); + return Val_unit; +} + +CAMLprim value ml_glattachshader( value program, value shader ) +{ + LOAD_FUNC(glAttachShader, PFNGLATTACHSHADERPROC) + glAttachShader( Shader_program_val(program), Shader_object_val(shader) ); + return Val_unit; +} + +CAMLprim value ml_gldetachshader( value program, value shader ) +{ + LOAD_FUNC(glDetachShader, PFNGLDETACHSHADERPROC) + glDetachShader( Shader_program_val(program), Shader_object_val(shader) ); + return Val_unit; +} + +CAMLprim value ml_gllinkprogram( value program ) +{ + LOAD_FUNC(glLinkProgram, PFNGLLINKPROGRAMPROC) + glLinkProgram( Shader_program_val(program) ); + return Val_unit; +} + +CAMLprim value ml_gluseprogram( value program ) +{ + LOAD_FUNC(glUseProgram, PFNGLUSEPROGRAMPROC) + glUseProgram( Shader_program_val(program) ); + return Val_unit; +} +CAMLprim value ml_glunuseprogram( value unit ) +{ + /* desactivate */ + LOAD_FUNC(glUseProgram, PFNGLUSEPROGRAMPROC) + glUseProgram(0); + return Val_unit; +} + +CAMLprim value ml_glgetshadercompilestatus( value shader ) +{ + GLint error; + LOAD_FUNC(glGetShaderiv, PFNGLGETSHADERIVPROC) + glGetShaderiv( Shader_object_val(shader), GL_COMPILE_STATUS, &error); + if (error == GL_TRUE) return Val_true; + else return Val_false; +} + +CAMLprim value ml_glgetshadercompilestatus_exn( value shader ) +{ + GLint error; + LOAD_FUNC(glGetShaderiv, PFNGLGETSHADERIVPROC) + glGetShaderiv( Shader_object_val(shader), GL_COMPILE_STATUS, &error); + if (error != GL_TRUE) + caml_failwith("Shader compile status: error"); + return Val_unit; +} + +CAMLprim value ml_glgetuniformlocation( value program, value name ) +{ + LOAD_FUNC(glGetUniformLocation, PFNGLGETUNIFORMLOCATIONPROC) + return Val_int( glGetUniformLocation( Shader_program_val(program), String_val(name) )); +} + +#else +CAMLprim value ml_glcreateshader( value shaderType ) +{ + caml_failwith("glCreateShader function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_gldeleteshader( value shader ) +{ + caml_failwith("glDeleteShader function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_glisshader( value shader ) +{ + caml_failwith("glIsShader function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_glshadersource( value shader, value str ) +{ + caml_failwith("glShaderSource function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_glcompileshader( value shader ) +{ + caml_failwith("glCompileShader function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_glcreateprogram( value unit ) +{ + caml_failwith("glCreateProgram function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_gldeleteprogram( value program ) +{ + caml_failwith("glDeleteProgram function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_glattachshader( value program, value shader ) +{ + caml_failwith("glAttachShader function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_gldetachshader( value program, value shader ) +{ + caml_failwith("glDetachShader function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_gllinkprogram( value program ) +{ + caml_failwith("glLinkProgram function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_gluseprogram( value program ) +{ + caml_failwith("glUseProgram function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_glunuseprogram( value unit ) +{ + caml_failwith("glUseProgram function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_glgetuniformlocation( value program, value name ) +{ + caml_failwith("glGetUniformLocation function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +#endif + + +#ifdef GL_VERSION_2_0 + +CAMLprim value ml_gluniform1f( value location, value v0) { + LOAD_FUNC(glUniform1f, PFNGLUNIFORM1FPROC) + glUniform1f( Int_val(location), Double_val(v0)); + return Val_unit; +} + +CAMLprim value ml_gluniform2f( value location, value v0, value v1) { + LOAD_FUNC(glUniform2f, PFNGLUNIFORM2FPROC) + glUniform2f( Int_val(location), Double_val(v0), Double_val(v1)); + return Val_unit; +} + +CAMLprim value ml_gluniform3f( value location, value v0, value v1, value v2) { + LOAD_FUNC(glUniform3f, PFNGLUNIFORM3FPROC) + glUniform3f( Int_val(location), Double_val(v0), Double_val(v1), Double_val(v2)); + return Val_unit; +} + +CAMLprim value ml_gluniform4f( value location, value v0, value v1, value v2, value v3) { + LOAD_FUNC(glUniform4f, PFNGLUNIFORM4FPROC) + glUniform4f( Int_val(location), Double_val(v0), Double_val(v1), Double_val(v2), Double_val(v3)); + return Val_unit; +} + +CAMLprim value ml_gluniform1i( value location, value v0) { + LOAD_FUNC(glUniform1i, PFNGLUNIFORM1IPROC) + glUniform1i( Int_val(location), Int_val(v0)); + return Val_unit; +} + +CAMLprim value ml_gluniform2i( value location, value v0, value v1) { + LOAD_FUNC(glUniform2i, PFNGLUNIFORM2IPROC) + glUniform2i( Int_val(location), Int_val(v0), Int_val(v1)); + return Val_unit; +} + +CAMLprim value ml_gluniform3i( value location, value v0, value v1, value v2) { + LOAD_FUNC(glUniform3i, PFNGLUNIFORM3IPROC) + glUniform3i( Int_val(location), Int_val(v0), Int_val(v1), Int_val(v2)); + return Val_unit; +} + +CAMLprim value ml_gluniform4i( value location, value v0, value v1, value v2, value v3) { + LOAD_FUNC(glUniform4i, PFNGLUNIFORM4IPROC) + glUniform4i( Int_val(location), Int_val(v0), Int_val(v1), Int_val(v2), Int_val(v3)); + return Val_unit; +} + +#else + +CAMLprim value ml_gluniform1f( value location, value v0) { + caml_failwith("glUniform1f function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_gluniform2f( value location, value v0, value v1) { + caml_failwith("glUniform2f function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_gluniform3f( value location, value v0, value v1, value v2) { + caml_failwith("glUniform3f function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_gluniform4f( value location, value v0, value v1, value v2, value v3) { + caml_failwith("glUniform4f function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_gluniform1i( value location, value v0) { + caml_failwith("glUniform1i function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_gluniform2i( value location, value v0, value v1) { + caml_failwith("glUniform2i function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_gluniform3i( value location, value v0, value v1, value v2) { + caml_failwith("glUniform3i function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} +CAMLprim value ml_gluniform4i( value location, value v0, value v1, value v2, value v3) { + caml_failwith("glUniform4i function is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +} + +#endif + + +#ifdef GL_VERSION_2_0 + +CAMLprim value ml_gluniform1fv( value location, value vars ) +{ + int i, len = Wosize_val(vars) / Double_wosize; + GLfloat val[len]; + for (i=0; i 0) + { + LOAD_FUNC(glGetShaderInfoLog, PFNGLGETSHADERINFOLOGPROC) + value infoLog = caml_alloc_string(infologLength); + glGetShaderInfoLog(Shader_object_val(shader), infologLength, &charsWritten, String_val(infoLog)); + return infoLog; + } else { + return caml_copy_string(""); + } +#else + caml_failwith("glGetShaderInfoLog is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +#endif +} + +CAMLprim value ml_glgetprograminfolog(value program) +{ +#ifdef GL_VERSION_2_0 + int infologLength = 0; + int charsWritten = 0; + + LOAD_FUNC(glGetProgramiv, PFNGLGETPROGRAMIVPROC) + glGetProgramiv( Shader_program_val(program), GL_INFO_LOG_LENGTH, &infologLength); + + if (infologLength > 0) + { + LOAD_FUNC(glGetProgramInfoLog, PFNGLGETPROGRAMINFOLOGPROC) + value infoLog = caml_alloc_string(infologLength); + glGetProgramInfoLog(Shader_program_val(program), infologLength, &charsWritten, String_val(infoLog)); + return infoLog; + } else { + return caml_copy_string(""); + } +#else + caml_failwith("glGetProgramInfoLog is available only if the OpenGL version is 2.0 or greater"); + return Val_unit; +#endif +} + diff --git a/src/raw.ml b/src/raw.ml new file mode 100644 index 0000000..128e4bd --- /dev/null +++ b/src/raw.ml @@ -0,0 +1,84 @@ +(* $Id: raw.ml,v 1.9 2007-04-13 02:48:43 garrigue Exp $ *) + +type addr +type kind = + [`bitmap|`byte|`double|`float|`int|`long|`short + |`ubyte|`uint|`ulong|`ushort] +type fkind = [`double|`float] +type ikind = [`bitmap|`byte|`int|`long|`short|`ubyte|`uint|`ulong|`ushort] +type lkind = [`int|`long|`uint|`ulong] +type 'a t = + { kind: 'a; base: addr; offset: int; size: int; static: bool} + +let kind raw = raw.kind +let byte_size raw = raw.size +let static raw = raw.static +let cast raw ~kind = + { kind = kind; size = raw.size; base = raw.base; + offset = raw.offset; static = raw.static } + +external sizeof : [< kind] -> int = "ml_raw_sizeof" +let length raw = raw.size / sizeof raw.kind +let sub raw ~pos ~len = + let size = sizeof raw.kind in + if pos < 0 or (pos+len) * size > raw.size then invalid_arg "Raw.sub"; + { raw with offset = raw.offset + pos * size; size = len * size } + +external get : [< ikind] t -> pos:int -> int = "ml_raw_get" +external set : [< ikind] t -> pos:int -> int -> unit = "ml_raw_set" +external get_float : [< fkind] t -> pos:int -> float = "ml_raw_get_float" +external set_float : [< fkind] t -> pos:int -> float -> unit + = "ml_raw_set_float" +external get_hi : [< lkind] t -> pos:int -> int = "ml_raw_get_hi" +external set_hi : [< lkind] t -> pos:int -> int -> unit = "ml_raw_set_hi" +external get_lo : [< lkind] t -> pos:int -> int = "ml_raw_get_lo" +external set_lo : [< lkind] t -> pos:int -> int -> unit = "ml_raw_set_lo" +external get_long : [< lkind] t -> pos:int -> nativeint = "ml_raw_get_long" +external set_long : [< lkind] t -> pos:int -> nativeint -> unit + = "ml_raw_set_long" + +external gets : [< ikind] t -> pos:int -> len:int -> int array + = "ml_raw_read" +external gets_string : 'a t -> pos:int -> len:int -> string + = "ml_raw_read_string" +external gets_float : [< fkind] t -> pos:int -> len:int -> float array + = "ml_raw_read_float" +external sets : [< ikind] t -> pos:int -> int array -> unit = "ml_raw_write" +external sets_string : 'a t -> pos:int -> string -> unit + = "ml_raw_write_string" +external sets_float : [< fkind] t -> pos:int -> float array -> unit + = "ml_raw_write_float" + +(* +external fill : [< ikind] t -> pos:int -> len:int -> unit = "ml_raw_fill" +external fill_float : [< fkind] t -> pos:int -> len:int -> unit + = "ml_raw_fill_float" +*) + +external create : ([< kind] as 'a) -> len:int -> 'a t = "ml_raw_alloc" +external create_static : ([< kind] as 'a) -> len:int -> 'a t + = "ml_raw_alloc_static" +external free_static : 'a t -> unit = "ml_raw_free_static" + +let of_array arr ~kind = + let raw = create kind ~len:(Array.length arr) in + sets raw ~pos:0 arr; + raw +let of_float_array arr ~kind = + let raw = create kind ~len:(Array.length arr) in + sets_float raw ~pos:0 arr; + raw +let of_string s ~kind = + let raw = create kind ~len:(String.length s) in + sets_string raw ~pos:0 s; + raw +let of_matrix mat ~kind = + let h = Array.length mat in + if h = 0 then invalid_arg "Raw.of_matrix"; + let w = Array.length mat.(0) in + let raw = create kind ~len:(h*w) in + for i = 0 to h - 1 do + if Array.length mat.(i) <> w then invalid_arg "Raw.of_matrix"; + sets_float raw ~pos:(i*w) mat.(i) + done; + raw diff --git a/src/raw.mli b/src/raw.mli new file mode 100644 index 0000000..94c7b2c --- /dev/null +++ b/src/raw.mli @@ -0,0 +1,83 @@ +(* $Id: raw.mli,v 1.10 2007-04-13 02:48:43 garrigue Exp $ *) + +(* This module provides a direct way to access C arrays of basic types. + This is particularly useful when one wants to avoid costly + conversions between ML and C representations. *) + +type (+'a) t + +type kind = + [`bitmap|`byte|`double|`float|`int|`long|`short + |`ubyte|`uint|`ulong|`ushort] + (* Supported element types. [bitmap] is equivalent to [ubyte] but + allows user modules to distinguish between them *) +type fkind = [`double|`float] +type ikind = [`bitmap|`byte|`int|`long|`short|`ubyte|`uint|`ulong|`ushort] +type lkind = [`int|`long|`uint|`ulong] + +val create : ([< kind] as 'a) -> len:int -> 'a t + (* [create t :len] returns a new raw array of C type t + and length len. This array is managed by the GC *) +val create_static : ([< kind] as 'a) -> len:int -> 'a t + (* [create_static t :len] returns a new raw array of C type t + and length len. This array is created through malloc. + You must free it explicitely *) +val free_static : 'a t -> unit + (* Free a raw array created through create_static *) + +val kind : 'a t -> 'a + (* Returns the type of a free array. Beware of the influence on the + type system: you probably want to write [(kind raw :> kind)] *) +val byte_size : 'a t -> int + (* The size of the array in bytes. That is (sizeof t * len) + where t and len are the parameters to create *) +val static : 'a t -> bool + (* Wether this array was statically allocated or not *) +val cast : 'a t -> kind:([< kind] as 'b) -> 'b t + (* Change the type of a raw array *) + +external sizeof : [< kind] -> int = "ml_raw_sizeof" + (* [sizeof t] returns the physical size of t in bytes *) +val length : [< kind] t -> int + (* [length raw] returns the length of raw array according to + its contents type *) +val sub : ([< kind] t as 'a) -> pos:int -> len:int -> 'a + (* returns the slice of length len starting at position pos *) + +(* The following functions access raw arrays in the intuitive way. + They raise [Invalid_argument] when access is attempted out of + bounds *) + +external get : [< ikind] t -> pos:int -> int = "ml_raw_get" +external set : [< ikind] t -> pos:int -> int -> unit = "ml_raw_set" +external get_float : [< fkind] t -> pos:int -> float = "ml_raw_get_float" +external set_float : [< fkind] t -> pos:int -> float -> unit + = "ml_raw_set_float" +external get_hi : [< lkind] t -> pos:int -> int = "ml_raw_get_hi" +external set_hi : [< lkind] t -> pos:int -> int -> unit = "ml_raw_set_hi" +external get_lo : [< lkind] t -> pos:int -> int = "ml_raw_get_lo" +external set_lo : [< lkind] t -> pos:int -> int -> unit = "ml_raw_set_lo" +external get_long : [< lkind] t -> pos:int -> nativeint = "ml_raw_get_long" +external set_long : [< lkind] t -> pos:int -> nativeint -> unit + = "ml_raw_set_long" + +(* Simultaneous access versions are much more efficient than individual + access, the overhead being paid only once *) + +val gets : [< ikind] t -> pos:int -> len:int -> int array +val sets : [< ikind] t -> pos:int -> int array -> unit +val gets_float : [< fkind] t -> pos:int -> len:int -> float array +val sets_float : [< fkind] t -> pos:int -> float array -> unit + +(* Fastest version: simply copy the contents of the array to and from + a string *) + +val gets_string : 'a t -> pos:int -> len:int -> string +val sets_string : 'a t -> pos:int -> string -> unit + +(* Abbreviations to create raw arrays from ML arrays and strings *) + +val of_array : int array -> kind:([< ikind] as 'a) -> 'a t +val of_float_array : float array -> kind:([< fkind] as 'a) -> 'a t +val of_string : string -> kind:([< kind] as 'a) -> 'a t +val of_matrix : float array array -> kind:([< fkind] as 'a) -> 'a t diff --git a/src/raw_tags.var b/src/raw_tags.var new file mode 100644 index 0000000..d09a6fb --- /dev/null +++ b/src/raw_tags.var @@ -0,0 +1,2 @@ +$$ +bitmap byte ubyte short ushort int uint long ulong float double \ No newline at end of file diff --git a/src/var2def.ml b/src/var2def.ml new file mode 100644 index 0000000..5f3029e --- /dev/null +++ b/src/var2def.ml @@ -0,0 +1,45 @@ +(* $Id: var2def.ml,v 1.9 2001-09-06 08:27:02 garrigue Exp $ *) + +open StdLabels + +(* Compile a list of variant tags into CPP defines *) + +(* hash_variant, from ctype.ml *) + +let hash_variant s = + let accu = ref 0 in + for i = 0 to String.length s - 1 do + accu := 223 * !accu + Char.code s.[i] + done; + (* reduce to 31 bits *) + accu := !accu land (1 lsl 31 - 1); + (* make it signed for 64 bits architectures *) + if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu + +open Genlex + +let lexer = make_lexer ["->"; "$$"] + +let main () = + let s = lexer (Stream.of_channel stdin) in + let tags = Hashtbl.create 57 in + try while true do match s with parser + [< ' Ident tag >] -> + print_string "#define MLTAG_"; + print_string tag; + print_string "\tVal_int("; + let hash = hash_variant tag in + begin try + failwith + (String.concat ~sep:" " + ["Doublon ~tag:";tag;"and";Hashtbl.find tags hash]) + with Not_found -> Hashtbl.add tags hash tag + end; + print_int hash; + print_string ")\n" + | [< ' Kwd "->"; ' Ident _ >] -> () + | [< ' Kwd "$$" >] -> () + | [< >] -> raise End_of_file + done with End_of_file -> () + +let _ = Printexc.print main () diff --git a/src/var2switch.ml b/src/var2switch.ml new file mode 100644 index 0000000..992f7ae --- /dev/null +++ b/src/var2switch.ml @@ -0,0 +1,33 @@ +(* $Id: var2switch.ml,v 1.5 2001-05-08 01:58:25 garrigue Exp $ *) + +(* Build a switch statement translating variants to C tags *) + +open Genlex + +let lexer = make_lexer ["->"; "$$"] + +let main () = + let table = ref false and prefix = ref "" and tag_number = ref 0 in + Arg.parse + ["-table", Arg.Set table, " Produce table output"] + (fun s -> prefix := s) + ""; + let s = lexer (Stream.of_channel stdin) in + try while true do match s with parser + [< ' Ident tag >] -> + incr tag_number; + print_string (if !table then " {MLTAG_" else " case MLTAG_"); + print_string tag; + print_string (if !table then ", " else ":\treturn "); + let name = + match s with parser + [< ' Kwd "->" ; ' Ident name >] -> name + | [< >] -> !prefix ^ String.uppercase tag + in print_string name; + print_string (if !table then "},\n" else ";\n") + | [< ' Kwd "$$" >] -> raise End_of_file + | [< >] -> raise End_of_file + done with End_of_file -> + Printf.printf "#define TAG_NUMBER %d\n" !tag_number + +let _ = Printexc.print main () -- cgit v1.2.3 From bf8a6e812885f8a98afd9c561d9e8809be04d866 Mon Sep 17 00:00:00 2001 From: Ralf Treinen Date: Fri, 16 Mar 2018 09:44:22 +0100 Subject: Import lablgl_1.05-3.debian.tar.xz [dgit import tarball lablgl 1:1.05-3 lablgl_1.05-3.debian.tar.xz] --- META.in | 16 ++ Makefile.config | 63 +++++ TODO | 15 ++ changelog | 503 ++++++++++++++++++++++++++++++++++++++++ clean | 3 + compat | 1 + control | 85 +++++++ copyright | 138 +++++++++++ gbp.conf | 2 + liblablgl-ocaml-dev.dirs.in | 2 + liblablgl-ocaml-dev.docs | 2 + liblablgl-ocaml-dev.links | 1 + liblablgl-ocaml-dev.manpages | 1 + liblablgl-ocaml-dev.ocamldoc.in | 1 + liblablgl-ocaml.dirs.in | 1 + liblablgl-ocaml.docs | 1 + patches/compilation-examples | 36 +++ patches/series | 1 + rules | 44 ++++ source/format | 1 + watch | 2 + xml-man/en/lablgl.xml | 85 +++++++ xml-man/en/license.xml | 48 ++++ xml-man/en/refentryinfo.xml | 41 ++++ xml-man/po4a/po4a.cfg | 7 + 25 files changed, 1100 insertions(+) create mode 100644 META.in create mode 100644 Makefile.config create mode 100644 TODO create mode 100644 changelog create mode 100644 clean create mode 100644 compat create mode 100644 control create mode 100644 copyright create mode 100644 gbp.conf create mode 100644 liblablgl-ocaml-dev.dirs.in create mode 100644 liblablgl-ocaml-dev.docs create mode 100644 liblablgl-ocaml-dev.links create mode 100644 liblablgl-ocaml-dev.manpages create mode 100644 liblablgl-ocaml-dev.ocamldoc.in create mode 100644 liblablgl-ocaml.dirs.in create mode 100644 liblablgl-ocaml.docs create mode 100644 patches/compilation-examples create mode 100644 patches/series create mode 100755 rules create mode 100644 source/format create mode 100644 watch create mode 100644 xml-man/en/lablgl.xml create mode 100644 xml-man/en/license.xml create mode 100644 xml-man/en/refentryinfo.xml create mode 100644 xml-man/po4a/po4a.cfg diff --git a/META.in b/META.in new file mode 100644 index 0000000..98786dc --- /dev/null +++ b/META.in @@ -0,0 +1,16 @@ +version="@LABLGL_VERSION@" +directory="+lablgl" +archive(byte) = "lablgl.cma" +archive(native) = "lablgl.cmxa" + +package "togl" ( + requires = "labltk lablgl" + archive(byte) = "togl.cma" + archive(native) = "togl.cmxa" +) + +package "glut" ( + requires = "lablgl" + archive(byte) = "lablglut.cma" + archive(native) = "lablglut.cmxa" +) diff --git a/Makefile.config b/Makefile.config new file mode 100644 index 0000000..a388291 --- /dev/null +++ b/Makefile.config @@ -0,0 +1,63 @@ +# LablGL and Togl configuration file +# +# Please have a look at the config/Makefile in the Objective Caml distribution, +# or at the labltklink script to get the information needed here +# + +##### Adjust these always + +# Uncomment if you have the fast ".opt" compilers +#CAMLC = ocamlc.opt +#CAMLOPT = ocamlopt.opt + +# Where to put the lablgl script +BINDIR = /usr/bin + +# Where to find X headers +XINCLUDES = -I/usr/X11R6/include +# X libs (for broken RTLD_GLOBAL: e.g. FreeBSD 4.0) +XLIBS = -L/usr/X11R6/lib -lXext -lXmu -lX11 + +# Where to find Tcl/Tk headers +# This must the same version as for LablTk +TKINCLUDES = -I/usr/include/tcl +# Tcl/Tk libs (for broken RTLD_GLOBAL: e.g. FreeBSD 4.0) +TKLIBS = -ltk -ltcl + +# Where to find OpenGL/Mesa/Glut headers and libraries +GLINCLUDES = +GLLIBS = -lGL -lGLU +GLUTLIBS = -lglut +# The following libraries may be required (try to add them one at a time) +#GLLIBS = -lGL -lGLU -lXmu -lXext -lXi -lcipher -lpthread + +# How to index a library after installing (ranlib required on MacOSX) +RANLIB = : +#RANLIB = ranlib + +##### Uncomment these for windows +#TKLIBS = tk83.lib tcl83.lib gdi32.lib user32.lib +#GLLIBS = opengl32.lib glu32.lib +#TOOLCHAIN = msvc +#XA = .lib +#XB = .bat +#XE = .exe +#XO = .obj +#XS = .dll + +##### Adjust these if non standard + +# The Objective Caml library directory +LIBDIR = `ocamlc -where` + +# Where to put dlls (if dynamic loading available) +DLLDIR = `ocamlc -where`/stublibs + +# Where to put LablGL (standard) +INSTALLDIR = $(LIBDIR)/lablgl + +# Where is Togl (default) +#TOGLDIR = Togl + +# C Compiler options +#COPTS = -c -O diff --git a/TODO b/TODO new file mode 100644 index 0000000..d1a1d01 --- /dev/null +++ b/TODO @@ -0,0 +1,15 @@ +lablgl for Debian +---------------------- + + * Need to add the download site in copyright. + * lablgl needs manpage. (mostly ocaml manpage, but with added -thread). + * In truth, it would be better to split the package between : + - the togl tcl/tk widget. + - the OpenGL library. + - the togl bindings. + - the gtkglarea bindings. + - examples and docs ? + * Examples checker.ml, scene.ml and simple.ml are not working, don't know + why (am using the non-DRI versions of Xfree 4's OpenGL). + + -- Sven LUTHER , Sun, 3 Dec 2000 11:06:58 +0100 diff --git a/changelog b/changelog new file mode 100644 index 0000000..b04b1c6 --- /dev/null +++ b/changelog @@ -0,0 +1,503 @@ +lablgl (1:1.05-3) unstable; urgency=medium + + * Switch to the default Tcl/Tk version from 8.5 since 8.5 is to be removed + from Debian. Thanks to Sergei Golovan for the patch! (closes: #892990) + * debian/copyright: + - change license short name "BSD" to "BSD-3-clause" + - add short license names GPL-2+, LGPL-2.1 + - https in format specifier + * Standards-Version 4.1.3 + * debhelper compat level 11 + + -- Ralf Treinen Fri, 16 Mar 2018 09:44:22 +0100 + +lablgl (1:1.05-2) unstable; urgency=medium + + * Add liblabltk-ocaml-dev to Build-Depends + + -- St矇phane Glondu Sat, 10 Oct 2015 06:54:02 +0200 + +lablgl (1:1.05-1) unstable; urgency=medium + + * New upstream release + + -- St矇phane Glondu Tue, 17 Dec 2013 15:31:14 +0100 + +lablgl (20120306-2) unstable; urgency=low + + * Upload to unstable + + -- St矇phane Glondu Tue, 03 Dec 2013 00:38:29 +0100 + +lablgl (20120306-1) experimental; urgency=low + + [ Ralf Treinen ] + * Minor language corrections in package descriptions. + * Fixed spelling error in lablgl.1 manpage. + + [ Mehdi Dogguy ] + * Fix version number in META + * Add myself to uploaders + + [ Sylvain Le Gall ] + * Remove Sylvain Le Gall from uploaders + + [ Lifeng Sun ] + * New upstream release. + * Bump debhelper compat level to 9. + * debian/copyright: switch to Machine-readable format. + * debian/control: + - Bump Standards-Version to 3.9.4. + - Add myself to Uploaders. + - Update Homepage. + - Canonical VCS-* fields. + - liblablgl-ocaml-dev: + + depends on ocaml-findlib. + + minor changes to package description. + * debian/watch: follow ocamlcore.org. + + -- Lifeng Sun Wed, 24 Jul 2013 15:21:15 +0800 + +lablgl (1.04-5) unstable; urgency=low + + * Use Tcl/Tk 8.5 + + -- St矇phane Glondu Thu, 17 Dec 2009 12:27:37 +0100 + +lablgl (1.04-4) unstable; urgency=low + + * Converted to source format 3.0 (quilt) + - added debian/source/format + * Fixed the Makefile in the examples to make compilation work. Patch: + compilation-examples. Closes: Bug#425465. Thanks a lot to Russell + Sears for the patch! + + -- Ralf Treinen Thu, 03 Dec 2009 21:50:04 +0100 + +lablgl (1.04-3) unstable; urgency=low + + * debian/rules: switch to dh and dh-ocaml 0.9 + * debian/control: + - switch to dh-ocaml 0.9 + - move to section ocaml + - add Homepage + - update Standards-Version to 3.8.3 + - Build-depends: update dh-ocaml, ocaml and debhelper + - Uploaders: update my e-mail address, remove Sven + + -- St矇phane Glondu Wed, 23 Sep 2009 20:48:30 +0200 + +lablgl (1.04-2) unstable; urgency=low + + [ Stephane Glondu ] + * Switch packaging to git + * Add myself to Uploaders + * Remove Julien from uploaders + * Get closer to CDBS interface + * Remove dpatch dependency + * Remove versioned dependencies on OCaml introduced for experimental + * Remove versioned dependencies available in stable + * Add debian/clean + + [ Samuel Mimram ] + * Upload to unstable and build with OCaml 3.11. + * Use dh-ocaml predefined variables. + + -- Samuel Mimram Wed, 25 Feb 2009 10:27:41 +0100 + +lablgl (1.04-1) experimental; urgency=low + + * New upstream release. + * Updated compat to 7. + * Updated standards version to 3.8.0. + * Depend on libgl1-mesa-dev instead of xlibmesa-gl-dev. + * Depend on libglu1-mesa-dev instead of libglu1-xorg-dev. + * Depend on x11proto-core-dev instead of x-dev. + + -- Samuel Mimram Tue, 10 Feb 2009 12:50:41 +0100 + +lablgl (1.03-4) experimental; urgency=low + + * Fixed versioning of camlp4 to force resolution against ocaml 3.11 + on experimental. + + -- Romain Beauxis Wed, 17 Dec 2008 01:37:31 +0100 + +lablgl (1.03-3) experimental; urgency=low + + * Upload to experimental to build against ocaml 3.11. + * Versioned build-dep on ocaml to avoid confusion. + * Added build-dep on dh-ocaml (needs the file ocaml-docbase-template.txt). + + -- Romain Beauxis Mon, 15 Dec 2008 17:12:48 +0100 + +lablgl (1.03-2) experimental; urgency=low + + [ Stefano Zacchiroli ] + * fix vcs-svn field to point just above the debian/ dir + + [ Ralf Treinen ] + * Recompiled for ocaml 3.10.2. + * Added myself to Uploaders + + -- Ralf Treinen Mon, 07 Apr 2008 20:50:45 +0200 + +lablgl (1.03-1) unstable; urgency=low + + * New upstream release. + * We don't need to remove rpaths anymore. + * Bumped standards version to 3.7.3, no changes needed. + + -- Samuel Mimram Tue, 11 Dec 2007 10:03:51 +0000 + +lablgl (1.02-7) unstable; urgency=low + + * Build-depends on ocaml 3.10.0-8 to be able to generate *.doc- + base.ocamldoc-apiref + + -- Sylvain Le Gall Tue, 04 Sep 2007 17:53:58 +0200 + +lablgl (1.02-6) unstable; urgency=low + + * Generate ocamldoc documentation + + -- Sylvain Le Gall Mon, 03 Sep 2007 23:16:44 +0200 + +lablgl (1.02-5) unstable; urgency=low + + [ Samuel Mimram ] + * Correct symlink for lablglut manpage (closes: #435895). + * Updated watch file. + + [ Sylvain Le Gall ] + * Upgrade build-dep on ocaml to version 3.10.0 + + -- Sylvain Le Gall Mon, 03 Sep 2007 16:36:57 +0200 + +lablgl (1.02-4) experimental; urgency=low + + * Rebuild for ocaml 3.10.0 + * Don't ignore errors in $(MAKE) clean + * Add myself to uploader + * Use binary:Version + * Add manpages for lablgl, lablglut + * Remove file generated from debian/*.in + + -- Sylvain Le Gall Sat, 14 Jul 2007 02:40:56 +0200 + +lablgl (1.02-3) unstable; urgency=low + + * Build-Depend on debhelper (>= 4.0) since we use compat level 4. + * Improve copyright file and add missing information there. + * Move README.Debian to TODO. + Thanks to Christoph Berg for his remarks about all this. + + -- Julien Cristau Thu, 22 Jun 2006 20:52:30 +0200 + +lablgl (1.02-2) unstable; urgency=low + + * Rebuild with OCaml 3.09.2. + * Updated standards version to 3.7.2, no changes needed. + + -- Samuel Mimram Mon, 15 May 2006 21:23:56 +0000 + +lablgl (1.02-1) unstable; urgency=low + + * New upstream release. + * Rebuild with OCaml 3.09.1. + + -- Samuel Mimram Sat, 7 Jan 2006 13:02:34 +0100 + +lablgl (1.01-9) unstable; urgency=low + + * Build-dep on chrpath and delete the rpath from the stub libraries. + * Drop lintian overrides. + * Add myself to Uploaders. + * liblablgl-ocaml-dev depends on libxmu-dev (Closes: #336128) and + freeglut3-dev (Closes: #295969). + * Use freeglut3-dev instead of libglut3-dev in Build-Depends. + + -- Julien Cristau Wed, 30 Nov 2005 19:46:16 +0100 + +lablgl (1.01-8) unstable; urgency=low + + * Rebuilt for ocaml 3.09.0. + * No hardcoded ocaml abi versions anymore. + + -- Sven Luther Thu, 27 Oct 2005 22:29:48 +0000 + +lablgl (1.01-7) unstable; urgency=low + + [ Julien Cristau ] + * libXxf86vm is not used by lablgl, so we: + + remove libxxf86vm-dev dependency from liblablgl-ocaml-dev. + + remove -lXxf86vm from Makefile.config. + (Closes: #325915) + + [ Samuel Mimram ] + * New maintainer, added myself to uploaders. + + -- Samuel Mimram Fri, 9 Sep 2005 13:08:23 +0200 + +lablgl (1.01-6) unstable; urgency=low + + * Added a watch file + * Added dependency to libglu1-xorg-dev as an alternative to + xlibmesa-glu-dev. + (Closes: #319281) + * Cleanup Build-depends, with explanations for each of them: + replace xlibs-dev with individual library packages, add tcl8.4-dev, remove + libncurses5-dev. + Also remove libxxf86vm-dev, which is not needed. (Julien Cristau) + * Upgrade to standards 3.6.2.0 (no change) + + -- Sven Luther Mon, 29 Aug 2005 23:24:14 +0200 + +lablgl (1.01-5) unstable; urgency=low + + * debian/Makefile.config + - added -lXxf86vm to XLIBS, fixes FTBFS with xorg + * debian/control + - added build-dep on libxxf86vm-dev + - added dep from -dev to libxxf86vm-dev + * changed svn repo structure so that it is compatible with + svn-buildpackage + + -- Stefano Zacchiroli Sat, 23 Jul 2005 17:13:43 +0200 + +lablgl (1.01-4) unstable; urgency=medium + + * Rebuilt against ocaml 3.08.3. + + -- Sven Luther Tue, 22 Mar 2005 08:52:49 +0100 + +lablgl (1.01-3) unstable; urgency=low + + * Added labltk to togl META-dependencies. (Closes: #288837) + + -- Sven Luther Wed, 5 Jan 2005 23:30:58 +0100 + +lablgl (1.01-2) unstable; urgency=low + + * Build with build-depends as ocaml, ocaml-3.08, to see if we can work + around the autobuilder bug with virtual packages this way. + + -- Sven Luther Tue, 27 Jul 2004 17:41:41 +0200 + +lablgl (1.01-1) unstable; urgency=low + + * New upstream version. + * Built with ocaml 3.08. + + -- Sven Luther Thu, 15 Jul 2004 14:14:44 +0200 + +lablgl (1.00-4) unstable; urgency=low + + * Changed build-depends to use new xlibmesa-glu package name. + (Closes: #244805) + + -- Sven Luther Wed, 26 May 2004 09:39:17 +0200 + +lablgl (1.00-3) unstable; urgency=low + + * Added new META files from Stefano, conflicts with older version of + findlib though. + + -- Sven Luther Wed, 14 Jan 2004 21:38:46 +0100 + +lablgl (1.00-2) unstable; urgency=high + + * Since ocaml now is version 3.07+2, modified debian/rules to use ocamlc + -where instead of ocamlc -version. + + -- Sven Luther Mon, 20 Oct 2003 09:20:44 +0200 + +lablgl (1.00-1) unstable; urgency=low + + * New upstream release. + (Adds support for glut, GlArray and some other extensions) + + -- Sven Luther Fri, 10 Oct 2003 15:26:10 +0200 + +lablgl (0.99-16) unstable; urgency=low + + * Rebuilt for ocaml 3.07. + + -- Sven Luther Wed, 1 Oct 2003 16:15:29 +0200 + +lablgl (0.99-15) unstable; urgency=low + + * Still struggling with the libgl/libglu dependencies, since the -14 didn't + build on Stefano's Woody backport. It seems that i have to put the virtual + build-depends last in the alternatives. + + -- Sven Luther Sat, 15 Mar 2003 13:32:18 +0100 + +lablgl (0.99-14) unstable; urgency=low + + * Hope i did it right this time :((( + + -- Sven Luther Fri, 14 Mar 2003 12:38:09 +0100 + +lablgl (0.99-13) unstable; urgency=low + + * The 0.99-10 change disappeared, re-added it :(((( + + -- Sven Luther Fri, 14 Mar 2003 09:52:07 +0100 + +lablgl (0.99-12) unstable; urgency=low + + * Well, the pre gl/glu split xlibmesa packages where xlibmesa and + xlibmesa-dev. + + -- Sven Luther Wed, 12 Mar 2003 11:31:06 +0100 + +lablgl (0.99-11) unstable; urgency=low + + * Added a shlibs.local override for the libglu1 dependency in + liblablgl-ocaml, so that it can also handle pre gl/glu split + xlibmesa3-gl Packages. + + -- Sven Luther Mon, 10 Mar 2003 13:44:15 +0100 + +lablgl (0.99-10) unstable; urgency=low + + * Apparently XFree86 4.2.1-6 is not yet building on arm and alpha, so we + have to workaround the xlibmesa-glu-dev does not depend on xlibmesa3-glu + but ourselves. + + -- Sven Luther Mon, 10 Mar 2003 12:20:03 +0100 + +lablgl (0.99-9) unstable; urgency=low + + * Changed build dependencies and dependencies again to xlibmesa, since the + the problem with xlibmesa-glu was fixed. Also, added an alternative glu + dependency on the xlimesa-gl-dev from before the gl/glu split. I hope this + will make lablgl fit to enter testing, or at lest it will not be stopped + by the nonexistent libglu packages in current testing, so we don't have to + wait for either mesa 5 or xfree86 to be ready. + + -- Sven Luther Mon, 10 Mar 2003 10:11:04 +0100 + +lablgl (0.99-8) unstable; urgency=low + + * Downgraded tcl/tk dependency on 8.3 again, since i was not able to build + ocaml 3.06 with 8.4. I hope that forthcoming 3.07 will be buildable with + tcl/tk 8.4, and that i could then upgrade the dependency again. + (Closes: #183920) + + -- Sven Luther Sat, 08 Mar 2003 13:06:21 +0100 + +lablgl (0.99-7) unstable; urgency=low + + * Removed the old mesag3-glide2 conflict, as it doesn't seem necessary + anymore. + + -- Sven Luther Fri, 14 Feb 2003 11:54:32 +0100 + +lablgl (0.99-6) unstable; urgency=low + + * Still problems on hppa autobuilder, testing built with mesa instead of + the xlibmesa. This will also allow us to build on ia64 and mips, where the + latest XFree86 packages providing xlibmesa-glu fail to build. + + -- Sven Luther Thu, 13 Feb 2003 15:51:50 +0100 + +lablgl (0.99-5) unstable; urgency=low + + * Now also build depend on xlibmesa3-glu, which xlibmesa-glu-dev doesn't + seem to depend on. Hope this fixes the build problem. + + -- Sven Luther Thu, 13 Feb 2003 12:42:22 +0100 + +lablgl (0.99-4) unstable; urgency=low + + * Changed the tcl/tk to depend on tcl/tk 8.4. + (Closes: #180793) + + -- Sven Luther Wed, 12 Feb 2003 22:12:19 +0100 + +lablgl (0.99-3) unstable; urgency=low + + * Added build dependencies on the -glu packages and normal dependencies on + the gl and glu developpment packages. + + -- Sven Luther Tue, 11 Feb 2003 13:30:42 +0100 + +lablgl (0.99-2) unstable; urgency=low + + * Added META file, courtesy of Stefano Zacchiroli. + + -- Sven Luther Fri, 24 Jan 2003 11:47:42 +0100 + +lablgl (0.99-1) unstable; urgency=low + + * New upstream release. + + -- Sven Luther Fri, 10 Jan 2003 10:47:37 +0100 + +lablgl (0.98-4) unstable; urgency=low + + * Rebuilt for ocaml 3.06-13. + * Closes: #164222, actually already in 0.98-3. + * Added glBindTexture patch from Chris. + + -- Sven Luther Sat, 14 Dec 2002 23:09:54 +0100 + +lablgl (0.98-3) unstable; urgency=low + + * added lablGL as a symlink to lablgl. + + -- Sven Luther Wed, 20 Nov 2002 09:09:29 +0100 + +lablgl (0.98-2) unstable; urgency=low + + * Changed Build-depends. + + -- Sven Luther Mon, 30 Sep 2002 18:07:28 +0200 + +lablgl (0.98-1) unstable; urgency=low + + * New upstream release. + * Built with ocaml 3.06. + + -- Sven Luther Wed, 21 Aug 2002 19:41:17 +0200 + +lablgl (0.97-2) unstable; urgency=low + + * Adapting to the new shared library split scheme. + * Now conflicts with mesag3-glide2, since it does not provide the propers + glut 1.3 bindings. Notice that it is possible to build lablgl with + mesag3-glide2, it is just not enabled by default. + + -- Sven Luther Wed, 20 Feb 2002 00:01:42 +0100 + +lablgl (0.97-1) unstable; urgency=low + + * New upstream version for ocaml 3.04. + + -- Sven Luther Thu, 20 Dec 2001 10:22:40 +0100 + +lablgl (0.95-1.1) unstable; urgency=low + + * Rebuilt for ocaml 3.02 + + -- Sven Luther Fri, 16 Mar 2001 10:00:58 +0100 + +lablgl (0.95-1) unstable; urgency=low + + * New upstream release + + -- Sven Luther Fri, 16 Mar 2001 10:00:58 +0100 + +lablgl (0.94-2) unstable; urgency=low + + * Added some build dependencies, ... + + -- Sven Luther Sun, 25 Feb 2001 19:59:30 +0100 + +lablgl (0.94-1) unstable; urgency=low + + * Initial Release. + + -- Sven Luther Sun, 3 Dec 2000 11:06:58 +0100 diff --git a/clean b/clean new file mode 100644 index 0000000..8bf4c72 --- /dev/null +++ b/clean @@ -0,0 +1,3 @@ +src/build.ml +Makefile.config +lablgl.1 diff --git a/compat b/compat new file mode 100644 index 0000000..b4de394 --- /dev/null +++ b/compat @@ -0,0 +1 @@ +11 diff --git a/control b/control new file mode 100644 index 0000000..780cde2 --- /dev/null +++ b/control @@ -0,0 +1,85 @@ +Source: lablgl +Section: ocaml +Priority: optional +Maintainer: Debian OCaml Maintainers +Uploaders: + Samuel Mimram , + St矇phane Glondu , + Mehdi Dogguy , + Ralf Treinen , + Lifeng Sun +Build-Depends: + debhelper (>= 11), + ocaml (>= 4.00.1), + tcl-dev, + tk-dev, + liblabltk-ocaml-dev, + libgl1-mesa-dev | libgl-dev, + libglu1-mesa-dev | libglu-dev, + freeglut3-dev, + x11proto-core-dev, + libxmu-dev, + libx11-dev, + dpkg-dev (>= 1.13.19), + docbook-xml, + docbook-xsl, + libxml2-utils, + xsltproc, + camlp4, + dh-ocaml (>= 0.9) +Standards-Version: 4.1.3 +Homepage: https://forge.ocamlcore.org/projects/lablgl/ +Vcs-Git: git://anonscm.debian.org/pkg-ocaml-maint/packages/lablgl.git +Vcs-Browser: http://anonscm.debian.org/gitweb/?p=pkg-ocaml-maint/packages/lablgl.git + +# Reasons for Build-Depends: +# +# debhelper (>= 4.0): used in debian/rules, debian/compat +# ocaml: the ocaml compiler and stdlib, with labltk +# tcl-dev: #include +# tk-dev: #include +# libgl-dev: #include +# #include +# libglu-dev: #include +# freeglut3-dev: #include +# #include +# x11proto-core-dev: #include +# libxmu-dev: #include +# libx11-dev: #include +# #include +# dpkg-dev (>= 1.13.19): binary:Version +# docbook-xml (>= 4.4), docbook-xsl, libxml2-utils, xsltproc: manpages +# camlp4: camlp4 + +Package: liblablgl-ocaml +Architecture: any +Depends: + ${ocaml:Depends}, + ${shlibs:Depends}, + ${misc:Depends} +Provides: ${ocaml:Provides} +Description: Runtime libraries for lablgl + LablGL is an OpenGL interface for Objective Caml. Since it includes + support for the Togl widget you can comfortably use it with LablTk. + A GtkGlarea binding for use with lablgtk is also provided. + . + This package contains only the dynamic libraries needed for running dynamic + bytecode executables. + +Package: liblablgl-ocaml-dev +Architecture: any +Depends: + libgl1-mesa-dev | libgl-dev, + libglu1-mesa-dev | xlibmesa-glu-dev | libglu-dev, + tk-dev, + ocaml-findlib, + libxmu-dev, + freeglut3-dev, + ${ocaml:Depends}, + ${shlibs:Depends}, + ${misc:Depends} +Provides: ${ocaml:Provides} +Description: OpenGL interface for Objective Caml + LablGL gives access to the OpenGL interface from Objective Caml. Since it + includes support for the Togl widget, you can comfortably use it with + LablTk. A GtkGlarea binding for use with lablgtk is also provided. diff --git a/copyright b/copyright new file mode 100644 index 0000000..75da67f --- /dev/null +++ b/copyright @@ -0,0 +1,138 @@ +Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ +Upstream-Name: lablgl +Upstream-Contact: garrigue@kurims.kyoto-u.ac.jp +Source: https://forge.ocamlcore.org/projects/lablgl/ + +Files: * +Copyright: 1997-2001 Jacques Garrigue + 1997-2001 Kyoto University. + Isaac Trotts + Erick Tryzelaar + Christophe Raffali +License: BSD-3-clause + +Files: LablGlut/examples/caml-images/OCamlMakefile +Copyright: 1999-2002 Markus Mottl +License: BSD-3-clause + +License: BSD-3-clause + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. 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. + 3. Neither the name of the University 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 AUTHOR 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 AUTHOR 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. + +Files: LablGlut/examples/caml-images/main.ml +Copyright: 2002 Issac J. Trotts +License: LGPL-2.1 + This file is distributed under the terms of the GNU Lesser General + Public License, available in /usr/share/common-licenses/LGPL-2.1. + +Files: Togl/* +Copyright: 1996-1998 Brian Paul + Benjamin Bederson +License: + The authors hereby grant permission to use, copy, modify, distribute, + and license this software and its documentation for any purpose, provided + that existing copyright notices are retained in all copies and that this + notice is included verbatim in any distributions. No written agreement, + license, or royalty fee is required for any of the authorized uses. + Modifications to this software may be copyrighted by their authors + and need not follow the licensing terms described here, provided that + the new terms are clearly indicated on the first page of each file where + they apply. + . + IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY + FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY + DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + . + THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE + IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE + NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR + MODIFICATIONS. + +Files: Togl/src/Togl/WinMain2.c + Togl/src/Togl/tkFont.h + Togl/src/Togl/tkInt4.0.h + Togl/src/Togl/tkInt4.1.h + Togl/src/Togl/tkInt8.1.h +Copyright: 1990-1994 The Regents of the University of California + 1995 Sun Microsystems, Inc. + 1998 Scriptics Corporation +License: + The authors hereby grant permission to use, copy, modify, distribute, + and license this software and its documentation for any purpose, provided + that existing copyright notices are retained in all copies and that this + notice is included verbatim in any distributions. No written agreement, + license, or royalty fee is required for any of the authorized uses. + Modifications to this software may be copyrighted by their authors + and need not follow the licensing terms described here, provided that + the new terms are clearly indicated on the first page of each file where + they apply. + . + IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY + FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY + DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + . + THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE + IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE + NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR + MODIFICATIONS. + . + GOVERNMENT USE: If you are acquiring this software on behalf of the + U.S. government, the Government shall have only "Restricted Rights" + in the software and related documentation as defined in the Federal + Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you + are acquiring the software on behalf of the Department of Defense, the + software shall be classified as "Commercial Computer Software" and the + Government shall have only "Restricted Rights" as defined in Clause + 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the + authors grant the U.S. Government and others acting in its behalf + permission to use and distribute the software in accordance with the + terms specified in this license. + +Files: debian/* +Copyright: 2000 Sven LUTHER + 2013 Lifeng Sun +License: GPL-2+ + This package is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + . + This package is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + . + You should have received a copy of the GNU General Public License + along with this program. If not, see + . + On Debian systems, the complete text of the GNU General + Public License version 2 can be found in "/usr/share/common-licenses/GPL-2". diff --git a/gbp.conf b/gbp.conf new file mode 100644 index 0000000..cec628c --- /dev/null +++ b/gbp.conf @@ -0,0 +1,2 @@ +[DEFAULT] +pristine-tar = True diff --git a/liblablgl-ocaml-dev.dirs.in b/liblablgl-ocaml-dev.dirs.in new file mode 100644 index 0000000..30ef5cd --- /dev/null +++ b/liblablgl-ocaml-dev.dirs.in @@ -0,0 +1,2 @@ +usr/bin +@OCamlStdlibDir@/lablgl diff --git a/liblablgl-ocaml-dev.docs b/liblablgl-ocaml-dev.docs new file mode 100644 index 0000000..9af7730 --- /dev/null +++ b/liblablgl-ocaml-dev.docs @@ -0,0 +1,2 @@ +README +Togl/examples diff --git a/liblablgl-ocaml-dev.links b/liblablgl-ocaml-dev.links new file mode 100644 index 0000000..c4d1153 --- /dev/null +++ b/liblablgl-ocaml-dev.links @@ -0,0 +1 @@ +usr/share/man/man1/lablgl.1.gz usr/share/man/man1/lablglut.1.gz diff --git a/liblablgl-ocaml-dev.manpages b/liblablgl-ocaml-dev.manpages new file mode 100644 index 0000000..7e88016 --- /dev/null +++ b/liblablgl-ocaml-dev.manpages @@ -0,0 +1 @@ +lablgl.1 diff --git a/liblablgl-ocaml-dev.ocamldoc.in b/liblablgl-ocaml-dev.ocamldoc.in new file mode 100644 index 0000000..cb7bcad --- /dev/null +++ b/liblablgl-ocaml-dev.ocamldoc.in @@ -0,0 +1 @@ +-I @OCamlStdlibDir@/labltk -no-custom-tags diff --git a/liblablgl-ocaml.dirs.in b/liblablgl-ocaml.dirs.in new file mode 100644 index 0000000..a8131b4 --- /dev/null +++ b/liblablgl-ocaml.dirs.in @@ -0,0 +1 @@ +@OCamlDllDir@ diff --git a/liblablgl-ocaml.docs b/liblablgl-ocaml.docs new file mode 100644 index 0000000..e845566 --- /dev/null +++ b/liblablgl-ocaml.docs @@ -0,0 +1 @@ +README diff --git a/patches/compilation-examples b/patches/compilation-examples new file mode 100644 index 0000000..7e035c2 --- /dev/null +++ b/patches/compilation-examples @@ -0,0 +1,36 @@ +Contributed-by: Russell Sears +Integrated: Ralf Treinen +Fixes-bug: #425465 +Description: make examples compile via "make" +Sent-to-upstream: to Jacques Garrigue by Ralf Treinen, Dec 3 2009 + +--- a/Togl/examples/Makefile ++++ b/Togl/examples/Makefile +@@ -1,4 +1,16 @@ + # Makefile for examples subdir + ++PACKAGES = lablgl.togl,unix ++DERIVEDML = $(patsubst %.ml.gz,%.ml,$(wildcard *.ml.gz)) ++ ++all: $(patsubst %.ml,%.opt,$(wildcard *.ml) $(DERIVEDML)) ++ ++%.ml : %.ml.gz ++ gunzip -c $^ > $@ ++ ++%.opt : %.ml ++ ocamlfind ocamlopt -package $(PACKAGES) -c $^ ++ ocamlfind ocamlopt -package $(PACKAGES) -linkpkg -o $@ $^ ++ + clean: +- rm -f *.cm* *.o *.opt ++ rm -f *.cm* *.o *.opt $(DERIVEDML) +--- a/Togl/examples/planet.ml ++++ b/Togl/examples/planet.ml +@@ -1,6 +1,6 @@ + (* $Id: planet.ml,v 1.17 2001-09-07 06:50:01 garrigue Exp $ *) + +-#load"unix.cma";; ++open Unix + + class planet togl = object (self) + val togl = togl diff --git a/patches/series b/patches/series new file mode 100644 index 0000000..dbe16b3 --- /dev/null +++ b/patches/series @@ -0,0 +1 @@ +compilation-examples diff --git a/rules b/rules new file mode 100755 index 0000000..db2f5e1 --- /dev/null +++ b/rules @@ -0,0 +1,44 @@ +#!/usr/bin/make -f +# -*- makefile -*- + +include /usr/share/ocaml/ocamlvars.mk + +# Uncomment this to turn on verbose mode. +#export DH_VERBOSE=1 + +VERSION:=$(shell sed -n "s/^LablGL \(.*\):/\1/p" CHANGES | head -n 1) +export OCAMLINIT_SED=-e 's%@LABLGL_VERSION@%$(VERSION)%g' + +%: + dh $@ --with ocaml + +.PHONY: override_dh_auto_configure +override_dh_auto_configure: + cp debian/Makefile.config . + +.PHONY: override_dh_auto_build +override_dh_auto_build: + $(MAKE) +ifneq ($(OCAML_OPT_ARCH),) + $(MAKE) opt +endif + + # Quick replacement for docbook/po4a CDBS class + # TODO: use cdbs + po4a + xmllint --nonet --noout --postvalid --xinclude $(CURDIR)/debian/xml-man/en/lablgl.xml + xsltproc --nonet --xinclude --param man.charmap.use.subset 0 \ + -o $(CURDIR)/ /usr/share/xml/docbook/stylesheet/nwalsh/manpages/docbook.xsl \ + $(CURDIR)/debian/xml-man/en/lablgl.xml + +.PHONY: override_dh_auto_clean +override_dh_auto_clean: + [ ! -f "$(CURDIR)/Makefile" ] || [ ! -f "$(CURDIR)/Makefile.config" ] || $(MAKE) clean + +.PHONY: override_dh_auto_install +override_dh_auto_install: + $(MAKE) install \ + LIBDIR=$(CURDIR)/debian/liblablgl-ocaml-dev$(OCAML_STDLIB_DIR) \ + DLLDIR=$(CURDIR)/debian/liblablgl-ocaml$(OCAML_STDLIB_DIR)/stublibs \ + BINDIR=$(CURDIR)/debian/liblablgl-ocaml-dev/usr/bin + cp debian/META $(CURDIR)/debian/liblablgl-ocaml-dev$(OCAML_STDLIB_DIR)/lablgl + ln -sf $(OCAML_STDLIB_DIR)/lablgl $(CURDIR)/debian/liblablgl-ocaml-dev$(OCAML_STDLIB_DIR)/lablGL diff --git a/source/format b/source/format new file mode 100644 index 0000000..163aaf8 --- /dev/null +++ b/source/format @@ -0,0 +1 @@ +3.0 (quilt) diff --git a/watch b/watch new file mode 100644 index 0000000..4faf76e --- /dev/null +++ b/watch @@ -0,0 +1,2 @@ +version=3 +https://forge.ocamlcore.org/frs/?group_id=291 .*/lablgl-([0-9\.]{1,7})\.tar\.gz diff --git a/xml-man/en/lablgl.xml b/xml-man/en/lablgl.xml new file mode 100644 index 0000000..97fe811 --- /dev/null +++ b/xml-man/en/lablgl.xml @@ -0,0 +1,85 @@ + + + lablgl"> + lablglut"> +]> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + LABGL + 1 + + + + lablgl + + OCaml toplevel with labgl support. + + + + + &dhprg; + ocaml toplevel option + + + + + DESCRIPTION + + This manual page documents briefly the &dhprg; command. + + This manual page was written for the &debian; distribution + because the original program does not have a manual page. + + + The &dhprg; commands launch an OCaml toplevel with + lablgl or labglut support. &dhprg2; provides the same functionality + for lablglut. + + + + + + + SEE ALSO + + + + + ocaml + + 1 + + + + diff --git a/xml-man/en/license.xml b/xml-man/en/license.xml new file mode 100644 index 0000000..b4cb4ec --- /dev/null +++ b/xml-man/en/license.xml @@ -0,0 +1,48 @@ + + +]> + + + + + + + + + + + + + + + + + + + + + + + + + + + LICENSE + + + This manual page was written by + + Sylvain + Le Gall + + gildor@debian.org + for the &debian; system (but may be used by others). + Permission is granted to copy, distribute and/or modify this document + under the terms of the GNU Lesser General Public + License, Version 2.1 or any later version published by the Free + Software Foundation; considering as source code all the file that + enable the production of this manpage. + + diff --git a/xml-man/en/refentryinfo.xml b/xml-man/en/refentryinfo.xml new file mode 100644 index 0000000..5384547 --- /dev/null +++ b/xml-man/en/refentryinfo.xml @@ -0,0 +1,41 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Sylvain + Le Gall + gildor@debian.org + + + 2007 + Sylvain Le Gall + + Jul 15, 2007 + diff --git a/xml-man/po4a/po4a.cfg b/xml-man/po4a/po4a.cfg new file mode 100644 index 0000000..4345b9c --- /dev/null +++ b/xml-man/po4a/po4a.cfg @@ -0,0 +1,7 @@ +[po4a_paths] debian/xml-man/po4a/po/lablgl-man.pot + +[type: docbook] debian/xml-man/en/lablgl.xml + +[type: docbook] debian/xml-man/en/license.xml + +[type: docbook] debian/xml-man/en/refentryinfo.xml -- cgit v1.2.3 From 8bfbb1a3bb1a711d3d2fd72ccadbf3ef424b8d2f Mon Sep 17 00:00:00 2001 From: Debian OCaml Maintainers Date: Fri, 16 Mar 2018 09:44:22 +0100 Subject: make examples compile via "make" Contributed-by: Russell Sears Integrated: Ralf Treinen Fixes-bug: #425465 Sent-to-upstream: to Jacques Garrigue by Ralf Treinen, Dec 3 2009 Gbp-Pq: Name compilation-examples --- Togl/examples/Makefile | 14 +++++++++++++- Togl/examples/planet.ml | 2 +- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/Togl/examples/Makefile b/Togl/examples/Makefile index 86fe6ca..da2168f 100644 --- a/Togl/examples/Makefile +++ b/Togl/examples/Makefile @@ -1,4 +1,16 @@ # Makefile for examples subdir +PACKAGES = lablgl.togl,unix +DERIVEDML = $(patsubst %.ml.gz,%.ml,$(wildcard *.ml.gz)) + +all: $(patsubst %.ml,%.opt,$(wildcard *.ml) $(DERIVEDML)) + +%.ml : %.ml.gz + gunzip -c $^ > $@ + +%.opt : %.ml + ocamlfind ocamlopt -package $(PACKAGES) -c $^ + ocamlfind ocamlopt -package $(PACKAGES) -linkpkg -o $@ $^ + clean: - rm -f *.cm* *.o *.opt + rm -f *.cm* *.o *.opt $(DERIVEDML) diff --git a/Togl/examples/planet.ml b/Togl/examples/planet.ml index 0a0f3fb..9d84849 100644 --- a/Togl/examples/planet.ml +++ b/Togl/examples/planet.ml @@ -1,6 +1,6 @@ (* $Id: planet.ml,v 1.17 2001-09-07 06:50:01 garrigue Exp $ *) -#load"unix.cma";; +open Unix class planet togl = object (self) val togl = togl -- cgit v1.2.3 From af28c1132f0ddf74bbd80a300b7ecd1cf62e034c Mon Sep 17 00:00:00 2001 From: Debian OCaml Maintainers Date: Wed, 7 Aug 2019 10:50:23 +0200 Subject: make examples compile via "make" Contributed-by: Russell Sears Integrated: Ralf Treinen Fixes-bug: #425465 Sent-to-upstream: to Jacques Garrigue by Ralf Treinen, Dec 3 2009 Gbp-Pq: Name compilation-examples --- Togl/examples/Makefile | 14 +++++++++++++- Togl/examples/planet.ml | 2 +- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/Togl/examples/Makefile b/Togl/examples/Makefile index 86fe6ca..da2168f 100644 --- a/Togl/examples/Makefile +++ b/Togl/examples/Makefile @@ -1,4 +1,16 @@ # Makefile for examples subdir +PACKAGES = lablgl.togl,unix +DERIVEDML = $(patsubst %.ml.gz,%.ml,$(wildcard *.ml.gz)) + +all: $(patsubst %.ml,%.opt,$(wildcard *.ml) $(DERIVEDML)) + +%.ml : %.ml.gz + gunzip -c $^ > $@ + +%.opt : %.ml + ocamlfind ocamlopt -package $(PACKAGES) -c $^ + ocamlfind ocamlopt -package $(PACKAGES) -linkpkg -o $@ $^ + clean: - rm -f *.cm* *.o *.opt + rm -f *.cm* *.o *.opt $(DERIVEDML) diff --git a/Togl/examples/planet.ml b/Togl/examples/planet.ml index 0a0f3fb..9d84849 100644 --- a/Togl/examples/planet.ml +++ b/Togl/examples/planet.ml @@ -1,6 +1,6 @@ (* $Id: planet.ml,v 1.17 2001-09-07 06:50:01 garrigue Exp $ *) -#load"unix.cma";; +open Unix class planet togl = object (self) val togl = togl -- cgit v1.2.3