diff options
| -rw-r--r-- | 2d/helpers.scm | 17 | ||||
| -rw-r--r-- | 2d/shader.scm | 13 |
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 ...)))) |