Simple stress test for canvas speed

canvas-speed.rkt

#lang racket/base

(require racket/gui/base
         racket/class
         racket/format)

(define NUM-CELL-X 100)
(define NUM-CELL-Y 100)
(define CELL-SIZE 2)
(define XMAX (* NUM-CELL-X CELL-SIZE))
(define YMAX (* NUM-CELL-Y CELL-SIZE))

(define NUM-FRAMES 10)

(define no-pen (make-object pen% "BLACK" 1 'transparent))
(define brush-red  (make-object brush% "red"  'solid))
(define brush-blue (make-object brush% "blue" 'solid))

(define (draw-to-dc dc)
  (send dc set-pen no-pen)
  (for* ([x (in-range NUM-CELL-X)] [y (in-range NUM-CELL-Y)])
    (send dc set-brush (if (= 0 (random 2)) brush-red brush-blue))
    (send dc draw-rectangle
          (* x CELL-SIZE) (* y CELL-SIZE)
          CELL-SIZE CELL-SIZE)))

(define fr (new frame% [label "test"]))
(define cv (new canvas% [parent fr]
                [min-width XMAX] [min-height XMAX]
                [style '(no-autoclear)]
                [paint-callback
                 (λ(cv dc)
                   #;(draw-to-dc dc)
                   (send dc draw-bitmap bmp 0 0))]))

(define bmp (send cv make-bitmap XMAX YMAX))
(define bmp-dc (new bitmap-dc% [bitmap bmp]))

(send fr show #t)

(collect-garbage)
(collect-garbage)

(define-values
  (lres ms-cpu ms-real ms-gc)
  (time-apply 
   (λ()
     (for ([i (in-range NUM-FRAMES)])
       #;(send bmp-dc set-bitmap bmp)
       (draw-to-dc bmp-dc)
       #;(send bmp-dc set-bitmap #f)
       
       (send cv refresh-now)
       (sleep/yield .01)))
   '()))

(printf "cpu: ~a\treal: ~a\tgc: ~a\tms/frame: ~a\tframe/sec: ~a\n"
        ms-cpu ms-real ms-gc
        (quotient ms-cpu NUM-FRAMES)
        (~r (/ (* 1000. NUM-FRAMES) ms-cpu) #:precision 3))

(send fr show #f)