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