Fix for bind-for-dragging

From: David McClain <Dave_McClain_at_msn.com>
Date: Mon, 25 Mar 96 06:53:42 UT

In response to some traffic received here regarding a "bug" in
bind-for-dragging, here is a simple fix... I consists of forming a unique hash
key for each tag and passing this key along with the start message for
dragging...

;;; Code extracted from Canvas.stk from Version 2.1.6 release

(define (stk::start-drag key w x y tag tkey) ;;; <-- NEW
  (let ((instance (Id->instance w)))
    (w 'dtag 'selected)
    (w 'addtag 'selected 'with (or tag 'current))
    (w 'raise (or tag 'current))
    (set! stk::last-x x)
    (set! stk::last-y y)
    (set! stk::instance-selected (Cid->instance instance
                                                (car (w 'find 'withtag 'selected))))

    ;; Set! stk::hooks to the hooks setted for this binding
    (set! stk::hooks (hash-table-get (slot-ref instance 'bindings)
                                     (string->symbol tkey))) ;;; <-- NEW

    ;; Apply user :start hook
    (apply (car stk::hooks) stk::instance-selected x y '())))

(define-method bind-for-dragging ((self <Canvas>) . args)
  (let* ((Id (slot-ref self 'Id))
         (w (widget-name Id))
         (who (tag-value (get-keyword :tag args 'all)))
         (but (get-keyword :button args 1))
         (mod (get-keyword :modifier args ""))
         (alone (get-keyword :only-current args #t))
         (str (if (equal? mod "") "" (string-append mod "-")))
         (start (format #f "<~AButtonPress-~A>" str but))
         (motion (format #f "<~AB~A-Motion>" str but))
         (stop (format #f "<~AButtonRelease-~A>" str but))
         (tkey (format #f "~A+~A" who start))) ;;; <-- NEW

    (Id 'bind who start `(stk::start-drag ,start ,w %x %y
                                            ',(if alone #f who)
                                            ,tkey)) ;;; <-- NEW
    (Id 'bind who motion `(stk::motion-drag ,w %x %y))
    (Id 'bind who stop `(stk::stop-drag ,w %x %y))

    ;; See if user want to set some movement hooks
    (hash-table-put! (slot-ref self 'bindings)
                     (string->symbol tkey) ;;; <-- NEW
                     (list (get-keyword :start args list)
                           (get-keyword :motion args list)
                           (get-keyword :stop args list)))))

;;; ------------------------ ( Now test it out using Jon Berry's Example...)
------------

(require "Canvas")

(define c (make <Canvas>))
(pack c)

(define o1 (make <oval> :parent c :coords '(10 10 20 20 ) :fill "blue"))
(define o2 (make <oval> :parent c :coords '(30 30 40 40 ) :fill "red"))

(bind-for-dragging c :tag (cid o1) :motion (lambda (w x y) (display "1\n")))
(bind-for-dragging c :tag (cid o2) :motion (lambda (w x y) (display "2\n")))


;;; --------------------

The result now works as Jon Berry would expect it to... However, is this what
was
intended?

Very nice work, Eric! I really love STk!!!
:-)
David McClain, Anaphoric Engineering, L.L.C.
Tucson, AZ
Received on Tue Mar 26 1996 - 09:22:06 CET