#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 <neil@neilvandyke.org>, 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
