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 misc)
  20   #:use-module (gacela system)
  21   #:use-module (ice-9 receive)
  22   #:use-module (ice-9 threads)
  23   #:use-module (srfi srfi-9)
  24   #:use-module (srfi srfi-9 gnu)
  25   #:use-module (system repl server)
  26   #:use-module (system repl coop-server))
  27
  28
  29 ;;; Engine Inner Properties
  30
  31 (define (default-step) 0.1)
  32
  33 (define (default-engine-inner-properties)
  34   `(engine-inner-properties (step . ,(default-step))))
  35
  36
  37 ;;; Engine definitions
  38
  39 (define-record-type engine
  40   (make-engine-record entities mutex running-mutex systems)
  41   engine?
  42   (entities engine-entities set-engine-entities!)
  43   (running-mutex engine-running-mutex set-engine-running-mutex!)
  44   (systems engine-systems set-engine-systems!))
  45
  46 (set-record-type-printer! engine
  47   (lambda (record port)
  48     (format port "#<[engine] state: ~a, entities: ~a>"
  49             (if (engine-running? record) "Running" "Stopped")
  50             (entity-count (engine-entities record)))))
  51
  52 (define (make-engine . systems)
  53   (make-engine-record
  54    (make-entity-set (new-entity (default-engine-inner-properties)))
  55    (make-mutex)
  56    systems))
  57
  58 (define-syntax define-engine
  59   (syntax-rules ()
  60     ((_ name system ...)
  61      (define name
  62        (make-engine system ...)))))
  63
  64 (define (engine-running? engine)
  65   (mutex-locked? (engine-running-mutex engine)))
  66
  67 (export make-engine
  68         define-engine
  69         engine-running?)
  70
  71
  72 ;;; Engine execution
  73
  74 (define* (start-engine engine #:optional (socket #f))
  75   (catch
  76    #t
  77    (lambda ()
  78      (with-mutex (engine-running-mutex engine)
  79        (let loop ((coop-server (if socket (spawn-coop-repl-server socket) #f)))
  80          (let ((t (current-utime))
  81                (delay 0)
  82                (halt #f))
  83            (for-each
  84             (lambda (s) (eval-system s engine))
  85             (engine-systems engine))
  86            (set! delay (- (inexact->exact (* (engine-property engine 'step) 1000000))
  87                           (- (current-utime) t)))
  88            (set! halt (engine-stopping? engine #:clean #t))
  89            (if coop-server
  90                (poll-coop-repl-server coop-server))
  91            (cond ((not halt)
  92                   (cond ((> delay 0)
  93                          (usleep delay)))
  94                   (loop coop-server))
  95                  (else
  96                   (if coop-server
  97                       (stop-server-and-clients!))))))))
  98    (lambda (key args)
  99      #f)))
 100
 101 (define (eval-system system engine)
 102   (call-with-values
 103       (lambda () (system (engine-entities engine)))
 104     (lambda vals
 105       (let ((changes (car vals)))
 106         (cond ((entities-changes? changes)
 107                (set-engine-entities! engine
 108                  (modify-entities (engine-entities engine)
 109                                   (get-entities-changes changes))))))
 110       (apply values vals))))
 111
 112 (define-syntax with-engine
 113   (syntax-rules ()
 114     ((_ engine component-types form ...)
 115      (with-mutex (engine-mutex engine)
 116        (eval-system (make-system component-types form ...) engine)))))
 117
 118 (define (stop-engine engine)
 119   (with-engine engine ()
 120     (entities-changes
 121      (list
 122       (new-entity '(engine-halt . #t)))))
 123   'engine-halt)
 124
 125 (define* (engine-stopping? engine #:key (clean #f))
 126   (let ((halts (eval-system
 127                 (make-system ((halt (engine-halt))) halt)
 128                 engine)))
 129     (cond ((and clean (not (null? halts)))
 130            (eval-system
 131             (make-system () (entities-changes (map (lambda (h) (remove-entity (car h))) halts)))
 132             engine)))
 133     (not (null? halts))))
 134
 135 (export start-engine
 136         with-engine
 137         stop-engine)
 138
 139
 140 ;;; Properties
 141
 142 (define (engine-property engine name)
 143   (eval-system
 144    (make-system ((props (engine-inner-properties)))
 145      (assoc-ref
 146       (assoc-ref (cdar props) 'engine-inner-properties)
 147       name))
 148    engine))
 149
 150 (define (set-engine-property! engine name value)
 151   (eval-system
 152    (make-system ((props (engine-inner-properties)))
 153      (entities-changes
 154       (list
 155        (set-entity (caar props)
 156                    (car
 157                     (assoc-set! (cdar props) 'engine-inner-properties
 158                                 (assoc-set! (assoc-ref (cdar props) 'engine-inner-properties)
 159                                             name
 160                                             value)))))))
 161    engine)
 162   value)
 163
 164 (export engine-property
 165         set-engine-property!)