From 0f5f0a460230c18782cc8e70fcd6fd0991cd09a1 Mon Sep 17 00:00:00 2001
From: Javier Sancho <jsf@jsancho.org>
Date: Fri, 8 Jun 2012 21:35:12 +0200
Subject: [PATCH] Improved cache system for resources and more things.

---
 src/gacela.scm | 32 +-------------------------------
 src/utils.scm  | 33 +++++++++++++++++++++++++++++++++
 src/video.scm  | 11 +++++++++--
 3 files changed, 43 insertions(+), 33 deletions(-)
 create mode 100644 src/utils.scm

diff --git a/src/gacela.scm b/src/gacela.scm
index 9be50b0..9096ddf 100644
--- a/src/gacela.scm
+++ b/src/gacela.scm
@@ -20,9 +20,7 @@
   #:use-module (gacela video)
   #:use-module (gacela audio)
   #:use-module (ice-9 optargs)
-  #:export (load-texture
-	    load-font
-	    *title*
+  #:export (*title*
 	    *width-screen*
 	    *height-screen*
 	    *bpp-screen*
@@ -57,34 +55,6 @@
 	       3d-mode?))
 
 
-;;; Resources Cache
-
-(define resources-cache (make-weak-value-hash-table))
-
-(define (from-cache key)
-  (hash-ref resources-cache key))
-
-(define (into-cache key res)
-  (hash-set! resources-cache key res))
-
-(define-macro (use-cache-with module proc)
-  (let ((pwc (string->symbol (string-concatenate (list (symbol->string proc) "-without-cache")))))
-    `(begin
-       (define ,pwc (@ ,module ,proc))
-       (define (,proc . param)
-	 (let* ((key param)
-		(res (from-cache key)))
-	   (cond (res
-		  res)
-		 (else
-		  (set! res (apply ,pwc param))
-		  (into-cache key res)
-		  res)))))))
-
-(use-cache-with (gacela video) load-texture)
-(use-cache-with (gacela video) load-font)
-
-
 ;;; Main Loop
 
 (define loop-flag #f)
diff --git a/src/utils.scm b/src/utils.scm
new file mode 100644
index 0000000..17d1bbf
--- /dev/null
+++ b/src/utils.scm
@@ -0,0 +1,33 @@
+;;; 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/>.
+
+
+(define-module (gacela utils)
+  #:export (use-cache-with))
+
+
+;;; Cache for procedures
+
+(define (use-cache-with proc)
+  (let ((cache (make-weak-value-hash-table)))
+    (lambda (. param)
+      (let* ((key param)
+	     (res (hash-ref cache key)))
+	(cond (res res)
+	      (else
+	       (set! res (apply proc param))
+	       (hash-set! cache key res)
+	       res))))))
diff --git a/src/video.scm b/src/video.scm
index 11ce699..466438f 100644
--- a/src/video.scm
+++ b/src/video.scm
@@ -20,6 +20,7 @@
   #:use-module (gacela gl)
   #:use-module (gacela ftgl)
   #:use-module (gacela math)
+  #:use-module (gacela utils)
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 receive)
   #:export (init-video
@@ -47,6 +48,7 @@
 	    progn-textures
 	    draw
 	    load-texture
+	    load-texture-without-cache
 	    get-texture-properties
 	    draw-texture
 	    draw-line
@@ -61,6 +63,7 @@
 	    set-camera
 	    camera-look
 	    load-font
+	    load-font-without-texture
 	    render-text)
   #:export-syntax (glmatrix-block))
 
@@ -267,7 +270,7 @@
 	  (else (let ((zoomx (/ (+ width 0.5) old-width)) (zoomy (/ (+ height 0.5) old-height)))
 	       (zoomSurface surface zoomx zoomy 0))))))
 
-(define* (load-texture filename #:key (min-filter GL_LINEAR) (mag-filter GL_LINEAR))
+(define* (load-texture-without-cache filename #:key (min-filter GL_LINEAR) (mag-filter GL_LINEAR))
   (progn-textures
    (receive
     (image real-w real-h) (load-image-for-texture filename)
@@ -285,6 +288,8 @@
 	     (set-texture-size! texture real-w real-h)
 	     texture))))))
 
+(define load-texture (use-cache-with load-texture-without-cache))
+
 (define (get-texture-properties texture)
   `((width . ,(texture-w texture)) (height . ,(texture-h texture))))
 
@@ -407,12 +412,14 @@
 
 ;;; Text and fonts
 
-(define* (load-font font-file #:key (size 40) (encoding ft_encoding_unicode))
+(define* (load-font-without-cache font-file #:key (size 40) (encoding ft_encoding_unicode))
   (let ((font (ftglCreateTextureFont font-file size)))
     (ftglSetFontFaceSize font size 72)
     (ftglSetFontCharMap font encoding)
     font))
 
+(define load-font (use-cache-with load-font-without-cache))
+
 (define* (render-text text font #:key (size #f))
   (cond (size
 	 (cond ((not (= (ftglGetFontFaceSize font) size))
-- 
2.39.2