summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--2d/helpers.scm17
-rw-r--r--2d/shader.scm13
2 files changed, 23 insertions, 7 deletions
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 ...))))