+++ /dev/null
-;;; Gacela, a GNU Common Lisp extension for fast games development
-;;; Copyright (C) 2009 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
-;;; the Free Software Foundation, either version 3 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-
-(eval-when (compile load eval)
- (when (not (find-package 'gacela)) (make-package 'gacela :nicknames '(gg) :use '(lisp)))
- (in-package 'gacela :nicknames '(gg) :use '(lisp)))
-
-
-(defconstant INFINITY MOST-POSITIVE-LONG-FLOAT)
-
-(defun append-if (new test tree &key (key #'first) (test-if #'equal))
- (cond ((atom tree) tree)
- (t (append-if-1
- new
- test
- (mapcar (lambda (x) (append-if new test x :key key :test-if test-if)) tree)
- :key key
- :test-if test-if))))
-
-(defun append-if-1 (new test tree &key (key #'first) (test-if #'equal))
- (cond ((funcall test-if (funcall key tree) test) (append tree new))
- (t tree)))
-
-(defun car+ (var)
- (if (listp var) (car var) var))
-
-(defun avg (&rest numbers)
- (let ((total 0))
- (dolist (n numbers) (incf total n))
- (/ total (length numbers))))
-
-(defun neg (num)
- (* -1 num))
-
-(defun signum+ (num)
- (let ((sig (signum num)))
- (cond ((= sig 0) 1)
- (t sig))))
-
-(defmacro destructure (destructuring-list &body body)
- (let ((lambda-list nil) (exp-list nil))
- (dolist (pair destructuring-list)
- (setq exp-list (cons (car pair) exp-list))
- (setq lambda-list (cons (cadr pair) lambda-list)))
- `(destructuring-bind ,lambda-list ,(cons 'list exp-list) ,@body)))
-
-(defun match-pattern (list pattern)
- (cond ((and (null list) (null pattern)) t)
- ((and (consp list) (consp pattern))
- (and (match-pattern (car list) (car pattern)) (match-pattern (cdr list) (cdr pattern))))
- ((and (atom list) (atom pattern))
- (cond ((or (numberp list) (numberp pattern)) (and (numberp list) (numberp pattern)))
- (t t)))))
-
-(defun nearest-power-of-two (n)
- (labels ((power (p n)
- (cond ((> (* p 2) n) p)
- (t (power (* p 2) n)))))
- (power 1 n)))
-
-(defmacro secure-block (output-stream &rest forms)
- (let ((error-handler #'si::universal-error-handler))
- `(block secure
- (defun si::universal-error-handler (error-name correctable function-name continue-format-string error-format-string &rest args)
- ,(when output-stream
- `(write-line
- (cond ((eq error-name :WRONG-TYPE-ARGUMENT) (string error-name))
- (t error-format-string))
- ,output-stream))
- (setf (symbol-function 'si::universal-error-handler) ,error-handler)
- (return-from secure))
- (let (result-eval)
- (setq result-eval (progn ,@forms))
- (setf (symbol-function 'si::universal-error-handler) ,error-handler)
- result-eval))))
-
-(defmacro persistent-let (name vars &rest forms)
- (labels ((get-vars (vars)
- (cond ((null vars) nil)
- (t (cons (if (consp (car vars)) (caar vars) (car vars))
- (get-vars (cdr vars)))))))
-
- `(let ,(cond ((functionp name)
- (let ((old-vars (funcall name)))
- (cond ((equal (get-vars vars) (get-vars old-vars)) old-vars)
- (t vars))))
- (t vars))
- (defun ,name ()
- ,(let ((lvars (get-vars vars)))
- `(mapcar (lambda (x y) (list x y)) ',lvars ,(cons 'list lvars))))
- ,@forms)))
-
-;Geometry
-(defun dotp (dot)
- (match-pattern dot '(0 0)))
-
-(defun vectorp (vector)
- (match-pattern vector '(0 0)))
-
-(defun circlep (circle)
- (match-pattern circle '((0 0) 0)))
-
-(defun polygonp (polygon)
- (cond ((consp polygon)
- (and (dotp (car polygon))
- (if (null (cdr polygon)) t (polygonp (cdr polygon)))))))
-
-(defun make-dot (x y)
- `(,x ,y))
-
-(defun make-vector (x y)
- `(,x ,y))
-
-(defun make-line (dot1 dot2)
- `(,dot1 ,dot2))
-
-(defun make-rectangle (x1 y1 x2 y2)
- `((,x1 ,y1) (,x2 ,y1) (,x2 ,y2) (,x1 ,y2)))
-
-(defun polygon-center (polygon)
- (apply #'mapcar #'avg polygon))
-
-(defun dots-distance (dot1 dot2)
- (destructure ((dot1 (x1 y1))
- (dot2 (x2 y2)))
- (sqrt (+ (expt (- x2 x1) 2)
- (expt (- y2 y1) 2)))))
-
-(defun dot-line-distance (dot line)
- (destructure ((line ((ax ay) (bx by)))
- (dot (cx cy)))
- (let* ((r-numerator (+ (* (- cx ax) (- bx ax)) (* (- cy ay) (- by ay))))
- (r-denomenator (+ (expt (- bx ax) 2) (expt (- by ay) 2)))
- (r (/ r-numerator r-denomenator)))
- (values
- (* (abs (/ (- (* (- ay cy) (- bx ax)) (* (- ax cx) (- by ay)))
- r-denomenator))
- (sqrt r-denomenator))
- r))))
-
-(defun dot-segment-distance (dot segment)
- (multiple-value-bind
- (dist r) (dot-line-distance dot segment)
- (cond ((and (>= r 0) (<= r 1)) dist)
- (t (let ((dist1 (dots-distance dot (car segment)))
- (dist2 (dots-distance dot (cadr segment))))
- (if (< dist1 dist2) dist1 dist2))))))
-
-(defun perpendicular-line (dot line)
- (destructure ((line ((ax ay) (bx by))))
- (multiple-value-bind
- (dist r) (dot-line-distance dot line)
- (make-line dot
- (make-dot (+ ax (* r (- bx ax)))
- (+ ay (* r (- by ay))))))))
-
-(defun line-angle (line)
- (destructure ((line ((ax ay) (bx by))))
- (let ((x (- bx ax)) (y (- by ay)))
- (if (and (= x 0) (= y 0)) 0 (atan y x)))))
-
-(defun inverse-angle (angle)
- (cond ((< angle pi) (+ angle pi))
- (t (- angle pi))))
-
-(defun translate-dot (dot dx dy)
- (destructure ((dot (x y)))
- (list (+ x dx) (+ y dy))))
-
-(defun translate-circle (circle dx dy)
- (destructure ((circle (center radius)))
- (list (translate-dot center dx dy) radius)))
-
-(defun translate-polygon (pol dx dy)
- (mapcar (lambda (dot)
- (translate-dot dot dx dy))
- pol))
-
-(defun polygon-edges (pol)
- (mapcar (lambda (v1 v2) (list v1 v2))
- pol
- (union (cdr pol) (list (car pol)))))
-
-(defun polygon-dot-intersection (polygon dot)
-;Eric Haines algorithm
- (let ((edges (polygon-edges
- (translate-polygon polygon (neg (car dot)) (neg (cadr dot)))))
- (counter 0))
- (dolist (edge edges)
- (destructure ((edge ((x1 y1) (x2 y2))))
- (cond ((/= (signum+ y1) (signum+ y2))
- (cond ((and (> x1 0) (> x2 0)) (incf counter))
- ((and (or (> x1 0) (> x2 0))
- (> (- x1 (* y1 (/ (- x2 x1) (- y2 y1)))) 0))
- (incf counter)))))))
- (not (evenp counter))))
-
-(defun circle-segment-intersection (circle segment)
- (destructure ((circle (center radius)))
- (<= (dot-segment-distance center segment) radius)))
-
-(defun circle-edges-intersection (circle polygon)
- (let ((edges (polygon-edges polygon))
- (edges-i nil))
- (dolist (edge edges)
- (cond ((circle-segment-intersection circle edge) (setq edges-i (cons edge edges-i)))))
- edges-i))
-
-(defun circle-polygon-intersection (circle polygon)
- (or (polygon-dot-intersection polygon (car circle))
- (circle-edges-intersection circle polygon)))
-
-(defun circle-circle-intersection (circle1 circle2)
- (destructure ((circle1 (center1 radius1))
- (circle2 (center2 radius2)))
- (<= (dots-distance center1 center2) (+ r1 r2))))
+++ /dev/null
-;;; Gacela, a GNU Common Lisp extension for fast games development
-;;; Copyright (C) 2009 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
-;;; the Free Software Foundation, either version 3 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-
-(eval-when (compile load eval)
- (when (not (find-package 'gacela)) (make-package 'gacela :nicknames '(gg) :use '(lisp)))
- (in-package 'gacela :nicknames '(gg) :use '(lisp)))
-
-
-;;; Behaviours of objects
-
-(defmacro make-behaviour (name attr &rest code)
- `(defun ,(get-behaviour-fun-name name) (object-attr)
- (let ,(mapcar #'attribute-definition attr)
- ,@code
- ,(cons 'progn (mapcar #'attribute-save (reverse attr)))
- object-attr)))
-
-(defun get-behaviour-fun-name (name)
- (intern (concatenate 'string "BEHAVIOUR-" (string-upcase (string name))) 'gacela))
-
-(defun attribute-name (attribute)
- (intern (string attribute) 'keyword))
-
-(defun attribute-definition (attribute)
- (let* ((name (cond ((listp attribute) (car attribute))
- (t attribute)))
- (pname (attribute-name name))
- (value (cond ((listp attribute) (cadr attribute)))))
- `(,name (getf object-attr ,pname ,value))))
-
-(defun attribute-save (attribute)
- (let* ((name (cond ((listp attribute) (car attribute))
- (t attribute)))
- (pname (attribute-name name)))
- `(setf (getf object-attr ,pname) ,name)))
-
-
-
-;;; Objects Factory
-
-(let (active-objects objects-to-add objects-to-kill)
- (defun add-object (object)
- (pushnew object objects-to-add))
-
- (defun kill-object (object)
- (pushnew object objects-to-kill))
-
- (defun kill-all-objects ()
- (setq active-objects nil objects-to-add nil objects-to-kill nil))
-
- (defun refresh-active-objects ()
- (cond (objects-to-add
- (setq active-objects (union active-objects objects-to-add))
- (setq objects-to-add nil)))
- (cond (objects-to-kill
- (setq active-objects (reverse (set-difference active-objects objects-to-kill)))
- (setq objects-to-kill nil))))
-
- (defun bhv-objects ()
- (dolist (o active-objects) (funcall o :action)))
-
- (defun render-objects ()
- (dolist (o active-objects) (funcall o :render))))
-
-
-(defmacro make-object (name attr bhv &body look)
- `(progn
- (let ((attr ,(cond (attr (cons 'list (make-object-attributes attr)))))
- (bhv ,(cond (bhv (cons 'list (make-object-behaviour bhv))))))
- (defun ,name (option &rest param)
- (case option
- (:action (dolist (b bhv t) (setq attr (funcall (get-behaviour-fun-name b) attr))))
- (:get-attr attr)
- (:get-bhv bhv)
- (:set-bhv (setq bhv (car param)))
- (:render (glPushMatrix)
- ,@(mapcar (lambda (x) (if (stringp x) `(draw-image ,x) x)) look)
- (glPopMatrix)))))
- (add-object ',name)
- ',name))
-
-(defun make-object-attributes (attr)
- (cond ((or (null attr) (atom attr)) nil)
- (t (let ((rest (make-object-attributes (cdr attr)))
- (this (object-attribute-definition (car attr))))
- (setf (getf rest (car this)) (cadr this))
- rest))))
-
-(defun object-attribute-definition (attribute)
- (let* ((name (cond ((listp attribute) (car attribute))
- (t attribute)))
- (pname (attribute-name name))
- (value (cond ((listp attribute) (cadr attribute)))))
- `(,pname ,value)))
-
-(defun make-object-behaviour (bhv)
- (cond ((null bhv) nil)
- ((atom bhv) (list bhv))
- (t bhv)))
+++ /dev/null
-(defmacro defproc (name type variables init logic motion)
- `(let ((make-name ',(intern (concatenate 'string "MAKE-" (string name)))))
- (setf (symbol-function make-name)
- (make-proc-constructor ,type ,variables ,init ,logic ,motion))
- make-name))
-
-(defmacro make-proc-constructor (type variables init logic motion)
- `(lambda
- ,(if (null variables) () (cons '&key variables))
- (proc-structure ,type ,variables ,init ,logic ,motion)))
-
-(defmacro proc-structure (type variables init logic motion)
- `(list
- :type ,type
- :init (lambda () ,init)
- :logic (lambda () ,logic)
- :motion (lambda () ,motion)
- :context (lambda ()
- ,(if variables
- `(mapcar #'list
- ',(mapcar #'car+ variables)
- (multiple-value-list
- (values-list ,(cons 'list (mapcar #'car+ variables)))))
- nil))))
-
-(defun proc-value (proc label)
- (car (cdr (assoc label (funcall (getf proc :context))))))
-
-(defun proc-type (proc)
- (getf proc :type))
-
-(defun init-proc (proc)
- (funcall (getf proc :init)))
-
-(defun logic-proc (proc)
- (funcall (getf proc :logic)))
-
-(defun motion-proc (proc)
- (funcall (getf proc :motion)))
-
-(let ((active-procs nil) (procs-to-add nil) (procs-to-quit nil))
-
- (defun add-proc (proc)
- (push proc procs-to-add))
-
- (defun logic-procs ()
- (dolist (proc active-procs) (logic-proc proc)))
-
- (defun motion-procs ()
- (dolist (proc active-procs) (motion-proc proc)))
-
- (defun funcall-procs (func)
- (dolist (proc active-procs) (funcall func proc)))
-
- (defun filter-procs (test)
- (intersection (mapcar (lambda (p) (cond ((funcall test p) p))) active-procs) active-procs))
-
- (defun quit-proc (proc)
- (push proc procs-to-quit))
-
- (defun refresh-active-procs ()
- (do ((proc (pop procs-to-add) (pop procs-to-add))) ((null proc))
- (push proc active-procs)
- (init-proc proc))
- (do ((proc (pop procs-to-quit) (pop procs-to-quit))) ((null proc))
- (setq active-procs (reverse (set-difference active-procs (list proc) :test #'equal)))))
-
- (defun quit-all-procs ()
- (setq active-procs nil)
- (setq procs-to-add nil)
- (setq procs-to-quit nil)))
+++ /dev/null
-;;; Gacela, a GNU Common Lisp extension for fast games development
-;;; Copyright (C) 2009 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
-;;; the Free Software Foundation, either version 3 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-
-(eval-when (compile load eval)
- (when (not (find-package 'gacela)) (make-package 'gacela :nicknames '(gg) :use '(lisp)))
- (in-package 'gacela :nicknames '(gg) :use '(lisp)))
-
-
-;;; Sound
-
-(defun load-sound (filename &key static)
- (let ((key (make-resource-sound :filename filename)))
- (cond ((get-resource key) key)
- (t (true-load-sound filename static)))))
-
-(defun true-load-sound (filename static)
- (init-audio)
- (let ((key (make-resource-sound :filename filename))
- (sound (Mix_LoadWAV filename)))
- (cond ((/= sound 0)
- (set-resource key
- `(:id-sound ,sound)
- (lambda () (true-load-sound filename static))
- (lambda () (Mix_FreeChunk sound))
- :static static)
- key))))
-
-(defun play-sound (sound &optional (loops 0))
- (let ((id-sound (getf (get-resource sound) :id-sound)))
- (/= (Mix_PlayChannel -1 id-sound loops) -1)))
-
-
-;;; Music
-
-(defun load-music (filename &key static)
- (let ((key (make-resource-music :filename filename)))
- (cond ((get-resource key) key)
- (t (true-load-music filename static)))))
-
-(defun true-load-music (filename static)
- (init-audio)
- (let ((key (make-resource-music :filename filename))
- (music (Mix_LoadMUS filename)))
- (cond ((/= music 0)
- (set-resource key
- `(:id-music ,music)
- (lambda () (true-load-music filename static))
- (lambda () (Mix_FreeMusic music))
- :static static)
- key))))
-
-(defun playing-music? ()
- (/= (Mix_PlayingMusic) 0))
-
-(defun paused-music? ()
- (/= (Mix_PausedMusic) 0))
-
-(defun play-music (music &optional (loops -1))
- (cond ((not (playing-music?))
- (let ((id-music (getf (get-resource music) :id-music)))
- (/= (Mix_PlayMusic id-music loops) -1)))))
-
-(defun pause-music ()
- (cond ((and (playing-music?) (not (paused-music?)))
- (Mix_PauseMusic)
- t)))
-
-(defun resume-music ()
- (cond ((and (playing-music?) (paused-music?))
- (Mix_ResumeMusic)
- t)))
-
-(defun halt-music ()
- (cond ((playing-music?)
- (Mix_HaltMusic)
- t)))
+++ /dev/null
-;;; Gacela, a GNU Common Lisp extension for fast games development
-;;; Copyright (C) 2009 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
-;;; the Free Software Foundation, either version 3 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-
-(eval-when (compile load eval)
- (when (not (find-package 'gacela)) (make-package 'gacela :nicknames '(gg) :use '(lisp)))
- (in-package 'gacela :nicknames '(gg) :use '(lisp)))
-
-
-;;; Timers
-
-(defstruct timer (start 0) (paused 0) (state 'stopped))
-
-(defun start-timer (timer)
- (setf (timer-start timer) (SDL_GetTicks))
- (setf (timer-state timer) 'running))
-
-(defun stop-timer (timer)
- (setf (timer-state timer) 'stopped))
-
-(defun get-time (timer)
- (cond ((eq (timer-state timer) 'stopped) 0)
- ((eq (timer-state timer) 'paused) (timer-paused timer))
- (t (- (SDL_GetTicks) (timer-start timer)))))
-
-(defun pause-timer (timer)
- (cond ((eq (timer-state timer) 'running)
- (setf (timer-paused timer) (- (SDL_GetTicks) (timer-start timer)))
- (setf (timer-state timer) 'paused))))
-
-(defun resume-timer (timer)
- (cond ((eq (timer-state timer) 'paused)
- (setf (timer-start timer) (- (SDL_GetTicks) (timer-paused timer)))
- (setf (timer-state timer) 'running))))
-
scm_primitive_load_path (scm_from_locale_string ("gacela_loader.scm"));
}
-void
-start_single ()
-{
- char *argv = "guile";
-
- scm_shell (1, &argv);
-}
-
void
start_server (int port)
{
main (int argc, char *argv[])
{
char *arg;
- int mode = 0; // shell: 1, server: 2, client: 3
+ int mode = 0; // playing: 1, server: 2, client: 3
char *host;
int port = 0;
int i;
// Checking arguments
for (i = 1; i < argc; i++) {
- if (strcmp (argv[i], "--shell-mode") == 0)
+ if (strcmp (argv[i], "--playing") == 0)
mode = 1;
else if (strncmp (argv[i], "--server", 8) == 0) {
mode = 2;
scm_init_guile ();
if (mode == 1) {
- scm_with_guile (&init_gacela, NULL);
- load_scheme_files (dirname (argv[0]));
- start_single ();
- }
- else if (mode == 2 && port != 0) {
- scm_with_guile (&init_gacela, NULL);
- load_scheme_files (dirname (argv[0]));
- start_server (port);
- }
- else if (mode == 3 && port != 0)
- start_remote_client (host, port);
- else {
fd1 = scm_pipe ();
fd2 = scm_pipe ();
pid = fork ();
kill (pid, SIGKILL);
}
}
+ else if (mode == 2 && port != 0) {
+ scm_with_guile (&init_gacela, NULL);
+ load_scheme_files (dirname (argv[0]));
+ start_server (port);
+ }
+ else if (mode == 3 && port != 0)
+ start_remote_client (host, port);
+ else {
+ scm_with_guile (&init_gacela, NULL);
+ load_scheme_files (dirname (argv[0]));
+ scm_shell (argc, argv);
+ }
}
(primitive-load-path "gacela_mobs.scm")
(primitive-load-path "gacela_misc.scm")
(primitive-load-path "gacela_server.scm")
+(primitive-load-path "gacela_widgets.scm")
--- /dev/null
+;;; Gacela, a GNU Guile extension for fast games development
+;;; Copyright (C) 2009 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
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+
+;;; Timers
+
+(defstruct timer (start 0) (paused 0) (state 'stopped))
+
+(defun start-timer (timer)
+ (setf (timer-start timer) (SDL_GetTicks))
+ (setf (timer-state timer) 'running))
+
+(defun stop-timer (timer)
+ (setf (timer-state timer) 'stopped))
+
+(defun get-time (timer)
+ (cond ((eq (timer-state timer) 'stopped) 0)
+ ((eq (timer-state timer) 'paused) (timer-paused timer))
+ (t (- (SDL_GetTicks) (timer-start timer)))))
+
+(defun pause-timer (timer)
+ (cond ((eq (timer-state timer) 'running)
+ (setf (timer-paused timer) (- (SDL_GetTicks) (timer-start timer)))
+ (setf (timer-state timer) 'paused))))
+
+(defun resume-timer (timer)
+ (cond ((eq (timer-state timer) 'paused)
+ (setf (timer-start timer) (- (SDL_GetTicks) (timer-paused timer)))
+ (setf (timer-state timer) 'running))))
+
projects / gacela.git / commitdiff