gacela/react.scm

   1 ;;; Gacela, a GNU Guile extension for fast games development
   2 ;;; Copyright (C) 2017 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 react)
  19   #:use-module (gacela scene)
  20   #:export (context
  21             at-rate))
  22
  23
  24 ;; Time Stack
  25
  26 (define time-stack '())
  27
  28 (define (push-init-time init-time)
  29   (set! time-stack (cons init-time time-stack)))
  30
  31 (define (pop-init-time)
  32   (set! time-stack (cdr time-stack)))
  33
  34 (define (head-init-time)
  35   (car time-stack))
  36
  37
  38 ;; Reactive context
  39
  40 (define-syntax context
  41   (lambda (x)
  42     (define (transform vars)
  43       (let ((datum (map (lambda (v) (syntax->datum v)) vars)))
  44         (map (lambda (v) (datum->syntax x v))
  45              (map (lambda (v)
  46                     (cond ((and (= (length v) 4) (equal? (caddr v) '<=))
  47                            (list (car v) (cadr v) (cadddr v)))
  48                           ((= (length v) 2)
  49                            (list (car v) (cadr v) 0))
  50                           (else
  51                            v)))
  52                   datum))))
  53     (syntax-case x (<=)
  54       ((_ ((variable value <= init-value)
  55            ...)
  56           scene)
  57        #'(make-scene
  58           "context"
  59           (let* ((variable init-value)
  60                  ...
  61                  (?init-time (get-internal-real-time)))
  62             (lambda ()
  63               (push-init-time ?init-time)
  64               (begin
  65                 (set! variable value)
  66                 ...)
  67               (display-scene scene)
  68               (pop-init-time)))))
  69       ((_ ((variable value value* ...)
  70            ...)
  71           scene)
  72        (with-syntax ((((variable1 value1 init-value1) ...) (transform #'((variable value value* ...) ...))))
  73          #'(context ((variable1 value1 <= init-value1)
  74                      ...)
  75                     scene))))))
  76
  77
  78 ;; Rate based functions
  79
  80 (define (at-rate value)
  81   (let ((delta (- (get-internal-real-time) (head-init-time))))
  82     (* value (/ delta 1000.0))))