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 (define mesh? (record-predicate mesh-type))
 121
 122 (define* (make-mesh proc #:optional type)
 123   (apply
 124    (record-constructor mesh-type)
 125    (let ((px 0) (py 0) (pz 0)
 126          (ax 0) (ay 0) (az 0)
 127          (rx 0) (ry 0) (rz 0)
 128          (id (gensym))
 129          (properties '()))
 130      (let ((inner-properties
 131             (lambda ()
 132               `((id . ,id) (type . ,type) (x . ,px) (y . ,py) (z . ,pz) (ax . ,ax) (ay . ,ay) (az . ,az) (rx . ,rx) (ry . ,ry) (rz . ,rz)))))
 133        (list
 134         (lambda ()
 135           "draw"
 136           (video:glmatrix-block
 137            (video:rotate ax ay az)
 138            (video:translate px py pz)
 139            (video:rotate rx ry rz)
 140            (proc properties)))
 141         (lambda (x y z)
 142           "translate"
 143           (set! px (+ px x))
 144           (set! py (+ py y))
 145           (set! pz (+ pz z)))
 146         (lambda (x y z)
 147           "turn"
 148           (set! ax (+ ax x))
 149           (set! ay (+ ay y))
 150           (set! az (+ az z)))
 151         (lambda (x y z)
 152           "rotate"
 153           (set! rx (+ rx x))
 154           (set! ry (+ ry y))
 155           (set! rz (+ rz z)))
 156         (lambda ()
 157           "inner-properties"
 158           (inner-properties))
 159         (lambda (prop-name)
 160           "inner-property"
 161           (assoc-ref (inner-properties) prop-name))
 162         (lambda ()
 163           "properties"
 164           properties)
 165         (lambda (new-properties)
 166           "properties-set!"
 167           (set! properties new-properties))
 168         (lambda (prop-name)
 169           "property"
 170           (assoc-ref properties prop-name))
 171         (lambda (prop-name value)
 172           "property-set!"
 173           (set! properties (assoc-set! properties prop-name value))))))))
 174
 175 (define (mesh-draw mesh)
 176   (((record-accessor mesh-type 'draw) mesh)))
 177
 178 (define (mesh-inner-properties mesh)
 179   (((record-accessor mesh-type 'inner-properties) mesh)))
 180
 181 (define (mesh-inner-property mesh prop-name)
 182   (((record-accessor mesh-type 'inner-property) mesh) prop-name))
 183
 184 (define (mesh-properties mesh)
 185   (((record-accessor mesh-type 'properties) mesh)))
 186
 187 (define (mesh-properties-set! mesh new-properties)
 188   (((record-accessor mesh-type 'properties-set!) mesh) new-properties))
 189
 190 (define (mesh-property mesh prop-name)
 191   (((record-accessor mesh-type 'property) mesh) prop-name))
 192
 193 (define (mesh-property-set! mesh prop-name value)
 194   (((record-accessor mesh-type 'property-set!) mesh) prop-name value))
 195
 196 (define* (show mesh #:optional (view current-view))
 197   (let ((id (mesh-inner-property mesh 'id))
 198         (table (view-meshes view)))
 199     (if (not (assoc-ref table id))
 200         (view-meshes-set! view (assoc-set! table id mesh))))
 201   mesh)
 202
 203 (define* (hide mesh #:optional (view current-view))
 204   (let ((id (mesh-inner-property mesh 'id))
 205         (table (view-meshes view)))
 206     (if (assoc-ref table id)
 207         (view-meshes-set! view (assoc-remove! table id))))
 208   mesh)
 209
 210 (define* (translate mesh x y #:optional (z 0))
 211   (((record-accessor mesh-type 'translate) mesh) x y z)
 212   mesh)
 213
 214 (define (turn mesh . params)
 215   (apply ((record-accessor mesh-type 'turn) mesh)
 216          (if (>= (length params) 3)
 217              params
 218              (list 0 0 (car params))))
 219   mesh)
 220
 221 (define (rotate mesh . params)
 222   (apply ((record-accessor mesh-type 'rotate) mesh)
 223          (if (>= (length params) 3)
 224              params
 225              (list 0 0 (car params))))
 226   mesh)
 227
 228
 229 ;;; Primitives
 230
 231 (defmacro* define-primitive (proc #:optional type)
 232   `(lambda (. params)
 233      (let ((m (make-mesh (lambda (props) (apply ,proc ((@ (gacela utils) arguments-apply) ,proc props))) ,type)))
 234        (mesh-properties-set! m ((@ (gacela utils) arguments-calling) ,proc params))
 235        m)))
 236
 237 (define-macro (define-primitives . symbols)
 238   (cond ((null? symbols)
 239          `#t)
 240         (else
 241          (let ((origin (caar symbols))
 242                (dest (cadar symbols)))
 243            `(begin
 244               (define ,origin (define-primitive ,dest ',origin))
 245               (define-primitives ,@(cdr symbols)))))))
 246
 247 (define-primitives
 248   (rectangle video:draw-rectangle)
 249   (square video:draw-square))
 250
 251
 252 ;;; Adding extensions to the main loop
 253 (add-extension! run-views 10)
 254
 255
 256 (module-map (lambda (sym var)
 257               (if (not (eq? sym '%module-public-interface))
 258                   (module-export! (current-module) (list sym))))
 259             (current-module))