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