#lang scheme ;; $Id: teapot.ss,v 1.24 2002/12/04 06:30:49 neil Exp $ ;; ;; This is a very simple version of the Newell Teapot, for PLT Scheme 202 using ;; the SGL OpenGL bindings. See "http://www.sjbaker.org/teapot/" for the ;; history. The Bezier patch translations to OpenGL are adapted from ;; "teapot.c", by Mark J. Kilgard, in which the following notices appear: ;; ;; Copyright (c) Mark J. Kilgard, 1994. ;; (c) Copyright 1993, Silicon Graphics, Inc. ;; Permission to use, copy, modify, and distribute this software for any ;; purpose and without fee is hereby granted, provided that the above ;; copyright notice appear in all copies and that both the copyright notice ;; and this permission notice appear in supporting documentation, and that ;; the name of Silicon Graphics, Inc. not be used in advertising or ;; publicity pertaining to distribution of the software without specific, ;; written prior permission. ;; ;; Scheme version by Neil W. Van Dyke , 28-Nov-2002. ;; See "http://www.neilvandyke.org/opengl-plt/" for more information. ;; trivially ported to PLT4 bindings - goetter 19 Aug 2008 ;; teapot history now at http://www.sjbaker.org/wiki/index.php?title=The_History_of_The_Teapot (require (lib "mred.ss" "mred") (lib "class.ss") (lib "math.ss") (lib "main.ss" "sgl") (lib "gl.ss" "sgl") (lib "gl-vectors.ss" "sgl")) (define patchdata '#( ;; rim #(102 103 104 105 4 5 6 7 8 9 10 11 12 13 14 15) ;; body #(12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27) #(24 25 26 27 29 30 31 32 33 34 35 36 37 38 39 40) ;; lid #(96 96 96 96 97 98 99 100 101 101 101 101 0 1 2 3) #(0 1 2 3 106 107 108 109 110 111 112 113 114 115 116 117) ;; bottom #(118 118 118 118 124 122 119 121 123 126 125 120 40 39 38 37) ;; handle #(41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56) #(53 54 55 56 57 58 59 60 61 62 63 64 28 65 66 67) ;; spout #(68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83) #(80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95))) (define cpdata '#(#( 0.2 0.0 2.7 ) #( 0.2 -0.112 2.7 ) #( 0.112 -0.2 2.7 ) #( 0.0 -0.2 2.7 ) #( 1.3375 0.0 2.53125) #( 1.3375 -0.749 2.53125) #( 0.749 -1.3375 2.53125) #( 0.0 -1.3375 2.53125) #( 1.4375 0.0 2.53125) #( 1.4375 -0.805 2.53125) #( 0.805 -1.4375 2.53125) #( 0.0 -1.4375 2.53125) #( 1.5 0.0 2.4 ) #( 1.5 -0.84 2.4 ) #( 0.84 -1.5 2.4 ) #( 0.0 -1.5 2.4 ) #( 1.75 0.0 1.875 ) #( 1.75 -0.98 1.875 ) #( 0.98 -1.75 1.875 ) #( 0.0 -1.75 1.875 ) #( 2.0 0.0 1.35 ) #( 2.0 -1.12 1.35 ) #( 1.12 -2.0 1.35 ) #( 0.0 -2.0 1.35 ) #( 2.0 0.0 0.9 ) #( 2.0 -1.12 0.9 ) #( 1.12 -2.0 0.9 ) #( 0.0 -2.0 0.9 ) #(-2.0 0.0 0.9 ) #( 2.0 0.0 0.45 ) #( 2.0 -1.12 0.45 ) #( 1.12 -2.0 0.45 ) #( 0.0 -2.0 0.45 ) #( 1.5 0.0 0.225 ) #( 1.5 -0.84 0.225 ) #( 0.84 -1.5 0.225 ) #( 0.0 -1.5 0.225 ) #( 1.5 0.0 0.15 ) #( 1.5 -0.84 0.15 ) #( 0.84 -1.5 0.15 ) #( 0.0 -1.5 0.15 ) #(-1.6 0.0 2.025 ) #(-1.6 -0.3 2.025 ) #(-1.5 -0.3 2.25 ) #(-1.5 0.0 2.25 ) #(-2.3 0.0 2.025 ) #(-2.3 -0.3 2.025 ) #(-2.5 -0.3 2.25 ) #(-2.5 0.0 2.25 ) #(-2.7 0.0 2.025 ) #(-2.7 -0.3 2.025 ) #(-3.0 -0.3 2.25 ) #(-3.0 0.0 2.25 ) #(-2.7 0.0 1.8 ) #(-2.7 -0.3 1.8 ) #(-3.0 -0.3 1.8 ) #(-3.0 0.0 1.8 ) #(-2.7 0.0 1.575 ) #(-2.7 -0.3 1.575 ) #(-3.0 -0.3 1.35 ) #(-3.0 0.0 1.35 ) #(-2.5 0.0 1.125 ) #(-2.5 -0.3 1.125 ) #(-2.65 -0.3 0.9375 ) #(-2.65 0.0 0.9375 ) #(-2.0 -0.3 0.9 ) #(-1.9 -0.3 0.6 ) #(-1.9 0.0 0.6 ) #( 1.7 0.0 1.425 ) #( 1.7 -0.66 1.425 ) #( 1.7 -0.66 0.6 ) #( 1.7 0.0 0.6 ) #( 2.6 0.0 1.425 ) #( 2.6 -0.66 1.425 ) #( 3.1 -0.66 0.825 ) #( 3.1 0.0 0.825 ) #( 2.3 0.0 2.1 ) #( 2.3 -0.25 2.1 ) #( 2.4 -0.25 2.025 ) #( 2.4 0.0 2.025 ) #( 2.7 0.0 2.4 ) #( 2.7 -0.25 2.4 ) #( 3.3 -0.25 2.4 ) #( 3.3 0.0 2.4 ) #( 2.8 0.0 2.475 ) #( 2.8 -0.25 2.475 ) #( 3.525 -0.25 2.49375) #( 3.525 0.0 2.49375) #( 2.9 0.0 2.475 ) #( 2.9 -0.15 2.475 ) #( 3.45 -0.15 2.5125 ) #( 3.45 0.0 2.5125 ) #( 2.8 0.0 2.4 ) #( 2.8 -0.15 2.4 ) #( 3.2 -0.15 2.4 ) #( 3.2 0.0 2.4 ) #( 0.0 0.0 3.15 ) #( 0.8 0.0 3.15 ) #( 0.8 -0.45 3.15 ) #( 0.45 -0.8 3.15 ) #( 0.0 -0.8 3.15 ) #( 0.0 0.0 2.85 ) #( 1.4 0.0 2.4 ) #( 1.4 -0.784 2.4 ) #( 0.784 -1.4 2.4 ) #( 0.0 -1.4 2.4 ) #( 0.4 0.0 2.55 ) #( 0.4 -0.224 2.55 ) #( 0.224 -0.4 2.55 ) #( 0.0 -0.4 2.55 ) #( 1.3 0.0 2.55 ) #( 1.3 -0.728 2.55 ) #( 0.728 -1.3 2.55 ) #( 0.0 -1.3 2.55 ) #( 1.3 0.0 2.4 ) #( 1.3 -0.728 2.4 ) #( 0.728 -1.3 2.4 ) #( 0.0 -1.3 2.4 ) #( 0.0 0.0 0.0 ) #( 1.425 -0.798 0.0 ) #( 1.5 0.0 0.075 ) #( 1.425 0.0 0.0 ) #( 0.798 -1.425 0.0 ) #( 0.0 -1.5 0.075 ) #( 0.0 -1.425 0.0 ) #( 1.5 -0.84 0.075 ) #( 0.84 -1.5 0.075 ))) (define teapot (let ((tex (vector->gl-float-vector '#(0 0 1 0 0 1 1 1)))) (lambda (grid scale type) (gl-push-attrib 'enable-bit 'eval-bit) (gl-enable 'auto-normal) (gl-enable 'normalize) (gl-enable 'map2-vertex-3) (gl-enable 'map2-texture-coord-2) (gl-push-matrix) (let* ((patchdata-len (vector-length patchdata)) (pqrs-len (* 4 4 3)) (p (make-vector pqrs-len)) (q (make-vector pqrs-len)) (r (make-vector pqrs-len)) (s (make-vector pqrs-len))) (do ((i 0 (+ 1 i))) ((= i patchdata-len)) (let ((jkl 0)) (do ((j 0 (+ 1 j))) ((= j 4)) (do ((k 0 (+ 1 k))) ((= k 4)) (let* ((pd (vector-ref patchdata i)) (pd-jk-1 (vector-ref pd (+ (* j 4) k))) (pd-jk-2 (vector-ref pd (+ (* j 4) (- 3 k))))) (do ((l 0 (+ 1 l))) ((= l 3)) (let* ((d1 (vector-ref (vector-ref cpdata pd-jk-1) l)) (d2 (vector-ref (vector-ref cpdata pd-jk-2) l))) (vector-set! p jkl d1) (vector-set! q jkl ((if (= l 1) - +) d2)) (when (< i 6) (vector-set! r jkl ((if (= l 0) - +) d2)) (vector-set! s jkl ((if (< l 2) - +) d1)))) (set! jkl (+ 1 jkl))))))) (glMap2f GL_MAP2_TEXTURE_COORD_2 0 1 2 2 0 1 4 2 tex) (glMap2f GL_MAP2_VERTEX_3 0 1 3 4 0 1 12 4 (vector->gl-float-vector p)) (gl-map-grid grid 0.0 1.0 grid 0.0 1.0) ;; have to use C style because no 'fill to GL_FILL mapping in gl/sgl (glEvalMesh2 type 0 grid 0 grid) ;; no gl-map in gl/sgl (glMap2f GL_MAP2_VERTEX_3 0 1 3 4 0 1 12 4 (vector->gl-float-vector q)) (glEvalMesh2 type 0 grid 0 grid) (when (< i 6) (glMap2f GL_MAP2_VERTEX_3 0 1 3 4 0 1 12 4 (vector->gl-float-vector r)) (glEvalMesh2 type 0 grid 0 grid) (glMap2f GL_MAP2_VERTEX_3 0 1 3 4 0 1 12 4 (vector->gl-float-vector s)) (glEvalMesh2 type 0 grid 0 grid)))) (gl-pop-matrix) (gl-pop-attrib)))) (define controls? #t) (define teapot-canvas% (class* canvas% () (inherit refresh with-gl-context swap-gl-buffers) (define teapot-dl #f) (define view-rotx 285.0) (define view-roty 0.0) (define view-rotz 0.0) (define (move x y) (set! view-rotx (+ view-rotx x)) (set! view-roty (+ view-roty y)) (refresh)) (define/public (move-left) (move 0.0 5.0)) (define/public (move-right) (move 0.0 -5.0)) (define/public (move-up) (move 5.0 0.0)) (define/public (move-down) (move -5.0 0.0)) (define/override (on-size width height) (with-gl-context (lambda () (gl-viewport 0 0 width height) (gl-matrix-mode 'projection) (gl-load-identity) (let ((h (/ height width))) (gl-frustum -1.0 1.0 (- h) h 1.0 100.0)) (gl-matrix-mode 'modelview) (gl-load-identity) (gl-translate 0.0 -1.0 -5.5) (gl-light-v 'light0 'position (vector->gl-float-vector (vector 5.0 5.0 10.0 0.0))) (gl-enable 'lighting) (gl-enable 'light0) (gl-enable 'depth-test) (unless teapot-dl (set! teapot-dl (gl-gen-lists 1)) (gl-new-list teapot-dl 'compile) ;; should be 'fill - no mapping for gl-eval-mesh in gl/sgl (teapot 24 0.6 GL_FILL) (gl-end-list))))) (define/override (on-paint) (with-gl-context (lambda () (gl-clear-color 0.0 0.0 0.0 0.0) (gl-clear 'color-buffer-bit 'depth-buffer-bit) (gl-push-matrix) (gl-rotate view-rotx 1.0 0.0 0.0) (gl-rotate view-roty 0.0 1.0 0.0) (gl-rotate view-rotz 0.0 0.0 1.0) (gl-call-list teapot-dl) (gl-pop-matrix) (swap-gl-buffers) (gl-flush)))) ;; add no-autoclear to prevent flash (super-instantiate () (style '(gl no-autoclear))))) (let* ((f (make-object frame% "teapot.ss" #f)) (c (instantiate teapot-canvas% (f) (min-width 300) (min-height 300)))) (when controls? (let ((h (instantiate horizontal-panel% (f) (alignment '(center center)) (stretchable-height #f) (stretchable-width #f)))) (instantiate button% ("Left" h (lambda x (send c move-left))) (stretchable-width #t)) (let ((v (instantiate vertical-panel% (h) (alignment '(center center)) (stretchable-width #f)))) (instantiate button% ("Up" v (lambda x (send c move-up))) (stretchable-width #t)) (instantiate button% ("Down" v (lambda x (send c move-down))) (stretchable-width #t))) (instantiate button% ("Right" h (lambda x (send c move-right))) (stretchable-width #t)))) (send f show #t)) ;;eof