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 (default-delay) 0.1)
  29
  30 (define-component engine-inner-properties
  31   delay)
  32
  33 (define-record-type engine
  34   (make-engine-record entities mutex running-mutex system)
  35   engine?
  36   (entities engine-entities set-engine-entities!)
  37   (mutex engine-mutex set-engine-mutex!)
  38   (running-mutex engine-running-mutex set-engine-running-mutex!)
  39   (system engine-system set-engine-system!))
  40
  41 (set-record-type-printer! engine
  42   (lambda (record port)
  43     (format port "#<[engine] state: ~a, entities: ~a>"
  44             (if (engine-running? record) "Running" "Stopped")
  45             (length (car (engine-entities record))))))
  46
  47 (define (make-engine . systems)
  48   (make-engine-record
  49    (receive (e c) ((new-entity (make-engine-inner-properties (default-delay))) '() '())
  50      (list e c))
  51    (make-mutex)
  52    (make-mutex)
  53    (apply group-systems systems)))
  54
  55 (define-syntax define-engine
  56   (syntax-rules ()
  57     ((_ name system ...)
  58      (define name
  59        (make-engine system ...)))))
  60
  61 (define (engine-running? engine)
  62   (mutex-locked? (engine-running-mutex engine)))
  63
  64 (export make-engine
  65         define-engine
  66         engine-running?)
  67
  68 (export-component engine-inner-properties)
  69
  70
  71 ;;; Engine Access Protocol Interface
  72
  73 (define current-engine-mutex (make-mutex))
  74 (define current-engine-list '())
  75
  76 (define (current-engine)
  77   (with-mutex current-engine-mutex
  78     (assoc-ref current-engine-list (current-thread))))
  79
  80 (define (set-current-engine! engine)
  81   (with-mutex current-engine-mutex
  82     (set! current-engine-list
  83           (cond (engine
  84                  (assoc-set! current-engine-list (current-thread) engine))
  85                 (else
  86                  (assoc-remove! current-engine-list (current-thread)))))))
  87
  88 (define* (get-entity key #:key (engine (current-engine)))
  89   (assoc key (car (engine-entities engine))))
  90
  91 (define* (get-entities-by-components component-types #:key (engine (current-engine)))
  92   (map (lambda (e)
  93          (get-entity e #:engine engine))
  94        (find-entities-by-components (cadr (engine-entities engine)) component-types)))
  95
  96 (define-syntax define-entity-setter
  97   (syntax-rules ()
  98     ((_ name! name)
  99      (define (name! . args)
 100        (let ((f (apply name args))
 101              (engine (current-engine)))
 102          (receive (e c r) (f (car (engine-entities engine)) (cadr (engine-entities engine)))
 103            (set-engine-entities! engine (list e c))
 104            r))))))
 105
 106 (define-entity-setter new-entity! new-entity)
 107 (define-entity-setter remove-entity! remove-entity)
 108 (define-entity-setter set-entity! set-entity)
 109 (define-entity-setter set-entity-components! set-entity-components)
 110 (define-entity-setter remove-entity-components! remove-entity-components)
 111
 112 (define-syntax with-engine
 113   (syntax-rules ()
 114     ((_ engine body ...)
 115      (let ((old-engine (current-engine)))
 116        (set-current-engine! engine)
 117        (let ((res (with-mutex (engine-mutex engine)
 118                     body
 119                     ...)))
 120          (set-current-engine! old-engine)
 121          res)))))
 122
 123 (define (set-engine-systems! engine . systems)
 124   (with-mutex (engine-mutex engine)
 125     (set-engine-system! engine (apply group-systems systems))))
 126
 127 (export current-engine
 128         set-current-engine!
 129         get-entity
 130         get-entities-by-components
 131         new-entity!
 132         remove-entity!
 133         set-entity!
 134         set-entity-components!
 135         remove-entity-components!
 136         with-engine
 137         set-engine-systems!)
 138
 139
 140 ;;; Engine execution
 141
 142 (define (start-engine engine)
 143   (cond ((not (engine-running? engine))
 144          (with-mutex (engine-running-mutex engine)
 145            (let loop ()
 146              (let ((delay 0))
 147                (with-engine engine
 148                  (receive (e c) ((apply (engine-system engine) (engine-entities engine)))
 149                    (set-engine-entities! engine (list e c)))
 150                  (set! delay (engine-inner-properties-delay (get-component 'engine-inner-properties (car (get-entities-by-components '(engine-inner-properties)))))))
 151                (usleep (inexact->exact (* delay 1000000))))
 152              (if (not (engine-stopping? engine #:clean #t))
 153                  (loop)))))))
 154
 155 (define (stop-engine engine)
 156   (with-engine engine
 157     (new-entity! '(engine-halt . #t)))
 158   'engine-halt)
 159
 160 (define* (engine-stopping? engine #:key (clean #f))
 161   (let ((halt #f))
 162     (with-engine engine
 163       (let halt-engine ((halts (get-entities-by-components '(engine-halt))))
 164         (cond ((not (null? halts))
 165                (set! halt #t)
 166                (cond (clean
 167                       (remove-entity! (caar halts))
 168                       (halt-engine (cdr halts))))))))
 169     halt))
 170
 171 (export start-engine
 172         stop-engine
 173         engine-stopping?)