diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index c7844f4..f7c5da8 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -123,8 +123,8 @@ [`(color ,(? color-number? r) ,(? color-number? g) ,(? color-number? b) ,(? color-number? a)) (values `(glColor4d ,r ,g ,b ,a) '())] [`(texture ,i) - (define tex (image->texture i)) - (values `(draw-gl-face ,tex) (list tex))] + (define entry (image->texture-cache-entry i)) + (values `(draw-gl-face ,(send entry get-texture)) (list entry))] [`(push-matrix ,instr ...) (define-values (code resources) (instructions->racket-code instr)) (values `(begin (glPushMatrix) ,@code (glPopMatrix)) resources)] @@ -155,9 +155,8 @@ [else (error 'image->bitmap "unsupported image type ~v" i)])) -(define (image->texture i) - (define bm (image->bitmap i)) - (new texture% [bitmap bm])) +(define (image->texture-cache-entry i) + (texture-cache-get i image->bitmap)) ;; (define (lerp a b v) (+ (* v a) (* (- 1 v) b))) @@ -297,7 +296,8 @@ (define-values (added removed) (patch-project/set/single p sprite-projection)) ;; Remove old sprites first, to recycle their texture identifiers (if any) (for [(s removed)] (remove-sprite! sprites s)) - (for [(s added)] (add-sprite! sprites s))) + (for [(s added)] (add-sprite! sprites s)) + (flush-texture-cache!)) (define (process-stop-requests! p) (when (matcher-match-value (patch-added p) 'stop #f) diff --git a/prospect-gl/texture.rkt b/prospect-gl/texture.rkt index d733332..9b8d544 100644 --- a/prospect-gl/texture.rkt +++ b/prospect-gl/texture.rkt @@ -1,6 +1,8 @@ #lang racket/gui -(provide texture%) +(provide texture% + texture-cache-get + flush-texture-cache!) (require sgl/gl) (require sgl/gl-vectors) @@ -47,3 +49,57 @@ (super-new) (load-from-bitmap! initial-bitmap))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define texture-cache (make-hasheq)) +(define texture-second-chances (make-hasheq)) +(define last-flush 0) + +(define entry% + (class object% + (init-field key + texture) + (super-new) + (define ref-count 0) + + (define/public (get-texture) + texture) + + (define/public (inc-ref-count!) + (set! ref-count (+ ref-count 1))) + + (define/public (dispose) + (set! ref-count (- ref-count 1)) + (when (zero? ref-count) + (hash-remove! texture-cache key) + (hash-set! texture-second-chances key this))) + + (define/public (*cleanup) + (send texture dispose)))) + +(define (texture-cache-get key key->bitmap) + (define entry + (hash-ref texture-cache + key + (lambda () + (define t (cond + [(hash-has-key? texture-second-chances key) + (define t (hash-ref texture-second-chances key)) + (hash-remove! texture-second-chances key) + t] + [else + (define bm (key->bitmap key)) + (new entry% [key key] [texture (new texture% [bitmap bm])])])) + (hash-set! texture-cache key t) + t))) + (send entry inc-ref-count!) + entry) + +(define (flush-texture-cache!) + (define now (current-seconds)) + (when (> now (+ last-flush 10)) + ;; (log-info "flushing texture cache (~a entries)" (hash-count texture-second-chances)) + (for [(entry (in-hash-values texture-second-chances))] (send entry *cleanup)) + (hash-clear! texture-second-chances) + (set! last-flush now)))