X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=src%2Fgacela.scm;h=3b65aff208d01470b6954ef2166c9096e8b11649;hb=22e3dfd1d4f268023ee5c0351eb25e409520004a;hp=63d6bd3e6992ea3d5703671faf90a699d80c385c;hpb=e2b3664ab965f251fb9ec1e5588510293ef52e61;p=gacela.git

diff --git a/src/gacela.scm b/src/gacela.scm
index 63d6bd3..3b65aff 100644
--- a/src/gacela.scm
+++ b/src/gacela.scm
@@ -1,5 +1,5 @@
 ;;; Gacela, a GNU Guile extension for fast games development
-;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
+;;; Copyright (C) 2013 by Javier Sancho Fernandez <jsf at jsancho dot org>
 ;;;
 ;;; This program is free software: you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -16,336 +16,50 @@
 
 
 (define-module (gacela gacela)
-  #:use-module (gacela events)
-  #:use-module (gacela video)
-  #:use-module (gacela audio)
-  #:use-module (ice-9 optargs)
-  #:export (*title*
-	    *width-screen*
-	    *height-screen*
-	    *bpp-screen*
-	    *frames-per-second*
-	    *mode*
-	    set-game-properties!
-	    get-game-properties
-	    init-gacela
-	    quit-gacela
-	    game-loop
-	    gacela-script
-	    game-running?
-	    set-game-code
-	    show-mob-hash
-	    hide-mob-hash
-	    get-active-mobs
-	    hide-all-mobs
-	    get-current-mob-id
-	    get-mob-function-name
-	    map-mobs
-	    translate-mob)
-  #:export-syntax (game
-		   show-mob
-		   hide-mob
-		   the-mob
-		   define-mob-function
-		   define-mob
-		   lambda-mob
-		   define-checking-mobs)
-  #:re-export (translate
-	       get-frame-time
-	       3d-mode?))
+  #:use-module (gacela system)
+  #:use-module (ice-9 threads)
+  #:use-module (srfi srfi-1)
+  #:export (make-world))
 
 
-;;; Main Loop
+;;; Entities and components
 
-(define loop-flag #f)
-(define game-code #f)
-(define game-loop-thread #f)
+(define (make-world . entities)
+  (apply make-entity-set entities))
 
-(define-macro (run-in-game-loop proc)
-  (let ((pgl (string->symbol (string-concatenate (list (symbol->string proc) "-in-game-loop"))))
-	(flag-symbol (gensym))
-	(value-symbol (gensym)))
-    `(begin
-       (define ,pgl ,proc)
-       (define (,proc . param)
-	 (cond ((and game-loop-thread (not (eq? game-loop-thread (current-thread))))
-		(let ((,flag-symbol #f))
-		  (define ,value-symbol)
-		  (system-async-mark
-		   (lambda ()
-		     (catch #t
-			   (lambda () (set! ,value-symbol (apply ,pgl param)))
-			   (lambda (key . args) #f))
-		     (set! ,flag-symbol #t))
-		   game-loop-thread)
-		  (while (not ,flag-symbol))
-		  ,value-symbol))
-	       (else
-		(apply ,pgl param)))))))
+(define entities-mutex (make-mutex))
+(define game-entities '())
+(define game-components '())
 
-(run-in-game-loop load-texture)
-(run-in-game-loop load-font)
-(run-in-game-loop set-screen-bpp!)
-(run-in-game-loop resize-screen)
 
-(define-macro (game . code)
-  `(let ((game-function ,(if (null? code)
-			     `(lambda () #f)
-			     `(lambda () ,@code))))
-     (set-game-code game-function)
-     (cond ((not (game-running?))
-	    (game-loop)))))
+(define (entity . components)
+  (with-mutex entities-mutex
+   (let ((key (gensym)))
+     (set! game-entities
+	   (acons key
+		  (map (lambda (c) (list (get-component-type c) c)) components)
+		  game-entities))
+     (set! game-components (register-components key components))
+     key)))
 
-(define (init-gacela)
-  (hide-all-mobs)
-  (set-game-code (lambda () #f))
-  (cond ((not game-loop-thread)
-	 (set! game-loop-thread (call-with-new-thread (lambda () (game))))))
-  (while (not loop-flag))
-  #t)
 
-(define (quit-gacela)
-  (hide-all-mobs)
-  (set-game-code (lambda () #f))
-  (set! game-loop-thread #f)
-  (set! loop-flag #f))
-
-(define (game-loop)
-  (refresh-active-mobs)
-  (init-video *width-screen* *height-screen* *bpp-screen* #:title *title* #:mode *mode* #:fps *frames-per-second*)
-  (set! loop-flag #t)
-  (while loop-flag
-	 (init-frame-time)
-;	    (check-connections)
-	 (process-events)
-	 (cond ((quit-signal?)
-		(quit-gacela))
-	       (else
-		(clear-screen)
-		(to-origin)
-		(refresh-active-mobs)
-		(if (procedure? game-code)
-		    (catch #t
-			   (lambda () (game-code))
-			   (lambda (key . args) #f)))
-		(run-mobs)
-		(flip-screen)
-		(delay-frame))))
-  (quit-video))
-
-(define (gacela-script args)
-  (while loop-flag (sleep 1)))
-
-(define (game-running?)
-  loop-flag)
-
-(define (set-game-code game-function)
-  (set! game-code game-function))
-
-
-;;; Game Properties
-
-(define *title* "Gacela")
-(define *width-screen* 640)
-(define *height-screen* 480)
-(define *bpp-screen* 32)
-(define *frames-per-second* 20)
-(define *mode* '2d)
-(define *fullscreen* 'off)
-
-(define* (set-game-properties! #:key title width height bpp fps mode fullscreen)
-  (if title
-      (set-screen-title! title))
-  (if bpp
-      (set-screen-bpp! bpp))
-  (if (or width height)
-      (begin
-	(if (not width) (set! width (get-screen-width)))
-	(if (not height) (set! height (get-screen-height)))
-	(resize-screen width height)))
-  (if fps
-      (set-frames-per-second! fps))
-  (if mode
-      (if (eq? mode '3d) (set-3d-mode) (set-2d-mode)))
-  (if fullscreen
-      (set-fullscreen! fullscreen))
-  (get-game-properties))
-
-(define (get-game-properties)
-  `((title . ,(get-screen-title)) (width . ,(get-screen-width)) (height . ,(get-screen-height)) (bpp . ,(get-screen-bpp)) (fps . ,(get-frames-per-second)) (mode . ,(if (3d-mode?) '3d '2d)) (fullscreen . ,(get-fullscreen))))
-
-
-;;; Mobs Factory
-
-(define mobs-table (make-hash-table))
-(define active-mobs '())
-(define mobs-changed #f)
-
-(define (show-mob-hash mob)
-  (hash-set! mobs-table (mob 'get-mob-id) mob)
-  (set! mobs-changed #t))
-
-(define (hide-mob-hash mob-id)
-  (hash-remove! mobs-table mob-id)
-  (set! mobs-changed #t))
-
-(define (refresh-active-mobs)
-  (cond (mobs-changed
-	 (set! mobs-changed #f)
-	 (set! active-mobs (hash-map->list (lambda (k v) v) mobs-table)))))
-
-(define (get-active-mobs)
-  active-mobs)
-
-(define (hide-all-mobs)
-  (set! mobs-changed #t)
-  (hash-clear! mobs-table))
-
-(define (mobs-changed?)
-  mobs-changed)
-
-
-(define-macro (show-mob mob)
-  (cond ((list? mob)
-	 `(let ((m ,mob))
-	    (show-mob-hash m)))
-	(else
-	 `(show-mob-hash (lambda* (#:optional (option #f)) (,mob option))))))
-
-(define-macro (hide-mob mob)
-  (cond ((list? mob)
-	 `(let ((m ,mob))
-	    (hide-mob-hash (m 'get-mob-id))))
+(define* (register-components entity components #:optional (clist game-components))
+  (cond ((null? components) clist)
 	(else
-	 `(hide-mob-hash (,mob 'get-mob-id)))))
-
-(define current-mob-id #f)
-
-(define translate-mob translate)
-
-(define (get-current-mob-id)
-  current-mob-id)
-
-(define* (run-mobs #:optional (mobs (get-active-mobs)))
-  (let ((sorted-mobs (sort mobs (lambda (m1 m2) (< (m1 'get-z-index) (m2 'get-z-index))))))
-    (for-each
-     (lambda (m)
-       (set! current-mob-id (m 'get-mob-id))
-       (glmatrix-block (m)))
-     sorted-mobs)
-    (set! current-mob-id #f)))
-
-
-;;; Making mobs
-
-(define mob-functions (make-hash-table))
-
-(define (get-mob-function-name mob-name)
-  (let ((name (hash-ref mob-functions mob-name)))
-    (cond ((not name)
-	   (set! name (gensym))
-	   (hash-set! mob-functions mob-name name)))
-    name))
-
-(define-macro (the-mob mob-name init-data)
-  `(let ((mob-id (gensym))
-	 (mob-z-index 0)
-	 (mob-time 0)
-	 (mob-data ,init-data)
-	 (saved-data ,init-data))
-     (lambda* (#:optional (option #f))
-       (define (save-data)
-	 (let ((time (get-frame-time)))
-	   (cond ((not (= time mob-time))
-		  (set! mob-time time)
-		  (set! saved-data mob-data)))))
-       (case option
-	 ((get-mob-id)
-	  mob-id)
-	 ((get-z-index)
-	  mob-z-index)
-	 ((get-type)
-	  (procedure-name ,mob-name))
-	 ((get-data)
-	  (save-data)
-	  saved-data)
-	 (else
-	  (cond ((keyword? option)
-		 (assoc-ref saved-data (keyword->symbol option)))
-		(else
-		 (save-data)
-		 (let ((res (,mob-name mob-id mob-data)))
-		   (set! mob-z-index (car res))
-		   (set! mob-data (cadr res))))))))))
-
-(define-macro (define-mob-function attr . body)
-  (let ((attr (map (lambda (a) (if (list? a) a (list a #f))) attr))
-	(mob-id-symbol (gensym))
-	(mob-id-z-index (gensym))
-	(data-symbol (gensym)))
-    `(lambda (,mob-id-symbol ,data-symbol)
-       (let ((,mob-id-z-index 0))
-	 (define (kill-me)
-	   (hide-mob-hash ,mob-id-symbol))
-	 (define* (translate x y #:optional (z 0))
-	   (cond ((3d-mode?)
-		  (translate-mob x y z))
-		 (else
-		  (set! ,mob-id-z-index (+ ,mob-id-z-index z))
-		  (translate-mob x y))))
-	 (let* ,attr
-	   ,@(map
-	      (lambda (a)
-		`(let ((val (assoc-ref ,data-symbol ',(car a))))
-		   (cond (val (set! ,(car a) val)))))
-	      attr)
-	   (catch #t
-		  (lambda* () ,@body)
-		  (lambda (key . args) #f))
-	   (list ,mob-id-z-index (list ,@(map (lambda (a) `(cons ',(car a) ,(car a))) attr))))))))
-
-(define-macro (define-mob mob-head . body)
-  (let* ((name (car mob-head))
-	 (attr (cdr mob-head))
-	 (make-fun-symbol (gensym))
-	 (mob-fun-symbol (gensym))
-	 (params-symbol (gensym)))
-    `(define (,name . ,params-symbol)
-       (define ,make-fun-symbol
-	 (lambda* ,(if (null? attr) '() `(#:key ,@attr))
-	   (the-mob ,name (list ,@(map (lambda (a) `(cons ',(car a) ,(car a))) attr)))))
-       (define ,mob-fun-symbol
-	 (define-mob-function ,attr ,@body))
-       (cond ((or (null? ,params-symbol) (keyword? (car ,params-symbol)))
-	      (apply ,make-fun-symbol ,params-symbol))
-	     (else
-	      (apply ,mob-fun-symbol ,params-symbol))))))
-
-(define-macro (lambda-mob attr . body)
-  (let ((fun-name (gensym)))
-    `(begin
-       (define-mob-function ,(cons fun-name attr) ,@body)
-       (the-mob 'undefined '() ,fun-name))))
-
-
-;;; Functions for checking mobs (collisions and more)
-
-(define (map-mobs fun type)
-  (let ((mobs (filter (lambda (m) (and (eq? (m 'get-type) type) (not (eq? (m 'get-mob-id) (get-current-mob-id))))) (get-active-mobs))))
-    (map (lambda (m) (fun (m 'get-data))) mobs)))
+	 (let* ((type (get-component-type (car components)))
+		(elist (assoc-ref clist type)))
+	   (register-components entity (cdr components)
+	     (assoc-set! clist type
+	       (cond (elist
+		      (lset-adjoin eq? elist entity))
+		     (else
+		      (list entity)))))))))
 
-(define-macro (define-checking-mobs head mob-def . body)
-  (let ((type (car mob-def)) (attr (cdr mob-def)))
-    `(define ,head
-       (map-mobs
-	(lambda (m)
-	  (let ,(map (lambda (a) `(,(car a) (assoc-ref m ',(cadr a)))) attr)
-	    ,@body))
-	',type))))
 
+(define (get-entity key)
+  (with-mutex entities-mutex
+   (assoc key game-entities)))
 
-;;; Scenes
 
-(define-macro (define-scene name . body)
-  `(define (,name)
-     ,@body))
+(export entity
+	get-entity)