--- /dev/null
+;;; Guile-OpenGL
+;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;;
+;;; Guile-OpenGL is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; Guile-OpenGL is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (gacela interfaces opengl)
+ #:use-module (glut)
+ #:use-module (gl)
+ #:use-module (glu)
+ #:use-module (glu low-level)
+ #:use-module (gl contrib packed-struct)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:export (for-each-event
+ draw-quad
+ draw-line
+ make-game
+ start-game
+ translate-camera
+ rotate-camera
+ full-screen))
+
+
+;;; Events
+
+(define *input-events* '())
+
+(define (clean-input-events)
+ (set! *input-events* '()))
+
+(define (add-input-event event)
+ (set! *input-events*
+ (cons event *input-events*)))
+
+(define (on-keyboard keycode x y)
+ (add-input-event (list 'keyboard keycode x y)))
+
+(define (on-special keycode x y)
+ (add-input-event (list 'special keycode x y)))
+
+(define (on-mouse button state x y)
+ (add-input-event (list 'mouse button state x y)))
+
+(define (on-motion x y)
+ (add-input-event (list 'motion x y)))
+
+(define (on-visibility visible?)
+ (add-input-event (list 'visible visible?)))
+
+(define* (for-each-event proc)
+ (let loop ((events *input-events*))
+ (cond ((not (null? events))
+ (proc (car events))
+ (loop (cdr events))))))
+
+
+;;; Display
+
+(define-packed-struct color-vertex
+ (x float)
+ (y float)
+ (z float)
+
+ (r float)
+ (g float)
+ (b float))
+
+(define *vertices-list* '())
+(define *lines-list* '())
+
+(define (on-reshape width height)
+ (pk 'reshape! width height)
+ (gl-viewport 0 0 width height)
+
+ ;; Projection matrix.
+ (set-gl-matrix-mode (matrix-mode projection))
+ (gl-load-identity)
+ (glu-perspective 60 (/ width height) 0.1 1000))
+
+(define (draw-vertices mode array)
+ (gl-enable-client-state (enable-cap vertex-array))
+ (gl-enable-client-state (enable-cap color-array))
+ (set-gl-vertex-array (vertex-pointer-type float)
+ array
+ #:stride (packed-struct-size color-vertex)
+ #:offset (packed-struct-offset color-vertex x))
+ (set-gl-color-array (color-pointer-type float)
+ array
+ #:stride (packed-struct-size color-vertex)
+ #:offset (packed-struct-offset color-vertex r))
+ (gl-draw-arrays mode 0
+ (packed-array-length array color-vertex))
+ (gl-disable-client-state (enable-cap color-array))
+ (gl-disable-client-state (enable-cap vertex-array)))
+
+(define *display-hook* (lambda () #f))
+
+(define (on-display)
+ (*display-hook*)
+ (gl-clear (clear-buffer-mask color-buffer depth-buffer))
+ (draw-vertices (begin-mode quads) (prepare-array *vertices-list*))
+ (draw-vertices (begin-mode lines) (prepare-array *lines-list*))
+ (swap-buffers))
+
+(define* (draw-quad pos #:key (color '(1 1 1)) (size 1))
+ (let* ((x (car pos))
+ (y (cadr pos))
+ (z (caddr pos))
+ (delta (/ size 2.0))
+ (x- (- x delta))
+ (y- (- y delta))
+ (x+ (+ x delta))
+ (y+ (+ y delta))
+ (r (car color))
+ (g (cadr color))
+ (b (caddr color)))
+ (set! *vertices-list*
+ (append
+ (list
+ (list x- y- z r g b)
+ (list x+ y- z r g b)
+ (list x+ y+ z r g b)
+ (list x- y+ z r g b))
+ *vertices-list*))))
+
+(define* (draw-line pos1 pos2 #:key (color '(1 1 1)))
+ (let* ((x1 (car pos1))
+ (y1 (cadr pos1))
+ (z1 (caddr pos1))
+ (x2 (car pos2))
+ (y2 (cadr pos2))
+ (z2 (caddr pos2))
+ (r (car color))
+ (g (cadr color))
+ (b (caddr color)))
+ (set! *lines-list*
+ (append
+ (list
+ (list x1 y1 z1 r g b)
+ (list x2 y2 z2 r g b))
+ *lines-list*))))
+
+(define (add-vertex array base type vertex)
+ (let ((pos vertex)
+ (color (cdddr vertex)))
+ (pack array base type
+ (car pos) (cadr pos) (caddr pos)
+ (car color) (cadr color) (caddr color))))
+
+(define (prepare-array vertices)
+ (let loop ((array (make-packed-array color-vertex (length vertices)))
+ (base 0)
+ (vertices vertices))
+ (cond ((null? vertices)
+ array)
+ (else
+ (let ((vertex (car vertices)))
+ (add-vertex array base color-vertex vertex))
+ (loop array (+ base 1) (cdr vertices))))))
+
+
+;;; Loop
+
+(define *now* (get-internal-real-time))
+(define *loops* 0)
+(define *main-loop-hook* (lambda () #f))
+(define main-window #f)
+
+(define (on-idle)
+ (cond ((and (> (get-internal-real-time) *now*) (> 10 *loops*))
+ (set-gl-matrix-mode (matrix-mode modelview))
+ (set! *vertices-list* '())
+ (*main-loop-hook*)
+ (clean-input-events)
+ (set! *now* (+ *now* 20))
+ (set! *loops* (+ *loops* 1)))
+ (else
+ (post-redisplay main-window)
+ (set! *loops* 0))))
+
+(define (full-screen full-screen?)
+ ((@ (glut) full-screen) main-window full-screen?))
+
+
+;;; Game
+
+(define-record-type game
+ (make-game-record name)
+ game?
+ (name get-name set-name!))
+
+(set-record-type-printer! game
+ (lambda (record port)
+ (format port "#<[game] ~a>" (get-name record))))
+
+(define (register-glut-callbacks)
+ ;; The trampolines allow the handlers to be overridden at runtime by
+ ;; an attached Guile REPL client.
+ (set-display-callback (lambda () (on-display)))
+ (set-reshape-callback (lambda (w h) (on-reshape w h)))
+ (set-keyboard-callback (lambda (k x y) (on-keyboard k x y)))
+ (set-special-callback (lambda (k x y) (on-special k x y)))
+ (set-mouse-callback (lambda (b s x y) (on-mouse b s x y)))
+ (set-motion-callback (lambda (x y) (on-motion x y)))
+ (set-visibility-callback (lambda (visible?) (on-visibility visible?)))
+ (set-idle-callback (lambda () (on-idle))))
+
+(define* (make-game name
+ #:key
+ (window-size '(50 . 50))
+ (display-mode (display-mode rgba alpha double depth))
+ (bg-color '(0 0 0 1))
+ (depth 1)
+ (shading-model (shading-model smooth))
+ (main-loop-hook (lambda () #f))
+ (display-hook (lambda () #f)))
+
+ (initialize-glut #:window-size window-size
+ #:display-mode display-mode)
+
+ (set! main-window (make-window name))
+ (register-glut-callbacks)
+ (apply set-gl-clear-color bg-color)
+ (set-gl-clear-depth depth)
+ (set-gl-shade-model shading-model)
+
+ (set-gl-matrix-mode (matrix-mode modelview))
+ (gl-load-identity)
+
+ (gl-enable (enable-cap depth-test))
+
+ (set! *main-loop-hook* main-loop-hook)
+ (set! *display-hook* display-hook)
+
+ (make-game-record name))
+
+(define (start-game game)
+ (glut-main-loop))
+
+
+;;; Camera
+
+(define (translate-camera x y z)
+ (gl-translate x y z))
+
+(define (rotate-camera angle x y z)
+ (gl-rotate angle x y z))
projects / gacela.git / blobdiff