;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; bind-for-dragging
;;;;
:;;; You can specify a :start, :before-motion, :after-motion, and :stop scripts
;;;; If :before-motion returns #f the the object is not displaced and the
;;;; :after-motion closure is not applied.
;;;;
;;;; Old :motion hook is equivalent to :after-motion but its use is deprecated
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-generic bind-for-dragging)
(let ()
  (define last-x 		   0)
  (define last-y 		   0)
  (define instance-selected '())

  (define (start-drag instance x y closure tag)
    (let ((tag (or tag (car ((slot-ref instance 'Id) 'find 'with 'current)))))
      (delete-tag instance 'selected)
      (add-tag instance 'selected 'with tag)
      (raise instance 'selected)
      (set! last-x x)
      (set! last-y y)
      (set! instance-selected (Cid->instance instance tag))
      ;; Apply user :start hook
      (if closure
	  (closure instance-selected x y))))
  
  (define (motion-drag instance x y before after)
    (let ((continue #t))
      ;; Apply user :before-motion hook
      (if before 
	  (set! continue (before instance-selected x y)))
      (when continue 
	(move instance 'selected (- x last-x) (- y last-y))
	(set! last-x x)
	(set! last-y y)
	;; Apply user :before-motion hook
	(if after 
	    (after instance-selected x y)))))
  
  (define (stop-drag instance x y closure)
    (delete-tag instance 'selected)
    ;; Apply user :stop hook
    (if closure 
	(closure instance-selected x y)))

  (add-method bind-for-dragging (method ((self <Canvas>) . args)
    (let* ((Id     (slot-ref self '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  (get-keyword :start args #f))
	   (before (get-keyword :before-motion args #f))
	   (after  (get-keyword :after-motion args (get-keyword :motion args #f)))
	   (stop   (get-keyword :stop args #f)))
      
      ;; Start binding
      (bind self who (format #f "<~AButtonPress-~A>" str but) 
	    (lambda (x y) (start-drag self x y start (if alone #f who))))
      ;; Motion binding
      (bind self who (format #f "<~AB~A-Motion>" str but)
	    (lambda (x y) (motion-drag self x y before after)))
      ;; Stop binding
      (bind self who (format #f "<~AButtonRelease-~A>" str but)
	    (lambda (x y) (stop-drag self x y stop)))))))