X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=gacela.lisp;h=9f563895bb4d83a0eb754ad6569cd04c8abfe7ef;hb=48a92156cd64faa98896bf82cdafad27987bc5cb;hp=eecc4893ee41e5196887514e79932e302bb571d8;hpb=8caa865a3194eb573382a411df7636ebb472ca1f;p=gacela.git diff --git a/gacela.lisp b/gacela.lisp index eecc489..9f56389 100644 --- a/gacela.lisp +++ b/gacela.lisp @@ -15,7 +15,7 @@ ;;; along with this program. If not, see . -(in-package :gacela) +(in-package :gacela :nicknames '(gg)) ;;; Default values for Gacela (defvar *width-screen* 640) @@ -38,9 +38,7 @@ ;;; Video Subsystem -(defstruct surface address clip-w clip-h shape) - -(let (screen flags) +(let (screen flags current-width current-height) (defun init-video-mode (&key (width *width-screen*) (height *height-screen*) (bpp *bpp-screen*)) (cond ((null screen) @@ -51,12 +49,17 @@ (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)) (t t))) (defun resize-screen (width height bpp) (setq screen (SDL_SetVideoMode width height bpp flags)) - (resize-screen-GL width height)) + (resize-screen-GL width height) + (setq current-width width current-height height)) + + (defun apply-mode-change () + (resize-screen-GL current-width current-height)) (defun fill-screen (color) (init-video-mode) @@ -69,13 +72,31 @@ (defun quit-video-mode () (setq screen nil))) +(let ((mode '2d)) + (defun set-2d-mode () + (cond ((3d-mode?) + (setq mode '2d) + (init-video-mode) + (glDisable GL_DEPTH_TEST) + (apply-mode-change)))) + + (defun set-3d-mode () + (cond ((not (3d-mode?)) + (setq mode '3d) + (init-video-mode) + (glClearDepth 1) + (glEnable GL_DEPTH_TEST) + (glDepthFunc GL_LEQUAL) + (apply-mode-change)))) + + (defun 3d-mode? () + (eq mode '3d))) (defun init-GL () - (2d-mode) (glShadeModel GL_SMOOTH) (glClearColor 0 0 0 0) - (glClearDepth 1) - (glDepthFunc GL_LEQUAL) +; (glClearDepth 1) +; (glDepthFunc GL_LEQUAL) ; (glEnable GL_BLEND) ; (glBlendFunc GL_SRC_ALPHA GL_ONE) (glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST) @@ -86,16 +107,16 @@ (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) - (let* ((w (/ width 2)) (-w (neg w)) (h (/ height 2)) (-h (neg h))) - (glOrtho -w w -h h 0 1)) -; (gluPerspective 45 ratio 0.1 100) - (glMatrixMode GL_MODELVIEW) - (glLoadIdentity) - t)) + (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 () @@ -121,20 +142,6 @@ (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 clean-screen () - (fill-screen *background-color*)) - -(defun refresh-screen () - (clean-screen) - (funcall-procs #'print-mob) - (flip)) - ;;; Audio Subsystem (let ((audio nil)) @@ -153,12 +160,29 @@ (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 size encoding) - `(:type font :filename ,filename :size ,size :enconding ,encoding)) +(defun make-resource-font (&key filename encoding) + `(:type font :filename ,filename :enconding ,encoding)) + +(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))) -(let ((resources-table (make-hash-table :test 'equal))) +(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)) (defun set-resource (key plist constructor destructor &key static) + (expire-resources) (setf (gethash key resources-table) (make-resource :plist plist :constructor constructor @@ -166,45 +190,47 @@ :time (if static t (SDL_GetTicks))))) (defun get-resource (key) - (let ((resource (gethash key resources-table))) - (cond ((null resource) nil) - (t (cond ((/= (resource-time resource) -1) - (setf (resource-time resource) (SDL_GetTicks)) - (setf (gethash key resources-table) resource))) - (resource-plist resource))))) + (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 (resource-destructor (gethash key resources-table))) - (setf (resource-time (gethash key resources-table)) nil)) + (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 the GUI -(let (socket) - (defun connect-to-gui () - (setq socket (si::socket 1984 :host "localhost"))) +;;; Connection with Gacela Skin Clients +(let (server-socket clients) + (defun start-skin-server (port) + (cond ((null server-socket) (setq server-socket (si::socket port :server #'check-skin-connections))))) - (defun eval-from-gui () - (cond ((and socket (listen socket)) (eval (read socket)))))) + (defun check-skin-connections () + (cond ((listen server-socket) (setq clients (cons (si::accept server-socket) clients))))) + (defun eval-from-skin () + + (when (si::listen socket) + (secure-block socket (eval (read socket))))) + + (defun stop-skin-client () + (when socket + (si::close socket) + (setq socket nil)))) -;;; GaCeLa Functions -(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))))))) +;;; GaCeLa Functions (let (time (time-per-frame (/ 1000.0 *frames-per-second*))) (defun set-frames-per-second (fps) (setq time-per-frame (/ 1000.0 fps))) @@ -216,30 +242,43 @@ (let ((frame-time (- (SDL_GetTicks) time))) (cond ((< frame-time time-per-frame) (SDL_Delay (- time-per-frame frame-time))))))) - + (defmacro run-game (title &body code) - `(progn + `(let ((game-function (lambda () ,@code))) (init-video-mode) (SDL_WM_SetCaption ,title "") - (init-frame-time) - (process-events) - (do () ((quit?)) - (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) - (glLoadIdentity) - ,@code - (SDL_GL_SwapBuffers) - (delay-frame) - (init-frame-time) - (process-events) - (setq running nil)))) + (set-game-code game-function) + (cond ((not (game-running?)) + (init-frame-time) + (process-events) + (game-loop))))) + +(let (running game-code) + (defun game-loop () + (setq running t) + (do () ((quit?)) + (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) + (glLoadIdentity) + (when (functionp game-code) (funcall game-code)) + (SDL_GL_SwapBuffers) + (delay-frame) + (init-frame-time) + (eval-from-skin) + (process-events)) + (setq running nil)) + + (defun game-running? () + running) + + (defun set-game-code (game-function) + (setq game-code game-function))) (defun quit-game () -; (free-all-resources) + (free-all-resources) ; (quit-audio) -; (quit-ttf) (quit-video-mode) -; (quit-all-procs) + (quit-all-mobs) ; (clear-events) ; (quit-events) (quit-sdl))