#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)

(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%
    ;; Inherit superclass methods
    (inherit min-client-width)
    (inherit min-client-height)
    (inherit refresh)
    ;; Instantiate superclass
    (super-instantiate ())
    ;; Create bitmaps
    (define bitmap-vector
      (let ((w (min-client-width))
            (h (min-client-height)))
        (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 bitmaps
      (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))
      ;; Refresh the canvas
      (refresh)
      (yield))
    ;; Override the superclass get-dc method to return the bitmap-dc of the
    ;; to bitmap.
    (define/override (get-dc)
      to-bitmap-dc)
    ;; Override the superclass on-paint method to move the from-bitmap to the
    ;; canvas.
    (define/override (on-paint)
      (let ((canvas-dc (super get-dc)))
        (send canvas-dc draw-bitmap
              (vector-ref bitmap-vector from-bitmap) 0 0)))))