#lang scheme/gui
;; animated-canvas.ss
;; Copyright (c) 2007-2008 M. Douglas Williams
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free
;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;; 02111-1307 USA.
;;
;; -------------------------------------------------------------------
;;
;; Version  Date      Description
;; 1.0.0    12/28/07  Initial release. (Doug Williams)
;; 2.0.0    09/02/08  Updated for PLT Scheme 4.0.  (Doug Williams)
;; 2.0.1    09/25/08  Added no-autoclear and transparent processing.
;;                    (Doug Williams)
;; 2.0.2    09/25/08  Added resizing.  (Doug Williams)

(provide (all-defined-out))

;; class animated-canvas%
;; Implements a canvas that supports offscreen bitmaps for animation. Works
;; like a standard canvas% object, but the device context points to the
;; appropriate bitmap-dc% for drawing. A call to swap-bitmaps swaps the
;; bitmaps and paits the old one.  [The device context is not valid across
;; calls to swap-bitmap.]
(define animated-canvas%
  (class canvas%
    ;; Init parameters (shadows those from csnvas%)
    ;; so we can manipulate no-autoclear
    (init parent)
    (init (style '()))
    ;; Save animated-canvas no-autoclear and transparent style
    (define no-autoclear? (if (memq 'no-autoclear style) #t #f))
    (define transparent? (if (memq 'transparent style) #t #f))
    ;; Instantiate superclass with updated no-autoclear and transparent
    ;; arguments
    (set! style (if no-autoclear? style (cons 'no-autoclear style)))
    (set! style (remq 'transparent style))
    (super-instantiate (parent) (style style))
    ;; Inherit superclass methods
    (inherit get-client-size)
    (inherit refresh)
    ;; Create bitmaps
    (define bitmap-vector
      (let-values (((w h) (get-client-size)))
        (build-vector
         2
         (lambda (i)
           (make-object bitmap% w h)))))
    ;; Create from and to bitmap indices
    (define from-bitmap 0)
    (define to-bitmap 1)
    ;; Create from and to device contexts
    (define from-bitmap-dc (make-object bitmap-dc%))
    (define to-bitmap-dc (make-object bitmap-dc%))
    ;; Initialize from and to indices
    (send from-bitmap-dc set-bitmap (vector-ref bitmap-vector from-bitmap))
    (send to-bitmap-dc set-bitmap (vector-ref bitmap-vector to-bitmap))
    ;; Clear the from bitmap so the canvas initially is white.
    (send from-bitmap-dc clear)
    (send to-bitmap-dc clear)
    ;; Swap the bitmaps
    (define/public (swap-bitmaps)
      ;; Reset bitmap-dc instances
      (send from-bitmap-dc set-bitmap #f)
      (send to-bitmap-dc set-bitmap #f)
      ;; Swap bitmap indices
      (set! from-bitmap (modulo (+ from-bitmap 1) 2))
      (set! to-bitmap (modulo (+ to-bitmap 1) 2))
      ;; Set bitmap-dc instances
      (send from-bitmap-dc set-bitmap (vector-ref bitmap-vector from-bitmap))
      (send to-bitmap-dc set-bitmap (vector-ref bitmap-vector to-bitmap))
      ;; Check for client resize and make new bitmap if necessary
      (let-values (((w h) (get-client-size)))
        (let ((bitmap (send to-bitmap-dc get-bitmap)))
          (unless (and (= w (send bitmap get-width))
                       (= h (send bitmap get-height)))
            (vector-set! bitmap-vector to-bitmap (make-object bitmap% w h))
            (send to-bitmap-dc set-bitmap (vector-ref bitmap-vector to-bitmap))
            )))
      ;; Clear the to-bitmap
      (unless no-autoclear?
        (send to-bitmap-dc clear))
      ;; Refresh the canvas
      (refresh)
      (yield))
    ;; Override the superclass get-dc method to return the bitmap-dc of the
    ;; to bitmap.
    (define/override-final (get-dc)
      to-bitmap-dc)
    ;; Override the superclass on-paint method to move the from-bitmap to the
    ;; canvas.
    (define/override-final (on-paint)
      (let ((canvas-dc (super get-dc)))
        (send canvas-dc draw-bitmap
              (vector-ref bitmap-vector from-bitmap) 0 0)))))