src/views.scm

   1 ;;; Gacela, a GNU Guile extension for fast games development
   2 ;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
   3 ;;;
   4 ;;; This program is free software: you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation, either version 3 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License
  15 ;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16
  17
  18 (define-module (gacela views)
  19   #:use-module (gacela gacela)
  20   #:use-module ((gacela video) #:renamer (symbol-prefix-proc 'video:))
  21   #:use-module ((gacela gl) #:select (glPushMatrix glPopMatrix))
  22   #:use-module (ice-9 optargs))
  23
  24
  25 ;;; Views
  26
  27 (define view-type
  28   (make-record-type "view"
  29                     '(id constructor body meshes priority)
  30                     (lambda (record port)
  31                       (format port "#<view: ~a meshes>"
  32                               (length (view-meshes record))))))
  33
  34 (define (build-view constructor) ((record-constructor view-type) (gensym) constructor #f '() 0))
  35 (define view? (record-predicate view-type))
  36 (define view-id (record-accessor view-type 'id))
  37 (define view-constructor (record-accessor view-type 'constructor))
  38 (define view-body (record-accessor view-type 'body))
  39 (define view-body-set! (record-modifier view-type 'body))
  40 (define view-meshes (record-accessor view-type 'meshes))
  41 (define view-meshes-set! (record-modifier view-type 'meshes))
  42 (define view-priority (record-accessor view-type 'priority))
  43
  44 (define-macro (make-view body)
  45   `(build-view (lambda () ,body)))
  46
  47 (define activated-views '())
  48
  49 (define (sort-views views-alist)
  50   (sort views-alist
  51         (lambda (v1 v2)
  52           (< (view-priority (cdr v1)) (view-priority (cdr v2))))))
  53
  54 (define (reset-view! view)
  55   (view-body-set! view ((view-constructor view)))
  56   (view-meshes-set! view '())
  57   (view-priority-set! view 0))
  58
  59 (define (activate-view view)
  60   (reset-view! view)
  61   (set! activated-views
  62         (sort-views (assoc-set! activated-views (view-id view) view)))
  63   view)
  64
  65 (define (view-actived? view)
  66   (and (assoc (view-id view) activated-views) #t))
  67
  68 (define (view-priority-set! view priority)
  69   ((record-modifier view-type 'priority) view priority)
  70   (if (view-actived? view)
  71       (set! activated-views (sort-views activated-views))))
  72
  73 (define current-view #f)
  74
  75 (define* (run-views #:optional (views activated-views))
  76   (cond ((not (null? views))
  77          (set! current-view (cdar views))
  78          ((view-body current-view))
  79          (draw-meshes (view-meshes current-view))
  80          (run-views (cdr views)))))
  81
  82 (define (draw-meshes meshes)
  83   (cond ((not (null? meshes))
  84          (catch #t
  85                   (lambda () (mesh-draw (cdar meshes)))
  86                   (lambda (key . args) #f))
  87          (draw-meshes (cdr meshes)))))
  88
  89
  90 (define default-view (activate-view (make-view (lambda () #f))))
  91
  92
  93 ;;; Meshes
  94
  95 (define mesh-type
  96   (make-record-type "mesh"
  97                     '(draw translate turn rotate inner-properties inner-property properties properties-set! property property-set!)
  98                     (lambda (record port)
  99                       (format port "#<mesh: ~a" (mesh-inner-property record 'type))
 100                       (for-each (lambda (x)
 101                                   (cond (((@ (gacela utils) bound?) (cdr x))
 102                                          (format port " ~a" x))))
 103                                 (mesh-properties record))
 104                       (display ">" port))))
 105
 106
 107 (define mesh? (record-predicate mesh-type))
 108
 109 (define* (make-mesh proc #:optional type)
 110   (apply
 111    (record-constructor mesh-type)
 112    (let ((px 0) (py 0) (pz 0)
 113          (ax 0) (ay 0) (az 0)
 114          (rx 0) (ry 0) (rz 0)
 115          (id (gensym))
 116          (properties '()))
 117      (let ((inner-properties
 118             (lambda ()
 119               `((id . ,id) (type . ,type) (x . ,px) (y . ,py) (z . ,pz) (ax . ,ax) (ay . ,ay) (az . ,az) (rx . ,rx) (ry . ,ry) (rz . ,rz)))))
 120        (list
 121         (lambda ()
 122           "draw"
 123           (video:glmatrix-block
 124            (video:rotate ax ay az)
 125            (video:translate px py pz)
 126            (video:rotate rx ry rz)
 127            (proc properties)))
 128         (lambda (x y z)
 129           "translate"
 130           (set! px (+ px x))
 131           (set! py (+ py y))
 132           (set! pz (+ pz z)))
 133         (lambda (x y z)
 134           "turn"
 135           (set! ax (+ ax x))
 136           (set! ay (+ ay y))
 137           (set! az (+ az z)))
 138         (lambda (x y z)
 139           "rotate"
 140           (set! rx (+ rx x))
 141           (set! ry (+ ry y))
 142           (set! rz (+ rz z)))
 143         (lambda ()
 144           "inner-properties"
 145           (inner-properties))
 146         (lambda (prop-name)
 147           "inner-property"
 148           (assoc-ref (inner-properties) prop-name))
 149         (lambda ()
 150           "properties"
 151           properties)
 152         (lambda (new-properties)
 153           "properties-set!"
 154           (set! properties new-properties))
 155         (lambda (prop-name)
 156           "property"
 157           (assoc-ref properties prop-name))
 158         (lambda (prop-name value)
 159           "property-set!"
 160           (set! properties (assoc-set! properties prop-name value))))))))
 161
 162 (define (mesh-draw mesh)
 163   (((record-accessor mesh-type 'draw) mesh)))
 164
 165 (define (mesh-inner-properties mesh)
 166   (((record-accessor mesh-type 'inner-properties) mesh)))
 167
 168 (define (mesh-inner-property mesh prop-name)
 169   (((record-accessor mesh-type 'inner-property) mesh) prop-name))
 170
 171 (define (mesh-properties mesh)
 172   (((record-accessor mesh-type 'properties) mesh)))
 173
 174 (define (mesh-properties-set! mesh new-properties)
 175   (((record-accessor mesh-type 'properties-set!) mesh) new-properties))
 176
 177 (define (mesh-property mesh prop-name)
 178   (((record-accessor mesh-type 'property) mesh) prop-name))
 179
 180 (define (mesh-property-set! mesh prop-name value)
 181   (((record-accessor mesh-type 'property-set!) mesh) prop-name value))
 182
 183 (define* (show mesh #:optional (view current-view))
 184   (let ((id (mesh-inner-property mesh 'id))
 185         (table (view-meshes view)))
 186     (if (not (assoc-ref table id))
 187         (view-meshes-set! view (assoc-set! table id mesh))))
 188   mesh)
 189
 190 (define* (hide mesh #:optional (view current-view))
 191   (let ((id (mesh-inner-property mesh 'id))
 192         (table (view-meshes view)))
 193     (if (assoc-ref table id)
 194         (view-meshes-set! view (assoc-remove! table id))))
 195   mesh)
 196
 197 (define* (translate mesh x y #:optional (z 0))
 198   (((record-accessor mesh-type 'translate) mesh) x y z)
 199   mesh)
 200
 201 (define (turn mesh . params)
 202   (apply ((record-accessor mesh-type 'turn) mesh)
 203          (if (>= (length params) 3)
 204              params
 205              (list 0 0 (car params))))
 206   mesh)
 207
 208 (define (rotate mesh . params)
 209   (apply ((record-accessor mesh-type 'rotate) mesh)
 210          (if (>= (length params) 3)
 211              params
 212              (list 0 0 (car params))))
 213   mesh)
 214
 215
 216 ;;; Primitives
 217
 218 (defmacro* define-primitive (proc #:optional type)
 219   `(lambda (. params)
 220      (let ((m (make-mesh (lambda (props) (apply ,proc ((@ (gacela utils) arguments-apply) ,proc props))) ,type)))
 221        (mesh-properties-set! m ((@ (gacela utils) arguments-calling) ,proc params))
 222        m)))
 223
 224 (define-macro (define-primitives . symbols)
 225   (cond ((null? symbols)
 226          `#t)
 227         (else
 228          (let ((origin (caar symbols))
 229                (dest (cadar symbols)))
 230            `(begin
 231               (define ,origin (define-primitive ,dest ',origin))
 232               (define-primitives ,@(cdr symbols)))))))
 233
 234 (define-primitives
 235   (rectangle video:draw-rectangle)
 236   (square video:draw-square))
 237
 238
 239 ;;; Adding extensions to the main loop
 240 (add-extension! run-views 10)
 241
 242
 243 (module-map (lambda (sym var)
 244               (if (not (eq? sym '%module-public-interface))
 245                   (module-export! (current-module) (list sym))))
 246             (current-module))