#lang scheme

;;; Qv http://www.opengl.org/resources/code/samples/glut_examples/examples/molehill.c

(require "glplus.ss" sgl sgl/gl-vectors)
(require mred)

(define my-canvas%
  (class* canvas% ()

    (inherit with-gl-context swap-gl-buffers)

    (define/override on-paint 
      (lambda ()
        (with-gl-context
         (lambda () 
           (display) 
           (swap-gl-buffers))) ))
    
    (define/override on-size 
      (lambda (w h)
        (with-gl-context
         (lambda () 
           (create-view w h)))))

    (super-instantiate () (style '(gl no-autoclear)))))


(define (create-view w h)
  (gl-viewport 0 0 w h)
  (gl-matrix-mode 'projection)
  (gl-load-identity)
  (gl-perspective 55 1 2 24)
  (gl-matrix-mode 'modelview)
  (gl-load-identity)
  ;; Move away from image and rotate in x-direction to give nice view.
  (gl-translate 0 0 -15)
  (gl-rotate 330 1 0 0) )

(define (display)
  (unless pts1
    (create-surfaces)
    (render-surfaces))
  (gl-clear-color 0.2 0 0.4 1)
  (gl-clear 'color-buffer-bit 'depth-buffer-bit)
  (gl-call-list 1))
     
(define (initialize)
  (gl-material-v 'front 'specular mat-specular)
  (gl-material-v 'front 'shininess mat-shininess)
  (gl-enable 'lighting)
  (gl-enable 'light0)
  (gl-enable 'depth-test)
  (gl-enable 'auto-normal)
  (gl-enable 'normalize)
  (set! nurb (gluNewNurbsRenderer))
  (gluNurbsProperty nurb GLU_SAMPLING_TOLERANCE 25.0)
  (gluNurbsProperty nurb GLU_DISPLAY_MODE GLU_FILL) )

(define (render-surfaces)
  (define (render-surface mat surf)
    (gl-material-v 'front 'diffuse mat)
    (gluBeginSurface nurb)
    (gluNurbsSurface nurb 8 knots 8 knots (* 4 3) 3 surf 4 4 GL_MAP2_VERTEX_3)
    (gluEndSurface nurb))
  (gl-new-list 1 'compile)
  ;; Render red hill.
  (render-surface mat-red-diffuse pts1)
  ;; Render green hill.
  (render-surface mat-green-diffuse pts2)
  ;; Render blue hill.
  (render-surface mat-blue-diffuse pts3)
  ;; Render yellow hill.
  (render-surface mat-yellow-diffuse pts4)
  (gl-end-list) )

(define (create-surfaces)
  (define (aset a r c coord v) (gl-vector-set! a (+ coord (* c 3) (* r 3 4)) v))
  ;; Build control points for NURBS mole hills
  (set! pts1 (make-gl-float-vector (* 4 4 3)))
  (set! pts2 (make-gl-float-vector (* 4 4 3)))
  (set! pts3 (make-gl-float-vector (* 4 4 3)))
  (set! pts4 (make-gl-float-vector (* 4 4 3)))
  (do ((u 0 (+ u 1))) ((= u 4))
    (do ((v 0 (+ v 1))) ((= v 4))
      ;; Red.
      (aset pts1 u v 0 (* 2 u))
      (aset pts1 u v 1 (* 2 v))
      (aset pts1 u v 2 (if (and (or (= u 1) (= u 2)) (or (= v 1) (= v 2)))
			   ;; Stretch up middle.
			   6
			   0))
      ;; Green.
      (aset pts2 u v 0 (* 2 (- u 3)))
      (aset pts2 u v 1 (* 2 (- v 3)))
      (aset pts2 u v 2
	    (if (and (or (= u 1) (= u 2)) (or (= v 1) (= v 2)))
		(if (and (= u 1) (= v 1))
		    ;; Pull hard on single middle square.
		    15
		    ;; Push down on other middle squares.
		    -2)
		0))
      ;; Blue.
      (aset pts3 u v 0 (* 2 (- u 3)))
      (aset pts3 u v 1 (* 2 v))
      (aset pts3 u v 2
	    (if (and (or (= u 1) (= u 2)) (or (= v 1) (= v 2)))
		(if (and (= u 1) (= v 2))
		    ;; Pull up on single middle square.
		    11
		    ;; Push up slightly on other middle squares.
		    2)
		0))
      ;; Yellow
      (aset pts4 u v 0 (* 2 u))
      (aset pts4 u v 1 (* 2 (- v 3)))
      (aset pts4 u v 2
	    (if (and (or (= u 1) (= u 2) (= u 3)) (or (= v 1) (= v 2)))
		(if (= v 1)
		    ;; Push down front middle and right squares.
		    -1
		    ;; Pull up back middle and right squares.
		    5)
		0)) ))
  
  ;; Stretch up red's far right corner.
  (aset pts1 3 3 2 6)
  ;; Pull down green's near left corner a little.
  (aset pts2 0 0 2 -2)
  ;; Turn up meeting of four corners.
  (aset pts1 0 0 2 1)
  (aset pts2 3 3 2 1)
  (aset pts3 3 0 2 1)
  (aset pts4 0 3 2 1) )


(define nurb #f)
(define pts1 #f)
(define pts2 #f)
(define pts3 #f)
(define pts4 #f)
(define mat-red-diffuse    (gl-float-vector 0.7 0   0.1 1))
(define mat-green-diffuse  (gl-float-vector 0   0.7 0.1 1))
(define mat-blue-diffuse   (gl-float-vector 0   0.1 0.7 1))
(define mat-yellow-diffuse (gl-float-vector 0.7 0.8 0.1 1))
(define mat-specular (gl-float-vector 1 1 1 1))
(define mat-shininess (gl-float-vector 100))
(define knots (gl-float-vector 0 0 0 0 1 1 1 1))

(define f (instantiate frame% ("molehill") (width 300) (height 300)))
(define a-canvas (instantiate my-canvas% (f) ))
(send f show #t)
(send a-canvas with-gl-context initialize)