X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=gacela.lisp;h=4197d22d077e2b488fc7f692d48285aced148848;hb=6a3d1ffb69036e6d4f1c239fd7d52f9bfc48d50c;hp=62594b53508a1a15d7aa6fa1cc1672e929c955b3;hpb=678a1561ca858c34fecf04792831caf68559c2ac;p=gacela.git diff --git a/gacela.lisp b/gacela.lisp index 62594b5..4197d22 100644 --- a/gacela.lisp +++ b/gacela.lisp @@ -15,17 +15,18 @@ ;;; along with this program. If not, see . -(in-package :gacela) +(eval-when (compile load) (make-package 'gacela :nicknames '(gg) :use '(lisp))) + +(eval-when (compile load eval) + (when (not (find-package 'gacela)) (make-package 'gacela :nicknames '(gg) :use '(lisp))) + (in-package 'gacela :nicknames '(gg) :use '(lisp))) + ;;; Default values for Gacela (defvar *width-screen* 640) (defvar *height-screen* 480) (defvar *bpp-screen* 32) -(defvar *title-screen* "Happy Hacking!!") -(defvar *gacela-freq* 30) -(defvar *transparent-color* '(:red 0 :green 0 :blue 0)) -(defvar *background-color* '(:red 0 :green 0 :blue 0)) -(defvar *zoom* -10) +(defvar *frames-per-second* 20) ;;; SDL Initialization Subsystem (let (initialized) @@ -39,11 +40,9 @@ ;;; Video Subsystem -(defstruct surface address clip-w clip-h shape) - -(let (screen flags) +(let (screen flags (current-width *width-screen*) (current-height *height-screen*) current-bpp) - (defun init-video-mode (&key (width *width-screen*) (height *height-screen*) (bpp *bpp-screen*)) + (defun init-video-mode (&key (width current-width) (height current-height) (bpp *bpp-screen*)) (cond ((null screen) (init-sdl) (SDL_GL_SetAttribute SDL_GL_DOUBLEBUFFER 1) @@ -52,80 +51,71 @@ (if (= (getf (SDL_GetVideoInfo) :blit_hw) 0) 0 SDL_HWACCEL))) (setq screen (SDL_SetVideoMode width height bpp flags)) (init-GL) - (resize-screen-GL width height)) + (resize-screen-GL width height) + (setq current-width width current-height height current-bpp bpp)) (t t))) - (defun resize-screen (width height bpp) - (setq screen (SDL_SetVideoMode width height bpp flags)) - (resize-screen-GL width height)) - - (defun fill-screen (color) - (init-video-mode) - (fill-surface screen (getf color :red) (getf color :green) (getf color :blue))) - - (defun flip () - (cond ((null screen) nil) - (t (SDL_Flip screen)))) + (defun resize-screen (width height &optional (bpp current-bpp)) + (cond (screen (setq screen (SDL_SetVideoMode width height bpp flags)) + (resize-screen-GL width height))) + (setq current-width width current-height height)) - (defun create-surface (width height &key (trans-color *transparent-color*)) - (init-video-mode) - (let ((new-surface (make-surface - :address (create-SDL_Surface - (surface-address screen) - width - height - (getf trans-color :red) - (getf trans-color :green) - (getf trans-color :blue))))) - (set-resource 'image new-surface (gentemp)) - new-surface)) - - (defun print-surface (x y surface) - (apply-surface x y surface screen) - surface) + (defun apply-mode-change () + (resize-screen-GL current-width current-height)) (defun quit-video-mode () (setq screen nil))) +(defun set-2d-mode () + (cond ((not (3d-mode?)) + (init-video-mode) + (glDisable GL_DEPTH_TEST) + (apply-mode-change)))) + +(defun set-3d-mode () + (cond ((3d-mode?) + (init-video-mode) + (glClearDepth 1) + (glEnable GL_DEPTH_TEST) + (glDepthFunc GL_LEQUAL) + (apply-mode-change)))) + +(defun 3d-mode? () + (eq (getf (get-game-properties) :mode) '3d)) (defun init-GL () (glShadeModel GL_SMOOTH) (glClearColor 0 0 0 0) - (glClearDepth 1) - (glEnable GL_DEPTH_TEST) - (glDepthFunc GL_LEQUAL) +; (glClearDepth 1) +; (glDepthFunc GL_LEQUAL) ; (glEnable GL_BLEND) ; (glBlendFunc GL_SRC_ALPHA GL_ONE) (glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST) t) -(defun init-textures () - (init-video-mode) - (glEnable GL_TEXTURE_2D)) - (defun init-lighting () (init-video-mode) (glEnable GL_LIGHTING)) (defun resize-screen-GL (width height) - (let ((ratio (if (= height 0) width (/ width height)))) - (glViewPort 0 0 width height) - (glMatrixMode GL_PROJECTION) - (glLoadIdentity) - (gluPerspective 45 ratio 0.1 100) - (glMatrixMode GL_MODELVIEW) - (glLoadIdentity) - t)) - -(defun copy-surface (source) - (cond ((surface-p source) - (let ((new-surface - (make-surface :address (copy-SDL_Surface (surface-address source)) - :clip-w (surface-clip-w source) - :clip-h (surface-clip-h source) - :shape (surface-shape source)))) - (set-resource 'image new-surface (gentemp)) - new-surface)))) + (glViewPort 0 0 width height) + (glMatrixMode GL_PROJECTION) + (glLoadIdentity) + (cond ((3d-mode?) (let ((ratio (if (= height 0) width (/ width height)))) + (gluPerspective 45 ratio 0.1 100))) ;0.1 + (t (let* ((w (/ width 2)) (-w (neg w)) (h (/ height 2)) (-h (neg h))) + (glOrtho -w w -h h 0 1)))) + (glMatrixMode GL_MODELVIEW) + (glLoadIdentity) + t)) + +(let ((current-color '(1 1 1 1))) + (defun get-current-color () + current-color) + + (defun set-current-color (red green blue &optional (alpha 1)) + (setq current-color (list red green blue alpha)) + (glColor4f red green blue alpha))) (defun load-image (image-file &key (transparent-color nil)) (init-video-mode) @@ -143,127 +133,12 @@ (caddr transparent-color))) optimized-image))))))) -(defun load-image2 (image-file &key (transparent-color nil)) - (let ((address-image (load-image image-file :transparent-color transparent-color))) - (list - (lambda (x y) (print-surface x y address-image)) - (lambda () (SDL_FreeSurface address-image))))) - -(defun apply-surface (x y source destination) - (let ((offset (SDL_Rect x y 0 0))) - (SDL_BlitSurface source 0 destination offset) - (free offset) - destination)) - -(defun apply-surface-old (x y source destination &optional (clip nil)) - (cond ((null clip) - (apply-surface2 x y (surface-address source) (surface-address destination) 0 0 0 0 0)) - ((integerp clip) - (apply-surface2 x y (surface-address source) (surface-address destination) 0 0 - (surface-clip-w source) (surface-clip-h source) clip)) - (t - (apply-surface2 x y (surface-address source) (surface-address destination) - (first clip) (second clip) (third clip) (fourth clip) 0))) - destination) - - -(defun print-image (x y image-file &optional (clip nil)) - (init-video-mode) - (let ((image (load-image image-file))) - (print-surface x y image clip) - image)) - - -(defun clean-screen () - (fill-screen *background-color*)) - -(defun refresh-screen () - (clean-screen) - (funcall-procs #'print-mob) - (flip)) - - -(defun filled-circle (radius &optional (color '(:red 255 :green 255 :blue 255))) - (init-video-mode) - (let ((new-surface (create-surface (1+ (* radius 2)) (1+ (* radius 2))))) - (sge_FilledCircle (surface-address new-surface) - radius radius radius - (getf color :red) - (getf color :green) - (getf color :blue)) - (setf (surface-shape new-surface) - `((,radius ,radius) ,radius)) - new-surface)) - - -(defun filled-rect (width height &optional (color '(:red 255 :green 255 :blue 255))) - (init-video-mode) - (let ((new-surface (create-surface width height))) - (sge_FilledRect (surface-address new-surface) - 0 0 width height - (getf color :red) - (getf color :green) - (getf color :blue)) - (setf (surface-shape new-surface) - (make-rectangle 0 0 width height)) - new-surface)) - - -;;; TTF Subsystem -(defstruct font address) - -(let ((ttf nil)) - - (defun init-ttf () - (cond ((null ttf) (progn (init-sdl) (setq ttf (TTF_Init)))) - (t ttf))) - - (defun quit-ttf () - (setq ttf (TTF_Quit)))) - - -(defun open-font (font-name tam) - (init-ttf) - (let ((font (get-resource 'font font-name tam))) - (if (null font) - (progn (setq font (make-font :address (TTF_OpenFont font-name tam))) - (set-resource 'font font font-name tam))) - font)) - - -(defun render-text (text-message - &key (color '(:red 255 :green 255 :blue 255)) - (font-name "lazy.ttf") (tam 28)) - (init-ttf) - (let ((message (get-resource 'text text-message color font-name tam))) - (if (null message) - (progn - (setq message - (make-surface - :address (render-text2 (open-font font-name tam) - text-message - (getf color :red) - (getf color :green) - (getf color :blue)))) - (set-resource 'text message text-message color font-name tam))) - message)) - - -(defun print-text (x y text-message - &key (color '(:red 255 :green 255 :blue 255)) - (font-name "lazy.ttf") (tam 28)) - (init-video-mode) - (init-ttf) - (let ((message (render-text text-message :color color :font-name font-name :tam tam))) - (print-surface x y message) - message)) - ;;; Audio Subsystem (let ((audio nil)) (defun init-audio () - (cond ((null audio) (progn (init-sdl) (setq audio (Mix_OpenAudio 22050 2 4096)))) + (cond ((null audio) (progn (init-sdl) (setq audio (Mix_OpenAudio 22050 MIX_DEFAULT_FORMAT 2 4096)))) (t audio))) (defun quit-audio () @@ -271,116 +146,167 @@ ;;; Resources Manager -(defstruct resource address free-function object) - -(let ((resources-table (make-hash-table :test 'equal))) - - (defun set-resource (type object &rest key) - (let ((res - (cond ((surface-p object) - (make-resource :address (surface-address object) - :free-function #'SDL_FreeSurface - :object object)) - ((font-p object) - (make-resource :address (font-address object) - :free-function #'TTF_CloseFont - :object object)) - ((cp-space-p object) - (make-resource :address (cp-space-address object) - :free-function #'cpSpaceFree - :object object)) - ((cp-body-p object) - (make-resource :address (cp-body-address object) - :free-function #'cpBodyFree - :object object)) - ((cp-shape-p object) - (make-resource :address (cp-shape-address object) - :free-function #'cpShapeFree - :object object)) - (t nil)))) - (cond (res (setf (gethash `(,type ,@key) resources-table) res))))) - - (defun get-resource (type &rest key) - (let ((resource (gethash `(,type ,@key) resources-table))) - (cond ((null resource) nil) - (t (resource-object resource))))) +(defstruct resource plist constructor destructor time) - (defun free-all-resources () - (maphash (lambda (key res) (funcall (resource-free-function res) (resource-address res))) - resources-table) - (clrhash resources-table))) +(defun make-resource-texture (&key filename min-filter mag-filter) + `(:type texture :filename ,filename :min-filter ,min-filter :mag-filter ,mag-filter)) + +(defun make-resource-font (&key filename encoding) + `(:type font :filename ,filename :enconding ,encoding)) + +(defun make-resource-sound (&key filename) + `(:type sound :filename ,filename)) + +(defun make-resource-music (&key filename) + `(:type music :filename ,filename)) + +(defmacro get-rtime (key) + `(resource-time (gethash ,key resources-table))) + +(defmacro get-rplist (key) + `(resource-plist (gethash ,key resources-table))) + +(defmacro get-rconstructor (key) + `(resource-constructor (gethash ,key resources-table))) + +(defmacro get-rdestructor (key) + `(resource-destructor (gethash ,key resources-table))) + +(let ((resources-table (make-hash-table :test 'equal)) + (expiration-time 50000)) + (defun set-expiration-time (new-time) + (setq expiration-time new-time)) -;;; Connection with the GUI -(let (socket) - (defun connect-to-gui () - (setq socket (si::socket 1984 :host "localhost"))) + (defun set-resource (key plist constructor destructor &key static) + (expire-resources) + (setf (gethash key resources-table) + (make-resource :plist plist + :constructor constructor + :destructor destructor + :time (if static t (SDL_GetTicks))))) - (defun eval-from-gui () - (cond ((and socket (listen socket)) (eval (read socket)))))) + (defun get-resource (key) + (cond ((null (gethash key resources-table)) nil) + (t (let ((time (get-rtime key))) + (cond ((null time) (funcall (get-rconstructor key))) + ((numberp time) (setf (get-rtime key) (SDL_GetTicks)))) + (get-rplist key))))) + + (defun free-resource (key) + (funcall (get-rdestructor key)) + (setf (get-rtime key) nil)) + + (defun expire-resource (key &optional (now (SDL_GetTicks))) + (let ((time (get-rtime key))) + (cond ((and (numberp time) (> (- now time) expiration-time)) (free-resource key))))) + + (defun expire-resources () + (maphash (lambda (key res) (expire-resource key)) resources-table)) + + (defun free-all-resources () + (maphash (lambda (key res) (free-resource key)) resources-table))) + + +;;; Connection with Gacela Clients +(let (server-socket clients) + (defun start-server (port) + (cond ((null server-socket) (setq server-socket (si::socket port :server #'check-connections))))) + + (defun check-connections () + (cond ((and server-socket (listen server-socket)) (setq clients (cons (si::accept server-socket) clients))))) + + (defun eval-from-clients () + (labels ((eval-clients (cli-socks) + (cond (cli-socks + (let ((cli (car cli-socks))) + (cond ((si::listen cli) + (secure-block cli (eval (read cli))) + (si::close cli) + (eval-clients (cdr cli-socks))) + (t + (cons cli (eval-clients (cdr cli-socks)))))))))) + (setq clients (eval-clients clients)))) + + (defun stop-server () + (cond (server-socket (si::close server-socket) (setq server-socket nil))) + (cond (clients + (labels ((close-clients (cli-socks) + (si::close (car cli-socks)) + (close-clients (cdr cli-socks)))) + (close-clients clients)) + (setq clients nil))))) ;;; GaCeLa Functions -;(defun game-loop (code) -; (process-events) -; (cond ((quit?) nil) -; (t -; (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) -; (glLoadIdentity) -; (translate 0 0 *zoom*) -; (funcall code) -; (SDL_GL_SwapBuffers) -; (SDL_Delay (- *gacela-freq* (rem (SDL_GetTicks) *gacela-freq*))) -; (game-loop code)))) - -(let (commands) - (defun prog-command (command) - (setq commands (cons command commands))) - - (defun run-commands () - (cond (commands - (let (running) - (setq running commands) - (setq commands nil) - (labels ((run-com (comlst) - (cond (comlst (run-com (cdr comlst)) - (eval (read-from-string (concatenate 'string "(progn " (car comlst) ")"))))))) - (run-com running))))))) - -(defmacro run-game (title &body code) - `(progn +(let (time (time-per-frame (/ 1000.0 *frames-per-second*))) + (defun set-frames-per-second (fps) + (setq time-per-frame (/ 1000.0 fps))) + + (defun init-frame-time () + (setq time (SDL_GetTicks))) + + (defun delay-frame () + (let ((frame-time (- (SDL_GetTicks) time))) + (cond ((< frame-time time-per-frame) + (SDL_Delay (- time-per-frame frame-time))))))) + + +(let ((ptitle "") (pwidth *width-screen*) (pheight *height-screen*) (pbpp *bpp-screen*) (pfps *frames-per-second*) (pmode '2d)) + (defun set-game-properties (&key title width height bpp fps mode) + (init-video-mode) + (when title (progn (setq ptitle title) (SDL_WM_SetCaption title ""))) + (when (or width height bpp) + (progn + (when width (setq pwidth width)) + (when height (setq pheight height)) + (when bpp (setq pbpp bpp)) + (resize-screen pwidth pheight pbpp))) + (when fps (progn (setq pfps fps) (set-frames-per-second fps))) + (when mode (progn (setq pmode mode) (if (eq mode '3d) (set-3d-mode) (set-2d-mode)))) + (get-game-properties)) + + (defun get-game-properties () + (list :title ptitle :width pwidth :height pheight :bpp pbpp :fps pfps :mode pmode))) + + +(defmacro run-game (&body code) + `(let ((game-function (lambda () ,@code))) (init-video-mode) - (SDL_WM_SetCaption ,title "") - (process-events) - (do () ((quit?)) - (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) - (glLoadIdentity) - (translate 0 0 *zoom*) - ,@code - (SDL_GL_SwapBuffers) - (SDL_Delay (- *gacela-freq* (rem (SDL_GetTicks) *gacela-freq*))) - (process-events) - (setq running nil)))) - -;(defun run-game () -; (init-video-mode) -; (SDL_WM_SetCaption *title-screen* "") -; (refresh-active-procs) -; (enjoy!) -; (do () ((quit?)) -; (process-events) -; (logic-procs) -; (motion-procs) -; (refresh-active-procs) -; (refresh-screen) -; (SDL_Delay (- *gacela-freq* (rem (SDL_GetTicks) *gacela-freq*))))) + (set-game-code game-function) + (cond ((not (game-running?)) + (game-loop))))) + +(let (running game-code) + (defun game-loop () + (setq running t) + (do () ((quit?)) + (init-frame-time) + (check-connections) + (eval-from-clients) + (process-events) + (cond ((not (quit?)) + (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) + (to-origin) + (refresh-active-objects) + (when (functionp game-code) (funcall game-code)) + (render-objects) + (SDL_GL_SwapBuffers) + (delay-frame)))) + (setq running nil)) + + (defun game-running? () + running) + + (defun set-game-code (game-function) + (setq game-code game-function))) (defun quit-game () -; (free-all-resources) -; (quit-audio) -; (quit-ttf) + (free-all-resources) + (quit-audio) (quit-video-mode) -; (quit-all-procs) +; (quit-all-mobs) + (kill-all-objects) ; (clear-events) ; (quit-events) (quit-sdl))