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 (make-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-meshes (record-accessor view-type 'meshes))
  40 (define view-priority (record-accessor view-type 'priority))
  41
  42 (define-macro (define-view body)
  43   `(make-view (lambda () ,body)))
  44
  45 (define activated-views '())
  46 (define (sort-views views-alist)
  47   (sort views-alist
  48         (lambda (v1 v2)
  49           (< (view-priority (cdr v1)) (view-priority (cdr v2))))))
  50
  51 (define (activate-view view)
  52   (set! activated-views
  53         (sort-views (assoc-set! activated-views (view-id view) view)))
  54   view)
  55
  56 (define (view-actived? view)
  57   (and (assoc (view-id view) activated-views) #t))
  58
  59 (define (view-priority-set! view priority)
  60   ((record-modifier view-type 'priority) view priority)
  61   (set! activated-views (sort-views activated-views)))
  62
  63 (define current-view #f)
  64
  65 (define* (run-views #:optional (views activated-views))
  66   (cond ((not (null? views))
  67          (set! current-view (cdar views))
  68          ; controllers go here
  69          (draw-meshes (view-meshes current-view))
  70          (run-views (cdr views)))))
  71
  72 (define (draw-meshes meshes)
  73   (cond ((not (null? meshes))
  74          (catch #t
  75                   (lambda () (mesh-draw (cdar meshes)))
  76                   (lambda (key . args) #f))
  77          (draw-meshes (cdr meshes)))))
  78
  79
  80 (define default-view (activate-view (define-view '())))
  81
  82
  83 ;;; Meshes
  84
  85 (define mesh-type
  86   (make-record-type "mesh"
  87                     '(draw translate turn rotate inner-properties inner-property properties properties-set! property property-set!)
  88                     (lambda (record port)
  89                       (format port "#<mesh: ~a" (mesh-inner-property record 'type))
  90                       (for-each (lambda (x)
  91                                   (cond (((@ (gacela utils) bound?) (cdr x))
  92                                          (format port " ~a" x))))
  93                                 (mesh-properties record))
  94                       (display ">" port))))
  95
  96
  97 (define mesh? (record-predicate mesh-type))
  98
  99 (define* (make-mesh proc #:optional type)
 100   (apply
 101    (record-constructor mesh-type)
 102    (let ((px 0) (py 0) (pz 0)
 103          (ax 0) (ay 0) (az 0)
 104          (rx 0) (ry 0) (rz 0)
 105          (id (gensym))
 106          (properties '()))
 107      (let ((inner-properties
 108             (lambda ()
 109               `((id . ,id) (type . ,type) (x . ,px) (y . ,py) (z . ,pz) (ax . ,ax) (ay . ,ay) (az . ,az) (rx . ,rx) (ry . ,ry) (rz . ,rz)))))
 110        (list
 111         (lambda ()
 112           "draw"
 113           (video:glmatrix-block
 114            (video:rotate ax ay az)
 115            (video:translate px py pz)
 116            (video:rotate rx ry rz)
 117            (proc properties)))
 118         (lambda (x y z)
 119           "translate"
 120           (set! px (+ px x))
 121           (set! py (+ py y))
 122           (set! pz (+ pz z)))
 123         (lambda (x y z)
 124           "turn"
 125           (set! ax (+ ax x))
 126           (set! ay (+ ay y))
 127           (set! az (+ az z)))
 128         (lambda (x y z)
 129           "rotate"
 130           (set! rx (+ rx x))
 131           (set! ry (+ ry y))
 132           (set! rz (+ rz z)))
 133         (lambda ()
 134           "inner-properties"
 135           (inner-properties))
 136         (lambda (prop-name)
 137           "inner-property"
 138           (assoc-ref (inner-properties) prop-name))
 139         (lambda ()
 140           "properties"
 141           properties)
 142         (lambda (new-properties)
 143           "properties-set!"
 144           (set! properties new-properties))
 145         (lambda (prop-name)
 146           "property"
 147           (assoc-ref properties prop-name))
 148         (lambda (prop-name value)
 149           "property-set!"
 150           (set! properties (assoc-set! properties prop-name value))))))))
 151
 152 (define (mesh-draw mesh)
 153   (((record-accessor mesh-type 'draw) mesh)))
 154
 155 (define (mesh-inner-properties mesh)
 156   (((record-accessor mesh-type 'inner-properties) mesh)))
 157
 158 (define (mesh-inner-property mesh prop-name)
 159   (((record-accessor mesh-type 'inner-property) mesh) prop-name))
 160
 161 (define (mesh-properties mesh)
 162   (((record-accessor mesh-type 'properties) mesh)))
 163
 164 (define (mesh-properties-set! mesh new-properties)
 165   (((record-accessor mesh-type 'properties-set!) mesh) new-properties))
 166
 167 (define (mesh-property mesh prop-name)
 168   (((record-accessor mesh-type 'property) mesh) prop-name))
 169
 170 (define (mesh-property-set! mesh prop-name value)
 171   (((record-accessor mesh-type 'property-set!) mesh) prop-name value))
 172
 173 (define* (show mesh #:optional (view current-view))
 174   (let ((id (mesh-inner-property mesh 'id))
 175         (table (view-meshes view)))
 176     (if (not (hash-ref table id))
 177         (hash-set! table id mesh))))
 178
 179 (define* (hide mesh #:optional (view current-view))
 180   (let ((table (view-meshes view)))
 181     (hash-remove! table (mesh-inner-property mesh 'id))))
 182
 183 (define* (translate mesh x y #:optional (z 0))
 184   (((record-accessor mesh-type 'translate) mesh) x y z)
 185   mesh)
 186
 187 (define (turn mesh . params)
 188   (apply ((record-accessor mesh-type 'turn) mesh)
 189          (if (>= (length params) 3)
 190              params
 191              (list 0 0 (car params))))
 192   mesh)
 193
 194 (define (rotate mesh . params)
 195   (apply ((record-accessor mesh-type 'rotate) mesh)
 196          (if (>= (length params) 3)
 197              params
 198              (list 0 0 (car params))))
 199   mesh)
 200
 201
 202 ;;; Primitives
 203
 204 (defmacro* define-primitive (proc #:optional type)
 205   `(lambda (. params)
 206      (let ((m (make-mesh (lambda (props) (apply ,proc ((@ (gacela utils) arguments-apply) ,proc props))) ,type)))
 207        (mesh-properties-set! m ((@ (gacela utils) arguments-calling) ,proc params))
 208        m)))
 209
 210 (define-macro (define-primitives . symbols)
 211   (cond ((null? symbols)
 212          `#t)
 213         (else
 214          (let ((origin (caar symbols))
 215                (dest (cadar symbols)))
 216            `(begin
 217               (define ,origin (define-primitive ,dest ',origin))
 218               (define-primitives ,@(cdr symbols)))))))
 219
 220 (define-primitives
 221   (rectangle video:draw-rectangle)
 222   (square video:draw-square))
 223
 224
 225 ;;; Adding extensions to the main loop
 226 (add-extension! run-views 10)
 227
 228
 229 (module-map (lambda (sym var)
 230               (if (not (eq? sym '%module-public-interface))
 231                   (module-export! (current-module) (list sym))))
 232             (current-module))