From 09fa5781bfe3e7b8406a4cee4eb24923e14527b0 Mon Sep 17 00:00:00 2001 From: jsancho Date: Wed, 3 Aug 2011 18:26:39 +0000 Subject: [PATCH] --- gacela_misc.lisp | 230 ------------------ gacela_objects.lisp | 113 --------- gacela_procs.lisp | 71 ------ gacela_sound.lisp | 90 ------- src/gacela.c | 36 ++- src/gacela_loader.scm | 1 + gacela_widgets.lisp => src/gacela_widgets.scm | 7 +- 7 files changed, 16 insertions(+), 532 deletions(-) delete mode 100755 gacela_misc.lisp delete mode 100755 gacela_objects.lisp delete mode 100755 gacela_procs.lisp delete mode 100644 gacela_sound.lisp rename gacela_widgets.lisp => src/gacela_widgets.scm (86%) diff --git a/gacela_misc.lisp b/gacela_misc.lisp deleted file mode 100755 index e19f3a2..0000000 --- a/gacela_misc.lisp +++ /dev/null @@ -1,230 +0,0 @@ -;;; Gacela, a GNU Common Lisp extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; 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 . - - -(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)))) diff --git a/gacela_objects.lisp b/gacela_objects.lisp deleted file mode 100755 index 178c4ac..0000000 --- a/gacela_objects.lisp +++ /dev/null @@ -1,113 +0,0 @@ -;;; Gacela, a GNU Common Lisp extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; 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 . - - -(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))) diff --git a/gacela_procs.lisp b/gacela_procs.lisp deleted file mode 100755 index ce58974..0000000 --- a/gacela_procs.lisp +++ /dev/null @@ -1,71 +0,0 @@ -(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))) diff --git a/gacela_sound.lisp b/gacela_sound.lisp deleted file mode 100644 index e1b2a1e..0000000 --- a/gacela_sound.lisp +++ /dev/null @@ -1,90 +0,0 @@ -;;; Gacela, a GNU Common Lisp extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; 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 . - - -(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))) diff --git a/src/gacela.c b/src/gacela.c index a75fe73..2f82d72 100644 --- a/src/gacela.c +++ b/src/gacela.c @@ -204,14 +204,6 @@ load_scheme_files (char *path) 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) { @@ -245,7 +237,7 @@ int 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; @@ -254,7 +246,7 @@ main (int argc, char *argv[]) // 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; @@ -279,18 +271,6 @@ main (int argc, char *argv[]) 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 (); @@ -309,4 +289,16 @@ main (int argc, char *argv[]) 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); + } } diff --git a/src/gacela_loader.scm b/src/gacela_loader.scm index c5f97fa..23b0951 100644 --- a/src/gacela_loader.scm +++ b/src/gacela_loader.scm @@ -22,3 +22,4 @@ (primitive-load-path "gacela_mobs.scm") (primitive-load-path "gacela_misc.scm") (primitive-load-path "gacela_server.scm") +(primitive-load-path "gacela_widgets.scm") diff --git a/gacela_widgets.lisp b/src/gacela_widgets.scm similarity index 86% rename from gacela_widgets.lisp rename to src/gacela_widgets.scm index 8ff79ec..a0e0223 100755 --- a/gacela_widgets.lisp +++ b/src/gacela_widgets.scm @@ -1,4 +1,4 @@ -;;; Gacela, a GNU Common Lisp extension for fast games development +;;; Gacela, a GNU Guile extension for fast games development ;;; Copyright (C) 2009 by Javier Sancho Fernandez ;;; ;;; This program is free software: you can redistribute it and/or modify @@ -15,11 +15,6 @@ ;;; along with this program. If not, see . -(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)) -- 2.39.2