#lang racket/base
(require racket/class
         racket/draw/dc
         racket/draw/bitmap-dc
         racket/draw/bitmap
         racket/draw/local
         "../../lock.rkt"
         "queue.rkt")

(provide backing-dc%
         
         ;; scoped method names:
         get-backing-size
         queue-backing-flush
         on-backing-flush
         start-backing-retained
         end-backing-retained
         reset-backing-retained
         make-backing-bitmap
         request-delay
         cancel-delay
         end-delay)

(define-local-member-name
  get-backing-size
  queue-backing-flush
  on-backing-flush
  start-backing-retained
  end-backing-retained
  reset-backing-retained
  make-backing-bitmap
  request-delay
  cancel-delay
  end-delay)

(define backing-dc%
  (class (dc-mixin bitmap-dc-backend%)
    (inherit call-with-cr-lock
             internal-get-bitmap
             internal-set-bitmap
             reset-cr
             erase)

    (super-new)

    ;; Override this method to get the right size
    (define/public (get-backing-size xb yb)
      (set-box! xb 1)
      (set-box! yb 1))

    ;; override this method to set up a callback to
    ;;  `on-backing-flush' when the backing store can be rendered
    ;;  to the screen; called atomically (expecting no exceptions)
    (define/public (queue-backing-flush)
      (void))

    (define retained-cr #f)
    (define retained-counter 0)
    (define needs-flush? #f)

    ;; called with a procedure that is applied to a bitmap;
    ;;  returns #f if there's nothing to flush
    (define/public (on-backing-flush proc)
      (cond
       [(not retained-cr) #f]
       [(positive? retained-counter) 
        (proc (internal-get-bitmap)) 
        #t]
       [else 
        (reset-backing-retained proc)
        #t]))
    
    (define/public (can-backing-flush?)
      (and retained-cr #t))

    (define/public (reset-backing-retained [proc void])
      (let ([cr retained-cr])
        (when cr 
          (let ([bm (internal-get-bitmap)])
            (set! retained-cr #f)
            (internal-set-bitmap #f #t)
            (super release-cr retained-cr)
            (proc bm)
            (release-backing-bitmap bm)))))

    (define/public (start-backing-retained)
      (call-with-cr-lock
       (lambda () 
         (set! retained-counter (add1 retained-counter)))))

    (define/public (end-backing-retained)
      (call-with-cr-lock
       (lambda () 
         (if (zero? retained-counter)
             (log-error "unbalanced end-on-paint")
             (set! retained-counter (sub1 retained-counter))))))

    (define/public (make-backing-bitmap w h)
      (make-object bitmap% w h #f #t))

    (define/public (ensure-ready) (get-cr))

    (define/override (get-cr)
      (or retained-cr
          (let ([w (box 0)]
                [h (box 0)])
            (get-backing-size w h)
            (let ([bm (get-backing-bitmap (lambda (w h) (make-backing-bitmap w h)) (unbox w) (unbox h))])
              (internal-set-bitmap bm #t))
            (let ([cr (super get-cr)])
              (set! retained-cr cr)
              (reset-cr cr)
              cr))))

    (define/override (release-cr cr)
      (when (zero? flush-suspends)
        (queue-backing-flush)))

    (define flush-suspends 0)
    (define req #f)

    (define/public (request-delay) (void))
    (define/public (cancel-delay req) (void))

    (define/override (suspend-flush) 
      (atomically
       (when (zero? flush-suspends)
         (when req (cancel-delay req))
         (set! req (request-delay)))
       (set! flush-suspends (add1 flush-suspends))))

    (define/override (resume-flush)  
      (atomically 
       (unless (zero? flush-suspends)
         (set! flush-suspends (sub1 flush-suspends))
         (when (zero? flush-suspends)
           (queue-backing-flush)))))

    (define/public (end-delay)
      ;; call in atomic mode
      (when (and (zero? flush-suspends) req)
        (cancel-delay req)
        (set! req #f)))))

(define (get-backing-bitmap make-bitmap w h)
  (make-bitmap w h))

(define (release-backing-bitmap bm)
  (send bm release-bitmap-storage))