From cc5051e85c6491f54438ee62573953107c916fff Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Thu, 22 May 2014 21:18:01 -0400
Subject: Memoize uniform-location.

* 2d/helpers.scm (memoize): New procedure.

* 2d/shader.scm (uniform-location): memoize.
  (uniform-set!): Pass symbol instead of string.
---
 2d/helpers.scm | 17 ++++++++++++++++-
 2d/shader.scm  | 13 +++++++------
 2 files changed, 23 insertions(+), 7 deletions(-)

(limited to '2d')

diff --git a/2d/helpers.scm b/2d/helpers.scm
index 59633d6..4082377 100644
--- a/2d/helpers.scm
+++ b/2d/helpers.scm
@@ -1,5 +1,6 @@
 ;;; guile-2d
 ;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu>
+;;; Copyright (C) 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This program is free software: you can redistribute it and/or
 ;;; modify it under the terms of the GNU General Public License as
@@ -28,7 +29,8 @@
   #:use-module (2d game)
   #:export (any-equal?
             logand?
-            define-guardian))
+            define-guardian
+            memoize))
 
 (define (any-equal? elem . args)
   "Return #t if ELEM equals any of the elements in the list ARGS."
@@ -51,3 +53,16 @@ same thread that is running the game loop."
          (when obj
            (reaper obj)
            (reap (name))))))))
+
+(define (memoize proc)
+  "Return a memoizing version of PROC."
+  (let ((cache (make-hash-table)))
+    (lambda args
+      (let ((results (hash-ref cache args)))
+        (if results
+            (apply values results)
+            (let ((results (call-with-values (lambda ()
+                                               (apply proc args))
+                             list)))
+              (hash-set! cache args results)
+              (apply values results)))))))
diff --git a/2d/shader.scm b/2d/shader.scm
index 0be977f..1ed18bd 100644
--- a/2d/shader.scm
+++ b/2d/shader.scm
@@ -284,9 +284,12 @@ location."
                                          (color-b c)
                                          (color-a c))))
 
-(define (uniform-location shader-program name)
-  "Retrieve the location for the uniform NAME within SHADER-PROGRAM."
-  (glGetUniformLocation (shader-program-id shader-program) name))
+(define uniform-location
+  (memoize
+   (lambda (shader-program name)
+     "Retrieve the location for the uniform NAME within SHADER-PROGRAM."
+     (glGetUniformLocation (shader-program-id shader-program)
+                           (symbol->string name)))))
 
 (define (uniform-set! shader-program name value)
   "Use the appropriate setter procedure to translate VALUE into OpenGL
@@ -313,8 +316,6 @@ within SHADER-PROGRAM."
      (begin body ...))
     ((_ ((name value) ...) body ...)
      (begin
-       (uniform-set! (current-shader-program)
-                     (symbol->string 'name)
-                     value)
+       (uniform-set! (current-shader-program) 'name value)
        ...
        body ...))))
-- 
cgit v1.2.3