Another Patch to STk-3.0b1...

From: Moises Lejter <mlm_at_cs.brown.edu>
Date: Wed, 6 Dec 1995 04:10:20 -0500 (EST)

I found that the support for dragging items in a Canvas in STklos was
broken. Applying the patch below got it working again, for me...
The resulting code is less efficient than the original version, but I
found it easier to understand... ;-)

Moises

-----cut here-----

*** /tmp/T0a001QR Wed Dec 6 04:07:44 1995
--- Canvas.stk Wed Dec 6 04:03:00 1995
***************
*** 260,270 ****
  ;; ;; Apply user :start hook
  ;; (apply (car stk::hooks) stk::instance-selected x y '())))
  
! (define (stk::start-drag key w x y tag)
! (let ((instance (Id->instance w))
! (tag (or tag (car (w 'find 'with 'current)))))
! (w 'dtag 'selected)
! (w 'addtag 'selected 'with tag)
      (set! stk::last-x x)
      (set! stk::last-y y)
      (set! stk::instance-selected (Cid->instance instance tag))
--- 260,269 ----
  ;; ;; Apply user :start hook
  ;; (apply (car stk::hooks) stk::instance-selected x y '())))
  
! (define (stk::start-drag key instance x y tag)
! (let ((tag (or tag (car (w 'find 'with 'current)))))
! (delete-tag instance 'selected)
! (add-tag instance 'selected 'with tag)
      (set! stk::last-x x)
      (set! stk::last-y y)
      (set! stk::instance-selected (Cid->instance instance tag))
***************
*** 280,286 ****
  ;;;
  ;;;
  ;;;
! (define (stk::motion-drag w x y)
    (move stk::instance-selected (- x stk::last-x) (- y stk::last-y))
    (set! stk::last-x x)
    (set! stk::last-y y)
--- 279,285 ----
  ;;;
  ;;;
  ;;;
! (define (stk::motion-drag instance x y)
    (move stk::instance-selected (- x stk::last-x) (- y stk::last-y))
    (set! stk::last-x x)
    (set! stk::last-y y)
***************
*** 290,297 ****
  ;;;
  ;;;
  ;;;
! (define (stk::stop-drag w x y)
! (w 'dtag 'selected)
    ;; Apply user :stop hook
    (apply (caddr stk::hooks) stk::instance-selected x y '()))
  
--- 289,296 ----
  ;;;
  ;;;
  ;;;
! (define (stk::stop-drag instance x y)
! (delete-tag instance 'selected)
    ;; Apply user :stop hook
    (apply (caddr stk::hooks) stk::instance-selected x y '()))
  
***************
*** 299,307 ****
  ;;;
  ;;;
  (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))
--- 298,304 ----
  ;;;
  ;;;
  (define-method bind-for-dragging ((self <Canvas>) . args)
! (let* ((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))
***************
*** 310,319 ****
           (motion (format #f "<~AB~A-Motion>" str but))
           (stop (format #f "<~AButtonRelease-~A>" str but)))
  
! (Id 'bind who start `(stk::start-drag ,start ,w %x %y
! ',(if alone #f who)))
! (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)
--- 307,316 ----
           (motion (format #f "<~AB~A-Motion>" str but))
           (stop (format #f "<~AButtonRelease-~A>" str but)))
  
! (bind self who start
! (lambda (x y) (stk::start-drag start self x y (if alone #f who))))
! (bind self who motion (lambda (x y) (stk::motion-drag self x y)))
! (bind self who stop (lambda (x y) (stk::stop-drag self x y)))
  
      ;; See if user want to set some movement hooks
      (hash-table-put! (slot-ref self 'bindings)

-----cut here-----
Received on Wed Dec 06 1995 - 10:14:20 CET