#!/usr/bin/env ypsilon
   
;; glut-demo.scm:
;;   GLUT, OpenGL, FFI, and Concurrent GC Stress Test
;;
;; Requirements:
;;   Darwin:  OpenGL.framework GLUT.framework
;;   Windows: opengl32.dll glut32.dll
;;   Linux:   libGL.so.1 libglut.so.3
;;   FreeBSD: libGL.so.1 libglut.so.4
               
(import (only (core) auto-compile-verbose scheme-load-verbose))

(auto-compile-verbose #t)
(scheme-load-verbose #t)

(import (rnrs)
        (rnrs programs)
        (srfi :28)
        (ypsilon gl)
        (ypsilon glut)
        (ypsilon time))

(define object glutSolidIcosahedron)
(define current-direction #t)
(define current-angle 0.0)
(define last-update 0)

(define display-func
  (lambda ()
    (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
    (do ((y 2.0 (+ y 3.0)))
      ((> y 14.0))
      (do ((x 2.0 (+ x 3.0)))
        ((> x 14.0))
        (if current-direction
            (render-one x y
                        0.4 (/ x 40.0) (/ y 40.0)
                        (/ x 20.0) (/ y 20.0) 0.4
                        (/ x 20.0) 0.2 (/ y 20.0)
                        (/ (+ x y) 20.0 100.0))
            (render-one x y
                        (/ y 40.0) (/ x 40.0) 0.4
                        (/ x 20.0) 0.4 (/ y 20.0)
                        0.2 (/ x 20.0) (/ y 20.0)
                        (/ (+ x y) 20.0 100.0)))))
    (glutSwapBuffers)))

(define rotate-func
  (lambda ()
    (cond ((< (+ last-update 16000) (microsecond))
           (if (= (glutGetWindow) 0) (exit 0))
           (if current-direction
               (let ((new-current-angle (+ current-angle 2.0)))
                 (if (>= new-current-angle 360.0)
                     (set! current-angle (- new-current-angle 360.0))
                     (set! current-angle new-current-angle)))
               (let ((new-current-angle (- current-angle 2.0)))
                 (if (< new-current-angle 360.0)
                     (set! current-angle (+ new-current-angle 360.0))
                     (set! current-angle new-current-angle))))
           (set! last-update (microsecond))
           (glutPostRedisplay)))))

(define mouse-func
  (lambda (button state x y)
    (and (= state 0) (set! current-direction (not current-direction)))
    (format #t "mouse-func callback ~s ~s ~s ~s ~%" button state x y)))

(define show-dodecahedron (lambda () (glScalef 0.6 0.6 0.6) (glutSolidDodecahedron)))
(define show-sphere       (lambda () (glutSolidSphere 1.0 32 16)))
(define show-cone         (lambda () (glutSolidCone 1.0 2.0 32 1)))
(define show-cube         (lambda () (glutSolidCube 1.5)))
(define show-torus        (lambda () (glutSolidTorus 0.5 1.0 16 32)))

(define menu
  (lambda (m)
    (format #t "menu callback ~s ~%" m)
    (case m
      ((1) (set! object glutSolidIcosahedron))
      ((2) (set! object glutSolidOctahedron))
      ((3) (set! object glutSolidTetrahedron))
      ((4) (set! object show-dodecahedron))
      ((5) (set! object show-sphere))
      ((6) (set! object show-cone))
      ((7) (set! object show-cube))
      ((8) (set! object show-torus))
      ((9) (glShadeModel GL_SMOOTH))
      ((10) (glShadeModel GL_FLAT))
      ((11) (exit)))))

(define reshape-func
  (lambda (w h)
    (format #t "reshape-func callback ~s ~s ~%" w h)
    (and (> w 0)
         (> h 0)
         (begin
           (glViewport 0 0 w h)
           (glMatrixMode GL_PROJECTION)
           (glLoadIdentity)
           (if (<= w h)
               (glOrtho 0.0 16.0 0.0 (/ (* 16.0 h) w) -10.0 10.0)
               (glOrtho 0.0 (/ (* 16.0 w) h) 0.0 16.0 -10.0 10.0))
           (glMatrixMode GL_MODELVIEW)))))

(define visibility-func
  (lambda (state)
    (format #t "visibility-func callback ~s ~%" state)))

(define f32vector
  (lambda lst
    (define-syntax f32set!
      (syntax-rules ()
        ((_ bv n value)
         (bytevector-ieee-single-native-set! bv (* n 4) value))))
    (let ((bv (make-bytevector (* (length lst) 4))))
      (let loop ((i 0) (lst lst))
        (cond ((null? lst) bv)
              (else
               (f32set! bv i (car lst))
               (loop (+ i 1) (cdr lst))))))))

(define render-one
  (lambda (x y ambr ambg ambb difr difg difb specr specg specb shine)
    (glPushMatrix)
    (glTranslatef x y 0.0)
    (cond ((eq? object show-sphere)
           (glRotatef 90.0 0.0 1.0 0.0)
           (glRotatef current-angle 0.0 0.0 1.0))
          (else
           (glRotatef current-angle -0.3 1.0 -0.5)))
    (glMaterialfv GL_FRONT GL_AMBIENT (f32vector ambr ambg ambb 1.0))
    (glMaterialfv GL_FRONT GL_DIFFUSE (f32vector difr difg difb 1.0))
    (glMaterialfv GL_FRONT GL_SPECULAR (f32vector specr specg specb 1.0))
    (glMaterialf GL_FRONT GL_SHININESS (* shine 128.0))
    (object)
    (glPopMatrix)))

#;(import (trace))
#;(trace render-one)
#;(collect-notify #t)

(define run
  (lambda ()
    (glutInitDisplayMode (+ GLUT_DOUBLE GLUT_RGBA GLUT_DEPTH))
    (glutInitWindowPosition 100 100)
    (glutInitWindowSize 500 500)
    (glutInit (vector (length (command-line))) (apply vector (command-line)))
    (glutCreateWindow "Hello GLUT")
    (glLightfv GL_LIGHT0 GL_AMBIENT (f32vector 0.0 0.0 0.0 1.0))
    (glLightfv GL_LIGHT0 GL_DIFFUSE (f32vector 1.0 1.0 1.0 1.0))
    (glLightfv GL_LIGHT0 GL_POSITION (f32vector 0.0 3.0 3.0 0.0))
    (glLightModelfv GL_LIGHT_MODEL_AMBIENT (f32vector 0.2 0.2 0.2 1.0))
    (glLightModelfv GL_LIGHT_MODEL_LOCAL_VIEWER (f32vector 0.0))
    (glShadeModel GL_FLAT)
    (glFrontFace GL_CW)
    (glEnable GL_LIGHTING)
    (glEnable GL_LIGHT0)
    (glEnable GL_AUTO_NORMAL)
    (glEnable GL_NORMALIZE)
    (glEnable GL_DEPTH_TEST)
    (glDepthFunc GL_LESS)
    (glutDisplayFunc display-func)
    (glutReshapeFunc reshape-func)
    (glutVisibilityFunc visibility-func)
    (glutMouseFunc mouse-func)
    (glutIdleFunc rotate-func)
    (glutCreateMenu menu)
    (glutAddMenuEntry "Icosahedron" 1)
    (glutAddMenuEntry "Octahedron" 2)
    (glutAddMenuEntry "Tetrahedron" 3)
    (glutAddMenuEntry "Dodecahedron" 4)
    (glutAddMenuEntry "Sphere" 5)
    (glutAddMenuEntry "Cone" 6)
    (glutAddMenuEntry "Cube" 7)
    (glutAddMenuEntry "Torus" 8)
    (glutAddMenuEntry "[smooth]" 9)
    (glutAddMenuEntry "[flat]" 10)
    (glutAddMenuEntry "Exit" 11)
    (glutAttachMenu GLUT_RIGHT_BUTTON)
    (glutMainLoop)))

(run)
