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