;;;;
;;;; C a n v a s . s t k 	  --  Canvas class definition
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works.  Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.  
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
;;;;    Creation date: 18-Aug-1993 19:55
;;;; Last file update:  8-May-1995 18:53

(require "Basics")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Canvas class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class <Canvas> (<Tk-simple-widget> <Tk-sizeable> <Tk-xyscrollable> 
			<Tk-editable>)
  ((items 	     :initform    (make-hash-table))
   (bindings	     :initform	  (make-hash-table))
   (close-enough     :init-keyword     :close-enough
		     :accessor    close-enough
		     :tk-name     closeenough
		     :allocation :tk-virtual)
   (confine 	     :init-keyword     :confine
		     :accessor    confine
		     :allocation :tk-virtual)
   (scroll-increment :init-keyword     :scroll-increment
		     :accessor    scroll-increment
		     :tk-name     scrollincrement
		     :allocation :tk-virtual)
   (scroll-region    :init-keyword     :scroll-region
		     :accessor    scroll-region
		     :tk-name     scrollregion
		     :allocation :tk-virtual)))

(define-method tk-constructor ((self <Canvas>))
  Tk:canvas)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Utilities
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;; tag-value delivers the integer Id of an object. A method for canvas items 
;; will be defined later
(define-method tag-value ((object <top>))
  (if (or (symbol?  object) (integer? object) (string?  object))
      object
      (error "**** object ~A is not contained in a canvas" object)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Canvas> methods
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;
;;; Add-tag
;;;
(define-method add-tag ((self <Canvas>) tag . args)
  (apply (slot-ref self 'Id) 'addtag tag args))

;;;
;;; Bounding-box
;;;
(define-method bounding-box ((self <Canvas>) tag)
  ((slot-ref self 'Id) 'bbox (tag-value tag)))
 
;;;
;;; Bind
;;;
(define-method canvas-bind ((self <Canvas>) tag-or-Id . args)
  (apply (slot-ref self 'Id) 'bind  (tag-value tag-or-Id) args))

;;;
;;; Canvas-x
;;;
(define-method canvas-x ((self <Canvas>) screenx . args)
  (apply (slot-ref self 'Id) 'canvasx screenx args))

;;;
;;; Canvas-y
;;;
(define-method canvas-y ((self <Canvas>) screeny . args)
  (apply (slot-ref self 'Id) 'canvasy screeny args))

;;;
;;; Coords et (setter coords)
;;;
(define-method coords ((self <Canvas>) tag-or-Id)
  ((slot-ref self 'Id) 'coords (tag-value tag-or-Id)))

(define-method (setter coords) ((self <Canvas>) tag-or-Id  args)
  (apply (slot-ref self 'Id) 'coords (tag-value tag-or-Id) args))

;;;
;;; Delete-chars
;;;
(define-method delete-chars ((self <Canvas>) tag-or-Id first . last)
  (apply (slot-ref self 'Id) 'dchars (tag-value tag-or-Id) first last))

;;;
;;; Delete (BUG. This procedure doesn't clean the hash table).....
;;;
(define-method delete ((self <Canvas>) . args)
  (apply (slot-ref self 'Id) 'delete (map tag-value args)))

;;;
;;; Delete-tag
;;;
(define-method delete-tag ((self <Canvas>) tag-or-Id . tag-to-delete)
  (apply (slot-ref self 'Id) 'dtag (tag-value tag-or-Id) tag-to-delete))


;;;
;;; Find-items
;;;
(define-method find-items ((self <Canvas>) . args)
  (map (lambda (x) (Cid->instance self x))
       (apply (slot-ref self 'Id) 'find  args)))

;;;
;;; Focus
;;;
(define-method focus ((self <Canvas>))
  (Cid->instance self ((slot-ref self 'Id) 'focus)))

(define-method focus ((self <Canvas>) tag-or-id)
  ((slot-ref self 'Id) 'focus (tag-value tag-or-id)))

;;;
;;; Get-tags
;;;
(define-method get-tags ((self <Canvas>) tag-or-Id)
  ((slot-ref self 'Id) 'gettags (tag-value tag-or-Id)))

;;;
;;; Icursor
;;;
(define-method icursor ((self <Canvas>) tag-or-id index)
  ((slot-ref self 'Id) 'icursor (tag-value tag-or-Id) index))

;;;
;;; Index
;;;
(define-method text-index ((self <Canvas>) tag-or-id index)
  ((slot-ref self 'Id) 'index (tag-value tag-or-Id) index))

;;;
;;; Insert
;;;
(define-method text-insert ((self <Canvas>) tag-or-id before string)
  ((slot-ref self 'Id) 'insert  (tag-value tag-or-Id) before string))

;;;
;;; Lower
;;; 
(define-method lower ((self <Canvas>) tag-or-Id . below)
  (apply (slot-ref self 'Id) 'lower (tag-value tag-or-Id) (map tag-value below)))

;;;
;;; Move
;;;
(define-method move ((self <Canvas>) tag-or-Id x y)
  ((slot-ref self 'Id) 'move (tag-value tag-or-Id) x y))

;;;
;;; Postscript
;;;
(define-method postscript ((self <Canvas>) . args)
  (apply (slot-ref self 'Id) 'postscript args))

;;;
;;; Raise
;;;
(define-method raise ((self <Canvas>) tag-or-Id . above)
  (apply (slot-ref self 'Id) 'raise (tag-value tag-or-Id) (map tag-value above)))

;;;
;;; Rescale
;;;
(define-method rescale ((self <Canvas>) tag-or-Id x y xs ys)
  ((slot-ref self 'Id) 'scale (tag-value tag-or-Id) x y xs ys))

;;;
;;; Scan
;;;
(define-method scan ((self <Canvas>) option x y)
  ((slot-ref self 'Id) 'scan option x y))

;;;
;;; Text-selection
;;;
(define-method text-selection ((self <Canvas>) . args)
  (apply (slot-ref self 'Id) 'select args))

;;;;;; item-type can be obtained by (class-name(class-of xxx))

;;;
;;; x-view
;;;
(define-method x-view ((self <Canvas>) index)
  ((slot-ref self 'Id) 'xview index))

;;;
;;; y-view
;;;
(define-method y-view ((self <Canvas>) index)
  ((slot-ref self 'Id) 'yview index))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; bind-for-drag
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define stk::last-x 		0)
(define stk::last-y 		0)
(define stk::instance-selected '())
(define stk::hooks  	       '())

;;;
;;;
;;;
;; (define (stk::start-drag key w x y tag)
;;   (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 key)))
;; 
;;     ;; 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))
    (raise stk::instance-selected)

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

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

;;;
;;;
;;;
(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)
  ;; Apply user :motion hook
  (apply (cadr stk::hooks) stk::instance-selected x y '()))

;;;
;;;
;;;
(define (stk::stop-drag w x y)
  (w 'dtag 'selected)
  ;; Apply user :stop hook
  (apply (caddr 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)))

    (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)
		     (string->symbol start)
		     (list (get-keyword :start  args list)
			   (get-keyword :motion args list)
			   (get-keyword :stop   args list)))))

(require "Canvitem")
(provide "Canvas")