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