src/interfaces/opengl.scm

   1 ;;; Guile-OpenGL
   2 ;;; Copyright (C) 2014 Free Software Foundation, Inc.
   3 ;;;
   4 ;;; Guile-OpenGL is free software: you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU Lesser General Public License as
   6 ;;; published by the Free Software Foundation, either version 3 of the
   7 ;;; License, or (at your option) any later version.
   8 ;;;
   9 ;;; Guile-OpenGL is distributed in the hope that it will be useful, but
  10 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;; Lesser General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU Lesser General Public
  15 ;;; License along with this program.  If not, see
  16 ;;; <http://www.gnu.org/licenses/>.
  17
  18 (define-module (gacela interfaces opengl)
  19   #:use-module (glut)
  20   #:use-module (gl)
  21   #:use-module (glu)
  22   #:use-module (glu low-level)
  23   #:use-module (gl contrib packed-struct)
  24   #:use-module (srfi srfi-9)
  25   #:use-module (srfi srfi-9 gnu)
  26   #:export (for-each-event
  27             draw-quad
  28             draw-line
  29             make-game
  30             start-game
  31             translate-camera
  32             rotate-camera
  33             full-screen))
  34
  35
  36 ;;; Events
  37
  38 (define *input-events* '())
  39
  40 (define (clean-input-events)
  41   (set! *input-events* '()))
  42
  43 (define (add-input-event event)
  44   (set! *input-events*
  45     (cons event *input-events*)))
  46
  47 (define (on-keyboard keycode x y)
  48   (add-input-event (list 'keyboard keycode x y)))
  49
  50 (define (on-special keycode x y)
  51   (add-input-event (list 'special keycode x y)))
  52
  53 (define (on-mouse button state x y)
  54     (add-input-event (list 'mouse button state x y)))
  55
  56 (define (on-motion x y)
  57     (add-input-event (list 'motion x y)))
  58
  59 (define (on-visibility visible?)
  60     (add-input-event (list 'visible visible?)))
  61
  62 (define* (for-each-event proc)
  63   (let loop ((events *input-events*))
  64     (cond ((not (null? events))
  65            (proc (car events))
  66            (loop (cdr events))))))
  67
  68
  69 ;;; Display
  70
  71 (define-packed-struct color-vertex
  72   (x float)
  73   (y float)
  74   (z float)
  75
  76   (r float)
  77   (g float)
  78   (b float))
  79
  80 (define *vertices-list* '())
  81 (define *lines-list* '())
  82
  83 (define (on-reshape width height)
  84   (pk 'reshape! width height)
  85   (gl-viewport 0 0 width height)
  86
  87   ;; Projection matrix.
  88   (set-gl-matrix-mode (matrix-mode projection))
  89   (gl-load-identity)
  90   (glu-perspective 60 (/ width height) 0.1 1000))
  91
  92 (define (draw-vertices mode array)
  93   (gl-enable-client-state (enable-cap vertex-array))
  94   (gl-enable-client-state (enable-cap color-array))
  95   (set-gl-vertex-array (vertex-pointer-type float)
  96                        array
  97                        #:stride (packed-struct-size color-vertex)
  98                        #:offset (packed-struct-offset color-vertex x))
  99   (set-gl-color-array (color-pointer-type float)
 100                       array
 101                       #:stride (packed-struct-size color-vertex)
 102                       #:offset (packed-struct-offset color-vertex r))
 103   (gl-draw-arrays mode 0
 104                   (packed-array-length array color-vertex))
 105   (gl-disable-client-state (enable-cap color-array))
 106   (gl-disable-client-state (enable-cap vertex-array)))
 107
 108 (define *display-hook* (lambda () #f))
 109
 110 (define (on-display)
 111   (*display-hook*)
 112   (gl-clear (clear-buffer-mask color-buffer depth-buffer))
 113   (draw-vertices (begin-mode quads) (prepare-array *vertices-list*))
 114   (draw-vertices (begin-mode lines) (prepare-array *lines-list*))
 115   (swap-buffers))
 116
 117 (define* (draw-quad pos #:key (color '(1 1 1)) (size 1))
 118   (let* ((x (car pos))
 119          (y (cadr pos))
 120          (z (caddr pos))
 121          (delta (/ size 2.0))
 122          (x- (- x delta))
 123          (y- (- y delta))
 124          (x+ (+ x delta))
 125          (y+ (+ y delta))
 126          (r (car color))
 127          (g (cadr color))
 128          (b (caddr color)))
 129     (set! *vertices-list*
 130       (append
 131        (list
 132         (list x- y- z r g b)
 133         (list x+ y- z r g b)
 134         (list x+ y+ z r g b)
 135         (list x- y+ z r g b))
 136        *vertices-list*))))
 137
 138 (define* (draw-line pos1 pos2 #:key (color '(1 1 1)))
 139   (let* ((x1 (car pos1))
 140          (y1 (cadr pos1))
 141          (z1 (caddr pos1))
 142          (x2 (car pos2))
 143          (y2 (cadr pos2))
 144          (z2 (caddr pos2))
 145          (r (car color))
 146          (g (cadr color))
 147          (b (caddr color)))
 148     (set! *lines-list*
 149       (append
 150        (list
 151         (list x1 y1 z1 r g b)
 152         (list x2 y2 z2 r g b))
 153        *lines-list*))))
 154
 155 (define (add-vertex array base type vertex)
 156   (let ((pos vertex)
 157         (color (cdddr vertex)))
 158     (pack array base type
 159           (car pos) (cadr pos) (caddr pos)
 160           (car color) (cadr color) (caddr color))))
 161
 162 (define (prepare-array vertices)
 163   (let loop ((array (make-packed-array color-vertex (length vertices)))
 164              (base 0)
 165              (vertices vertices))
 166     (cond ((null? vertices)
 167            array)
 168           (else
 169            (let ((vertex (car vertices)))
 170              (add-vertex array base color-vertex vertex))
 171            (loop array (+ base 1) (cdr vertices))))))
 172
 173
 174 ;;; Loop
 175
 176 (define *now* (get-internal-real-time))
 177 (define *loops* 0)
 178 (define *main-loop-hook* (lambda () #f))
 179 (define main-window #f)
 180
 181 (define (on-idle)
 182   (cond ((and (> (get-internal-real-time) *now*) (> 10 *loops*))
 183          (set-gl-matrix-mode (matrix-mode modelview))
 184          (set! *vertices-list* '())
 185          (*main-loop-hook*)
 186          (clean-input-events)
 187          (set! *now* (+ *now* 20))
 188          (set! *loops* (+ *loops* 1)))
 189         (else
 190          (post-redisplay main-window)
 191          (set! *loops* 0))))
 192
 193 (define (full-screen full-screen?)
 194   ((@ (glut) full-screen) main-window full-screen?))
 195
 196
 197 ;;; Game
 198
 199 (define-record-type game
 200   (make-game-record name)
 201   game?
 202   (name get-name set-name!))
 203
 204 (set-record-type-printer! game
 205   (lambda (record port)
 206     (format port "#<[game] ~a>" (get-name record))))
 207
 208 (define (register-glut-callbacks)
 209   ;; The trampolines allow the handlers to be overridden at runtime by
 210   ;; an attached Guile REPL client.
 211   (set-display-callback (lambda () (on-display)))
 212   (set-reshape-callback (lambda (w h) (on-reshape w h)))
 213   (set-keyboard-callback (lambda (k x y) (on-keyboard k x y)))
 214   (set-special-callback (lambda (k x y) (on-special k x y)))
 215   (set-mouse-callback (lambda (b s x y) (on-mouse b s x y)))
 216   (set-motion-callback (lambda (x y) (on-motion x y)))
 217   (set-visibility-callback (lambda (visible?) (on-visibility visible?)))
 218   (set-idle-callback (lambda () (on-idle))))
 219
 220 (define* (make-game name
 221                     #:key
 222                     (window-size '(50 . 50))
 223                     (display-mode (display-mode rgba alpha double depth))
 224                     (bg-color '(0 0 0 1))
 225                     (depth 1)
 226                     (shading-model (shading-model smooth))
 227                     (main-loop-hook (lambda () #f))
 228                     (display-hook (lambda () #f)))
 229
 230   (initialize-glut #:window-size window-size
 231                    #:display-mode display-mode)
 232
 233   (set! main-window (make-window name))
 234   (register-glut-callbacks)
 235   (apply set-gl-clear-color bg-color)
 236   (set-gl-clear-depth depth)
 237   (set-gl-shade-model shading-model)
 238
 239   (set-gl-matrix-mode (matrix-mode modelview))
 240   (gl-load-identity)
 241
 242   (gl-enable (enable-cap depth-test))
 243
 244   (set! *main-loop-hook* main-loop-hook)
 245   (set! *display-hook* display-hook)
 246
 247   (make-game-record name))
 248
 249 (define (start-game game)
 250   (glut-main-loop))
 251
 252
 253 ;;; Camera
 254
 255 (define (translate-camera x y z)
 256   (gl-translate x y z))
 257
 258 (define (rotate-camera angle x y z)
 259   (gl-rotate angle x y z))