src/engine.scm

   1 ;;; Gacela, a GNU Guile extension for fast games development
   2 ;;; Copyright (C) 2013 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 engine)
  19   #:use-module (gacela system)
  20   #:use-module (ice-9 receive)
  21   #:use-module (ice-9 threads)
  22   #:use-module (srfi srfi-9)
  23   #:use-module (srfi srfi-9 gnu))
  24
  25
  26 ;;; Engine definitions
  27
  28 (define-record-type engine
  29   (make-engine-record entities mutex system)
  30   engine?
  31   (entities engine-entities set-engine-entities!)
  32   (mutex engine-mutex set-engine-mutex!)
  33   (system engine-system set-engine-system!))
  34
  35 (set-record-type-printer! engine
  36   (lambda (record port)
  37     (format port "#<[engine] entities: ~a>"
  38             (length (car (engine-entities record))))))
  39
  40 (define (make-engine . systems)
  41   (make-engine-record
  42    '(() ())
  43    (make-mutex)
  44    (if (not (= (length systems) 1))
  45        (join-systems systems)
  46        (car systems))))
  47
  48 (define-syntax define-engine
  49   (syntax-rules ()
  50     ((_ name system ...)
  51      (define name
  52        (make-engine system ...)))))
  53
  54 (export make-engine
  55         define-engine)
  56
  57
  58 ;;; Engine Access Protocol Interface
  59
  60 (define current-engine-mutex (make-mutex))
  61 (define current-engine-list '())
  62
  63 (define (current-engine)
  64   (with-mutex current-engine-mutex
  65     (assoc-ref current-engine-list (current-thread))))
  66
  67 (define (set-current-engine! engine)
  68   (with-mutex current-engine-mutex
  69     (set! current-engine-list
  70           (cond (engine
  71                  (assoc-set! current-engine-list (current-thread) engine))
  72                 (else
  73                  (assoc-remove! current-engine-list (current-thread)))))))
  74
  75 (define* (get-entity key #:key (engine (current-engine)))
  76   (assoc key (car (engine-entities engine))))
  77
  78 (define-syntax define-entity-setter
  79   (syntax-rules ()
  80     ((_ name! name)
  81      (define (name! . args)
  82        (let ((f (apply name args))
  83              (engine (current-engine)))
  84          (receive (e c r) (f (car (engine-entities engine)) (cadr (engine-entities engine)))
  85            (set-engine-entities! engine (list e c))
  86            r))))))
  87
  88 (define-entity-setter new-entity! new-entity)
  89 (define-entity-setter remove-entity! remove-entity)
  90 (define-entity-setter set-entity! set-entity)
  91 (define-entity-setter set-entity-components! set-entity-components)
  92 (define-entity-setter remove-entity-components! remove-entity-components)
  93
  94 (define-syntax with-engine
  95   (syntax-rules ()
  96     ((_ engine body ...)
  97      (begin
  98        (set-current-engine! engine)
  99        (let ((res (begin body ...)))
 100          (set-current-engine! #f)
 101          res)))))
 102
 103 (export current-engine
 104         set-current-engine!
 105         get-entity
 106         new-entity!
 107         remove-entity!
 108         set-entity!
 109         set-entity-components!
 110         remove-entity-components!
 111         with-engine)