Dear list, the attached program draws a grid in a canvas and paints a few of the cells so created. When resizing the window, the grid is also dynamically resized together with the coloring of a few painted cells. Everything seems to work fine, except that while the window is being changed in size the drawing is off and the colored cells do not properly correspond to the drawn grid. You can see this especially well if you hold down the mouse button after resizing. When releasing it the grid lines will change position to match up once more with the colorings.
Marijn
#lang racket/gui
;;; multi-dimensional arrays
(require srfi/25)
(define cell-editor%
(class text%
(init)
(super-new)
))
(define cell-editor-admin%
(class editor-admin%
(init-field grid row column editor)
(super-new)
(define blinker
(new timer% (notify-callback (lambda () (send editor blink-caret)))))
(define/public (start-caret-blinking interval)
(send blinker start interval))
(define/public (stop-caret-blinking)
(send blinker stop))
(define/public (on-char char)
(send editor on-char char))
(define/public (on-focus on?)
(if on?
(send blinker start 500)
(send blinker stop))
(send editor on-focus on?))
(define/public (redraw-editor)
(send editor
refresh
0 0
(send grid get-cell-pixel-width) (send grid get-cell-pixel-height)
(if (eq? this (send grid get-active-admin))
'show-caret
'no-caret)
#f))
(define/override (get-dc (x #f) (y #f))
(when x (set-box! x (- -2 (send grid column->x column))))
(when y (set-box! y (- -2 (send grid row->y row))))
(send grid get-dc) )
(define/override (get-max-view x y w h (full? #f))
(get-view x y w h full?))
(define/override (get-view x y w h (full? #f))
(when x (set-box! x 0))
(when y (set-box! y 0))
(when w (set-box! w (send grid get-cell-pixel-width)))
(when h (set-box! h (send grid get-cell-pixel-height))) )
(define/override (grab-caret (domain 'global))
(when (eq? domain 'global)
(send grid set-focus)))
(define/override (modified modified?)
(values))
(define/override (needs-update x y w h)
(send grid refresh))
(define/override (popup-menu menu x y)
#f)
(define/override (refresh-delayed?)
#f)
(define/override (resized refresh?)
(send grid refresh)) ;; only when refresh? arg ?
(define/override (scroll-to x y w h (refresh? #t) (bias 'none))
(send grid refresh)) ;; necessary ?
(define/override (update-cursor)
(values))
))
(define grid%
(class canvas%
(init-field nr-rows nr-columns)
(init parent
(min-height 0) (min-width 0)
(stretchable-height #t) (stretchable-width #t))
(define cell-char-width 5)
(define cell-char-height 1)
(super-new (parent parent)
(min-height min-height) (min-width min-width)
(stretchable-height stretchable-height) (stretchable-width
stretchable-width))
(define dc (send this get-dc))
(define char-width-scale 1)
(define char-height-scale 1.3)
(define (char-width) (* (send dc get-char-width) char-width-scale))
(define (char-height) (* (send dc get-char-height) char-height-scale))
(display "char-width: ") (displayln (char-width))
(display "char-height: ") (displayln (char-height))
(define (cell-pixel-width) (inexact->exact (ceiling (* cell-char-width
(char-width)))))
(define (cell-pixel-height) (inexact->exact (ceiling (* cell-char-height
(char-height)))))
(define (cell+border-pixel-width) (+ (cell-pixel-width) 1))
(define (cell+border-pixel-height) (+ (cell-pixel-height) 1))
(define/public (get-cell-pixel-width) (cell-pixel-width))
(define/public (get-cell-pixel-height) (cell-pixel-height))
(define (window-height) (+ 1 (* nr-rows (cell+border-pixel-height))))
(define (window-width) (+ 1 (* nr-columns (cell+border-pixel-width))))
; (display "window-width: ") (displayln window-width)
; (display "window-height: ") (displayln window-height)
;;; set window size
(send this min-width (max min-width (window-width)))
(send this min-height (max min-height (window-height)))
(define (x->column x)
(inexact->exact (floor (/ x (cell+border-pixel-width)))))
(define (y->row y)
(inexact->exact (floor (/ y (cell+border-pixel-height)))))
(define/public (column->x column)
(* column (cell+border-pixel-width)))
(define/public (row->y row)
(* row (cell+border-pixel-height)))
(define (paint-cell row column color)
(send dc set-pen "" 1 'transparent)
(send dc set-brush color 'solid)
(send dc draw-rectangle
(column->x column) (row->y row)
(cell-pixel-width) (cell-pixel-height)) )
(define (write-cell row column text)
(define x (column->x column))
(define y (row->y row))
(send dc set-clipping-rect x y (cell-pixel-width) (cell-pixel-height))
; (send dc get-text-extent text)
(send dc draw-text text x y)
(send dc set-clipping-region #f))
(define/override (on-size width height)
;(display "width ")(displayln width)
;(display "height ")(displayln height)
(set! cell-char-width (/ width nr-columns (char-width)))
(set! cell-char-height (/ height nr-rows (char-height))) )
(define/override (on-paint)
(send dc set-pen "black" 1 'solid)
;;; draw vertical grid lines
(for ((c (in-range 1 nr-columns)))
(let ((x (- (* c (cell+border-pixel-width)) 1)))
(send dc draw-line x 0 x (window-height))))
;;; draw horizontal grid lines
(for ((r (in-range 1 nr-rows)))
(let ((y (- (* r (cell+border-pixel-height)) 1)))
(send dc draw-line 0 y (window-width) y)))
;;; draw grid contents
(for* ((r (in-range 0 nr-rows))
(c (in-range 0 nr-columns)) )
(send (array-ref admins r c) redraw-editor) )
(paint-cell 1 1 (make-object color% 200 100 50 1.0))
(paint-cell 5 5 (make-object color% 50 200 100 1.0))
(paint-cell 2 3 (make-object color% 50 50 200 1.0))
)
(define/override (on-event event)
(define column (x->column (send event get-x)))
(define row (y->row (send event get-y)))
(define type (send event get-event-type))
(case type
((motion)
(if (send event dragging?)
(handle-dragging event)
(handle-motion event)))
((left-down)
(handle-left-down event row column)) ))
(define/override (on-char char)
(send active-admin on-char char))
(define/override (on-focus on?)
(send active-admin on-focus on?)
(send this refresh)
)
(define (handle-dragging event)
(print event))
(define (handle-motion event)
#f)
(define (change-active-cell row column)
(send active-admin on-focus #f)
(set! active-admin (array-ref admins row column))
(send active-admin on-focus #t) )
(define (handle-left-down event row column)
(change-active-cell row column)
; (paint-cell row column (make-object color% 50 50 200 1.0)))
#;(write-cell row column "ÃFjgG30093") )
(define admins (make-array (shape 0 nr-rows 0 nr-columns)))
(for* ((r (in-range 0 nr-rows))
(c (in-range 0 nr-columns)) )
(define editor (new cell-editor%))
(define admin (new cell-editor-admin% (grid this) (editor editor) (row r)
(column c)))
(array-set! admins r c admin)
(send editor set-admin admin) )
(define active-admin (array-ref admins 0 0))
(define/public (get-active-admin)
active-admin)
))
(define root (new frame% (label "Grid Test")))
(define grid
(new grid%
(parent root)
(nr-rows 4) (nr-columns 5)
(min-width 50) (min-height 50)
(style '(border resize-corner) #;'(combo control-border))))
(send root show #t)
signature.asc
Description: OpenPGP digital signature
_________________________________________________ For list-related administrative tasks: http://lists.racket-lang.org/listinfo/dev
