Graphics

This lesson matters of interactive graphics. We will build a draggable rectangle in a canvas.

By the way, we learn, how to use event-fields.

To load the Tk extensions, enter

(require-extension tk)
(start-tk)

First, we create and pack the canvas c1:

(define c1 (tk 'create-widget 'canvas))
(tk/pack c1 #:expand #t #:fill 'both)

Then, we create a rectangular item r1 of white color and red outline:

(define r1 (c1 'create 'rectangle 10 10 60 60))
(c1 'itemconfigure r1 #:fill 'white #:outline 'red)

We see the result:

We need variables to store the actual x and y position of the pointer and a procedure to initialise them:

(define pointer-x 0)
(define pointer-y 0)
(define (set-pointer! x y)
  (set! pointer-x x)
  (set! pointer-y y))

On mouse-click on rectangle r1, to store the actual pointer position, the procedure set-pointer! should be invoked with the event-fields %x and %y:

(c1 'bind r1 '<Button> `(,set-pointer! %x %y))

We need a procedure to move rectange r1:

(define (move-item canvas tag-or-id x y)
  (let ((dx (- x pointer-x))
        (dy (- y pointer-y)))
    (set-pointer! x y)
    (canvas 'move tag-or-id dx dy)))

While Button 1 is pressed, on mouse-move rectangle r1 should be dragged:

(c1 'bind r1 '<Button1-Motion>
    `(,(lambda (x y)
	 (move-item c1 r1 x y))
      %x %y))

All is prepared now, and we can enter the event loop:

(event-loop)

Now, we can drag the rectangle across the canvas. Have fun!

Note that the procedure move-item is designed so that the expression (canvas ‘move ...) is invoked on last position in the sequence, when the coordinates are already updated. This is important. While expecting the result of (canvas ‘move ...), the next event can trigger before the actual event has finished, and the new event needs the correct coordinates, too.

Another solution to this problem making it synchronous by a semaphore as following:

(define waiting #t)
(define (move-item canvas tag-or-id x y)
  (if waiting
      (fluid-let ((waiting #f))
	(let ((dx (- x pointer-x))
	      (dy (- y pointer-y)))
	  (set-pointer! x y)
	  (canvas 'move tag-or-id dx dy)))))

Now, any subsequent event triggered while move-item is still thinking will be ignored.

See also canvas, canvas create, canvas bind, event substitutions, canvas move.

© Author | Home | Sitemap