

(define-class <vertex-object> (<Tk-canvas-figure>) ())


(define-class <guarded-oval> (<vertex-object>)    
  ((fill    :getter fill      :init-keyword :fill    :allocation :tk-virtual)
   (parent  :accessor parent  :init-keyword :parent)
   (vertex  :accessor vertex  :init-keyword :vertex) 
   (outline :accessor outline :init-keyword :outline :allocation :tk-virtual)
   (stipple :accessor stipple :init-keyword :stipple :allocation :tk-virtual)
   (tags    :accessor tags    :init-keyword :tags    :allocation :tk-virtual)
   (vertex-label :initform "v" :accessor vertex-label 
                               :init-keyword :vertex-label)
   (color :initform *link:default-vertex-color* :accessor color
                 :init-keyword :color
                 :allocation :virtual
                 :slot-ref (lambda (o)
                                (let* ((clr (find-string-attribute
                                        'color
                                        (slot-ref o 'vertex))))
                                    (slot-set! o 'fill clr)
                                    clr))
                 :slot-set! (lambda (o c)
                                (set-string-attribute!
                                        'color
                                        c
                                        (slot-ref o 'vertex))
                                (slot-set! o 'fill c)))
   (width   :accessor width   :init-keyword :width   :allocation :tk-virtual)))


(define-method initialize-item ((self <guarded-oval>) canvas coords args)
  (define v (eval `(apply ,canvas 'create 'oval ,@coords
                ',(get-keyword :tk-options args '()))))
  (slot-set! self 'cid v)
  (slot-set! self 'tags '("vertex"))
  v
)

(define-generic guarded-oval?)
(define-method  guarded-oval? ((o <guarded-oval>)) #t)
(define-method  guarded-oval? ((o <top>)) #f)


(define-class <my-image-item> (<Tk-composite-item> <vertex-object>) 
   ((image-object		:accessor	image-object)
    (rectangle-object		:accessor 	rectangle-object)
    (xpixels			:accessor 	xpixels)
    (ypixels			:accessor 	ypixels)
    (coords			:getter		coords
				:allocation	:virtual
				:slot-ref	(lambda (o)
						   (slot-ref 
						     (slot-ref o 'image-object)
						     'coords))
				:slot-set!	(lambda (o l)
						   (let* ((io (slot-ref o 
								'image-object))
							  (ro (slot-ref o
							     'rectangle-object))
							  (x (car l))
							  (y (cadr l))
							  (xpixels (slot-ref o
								     'xpixels))
							  (ypixels (slot-ref o
								     'ypixels))
							  (xos (quotient 
								 xpixels 2))
							  (yos (quotient 
								 ypixels 2)))
						       (set! (coords io) l)
						       (set! (coords ro)
					                  (list (- x xos)
                                                                (- y yos)
					                        (+ x xos)
                                                                (+ y yos))))))
    (color			:accessor color
				:init-keyword :color
				:allocation   :propagated
				:propagate-to ((rectangle-object outline)))
    (stipple			:accessor stipple
				:init-keyword :stipple
				:allocation   :propagated
				:propagate-to (rectangle-object))
    (width			:accessor width
				:init-keyword :width
				:allocation   :propagated
				:propagate-to (rectangle-object))
    (outline			:accessor outline
				:init-keyword :outline
				:allocation   :propagated
				:propagate-to ((rectangle-object outline)))


   )
)

(define-method initialize-item ((self <my-image-item>) canvas coords args)
  (let* ((vcolor      (get-keyword :color args *link:default-vertex-color*))
         (xpix        (get-keyword :xpixels args))
         (ypix        (get-keyword :ypixels args))
	 (xos         (quotient xpix 2)) 
	 (yos         (quotient ypix 2)) 
         (x           (car coords))
         (y           (cadr coords))
         (img 	      (make <photo-image> :file (get-keyword :file args 
				"/home/berryj/link/stklos/todd.gif")))
	 (parent      (get-keyword :parent args))
         (ti2 (make <image-item> :parent parent :image-name img
                      :coords (list x y)))
	 (rect (make <rectangle> :parent parent :outline vcolor
		      :coords (list (- x xos) (- y yos) (+ x xos) (+ y yos))))
         (Cid         (my-gensym "my-image-item")))

    (slot-set! self 'Cid Cid)
    (slot-set! self 'image-object ti2)
    (slot-set! self 'rectangle-object rect)
    (slot-set! self 'xpixels xpix)
    (slot-set! self 'ypixels ypix)

    (add-to-group self ti2 rect)
    (bind-for-dragging parent
                :tag (slot-ref (slot-ref self 'vertex-object) 'cid)
                :button 1
                :only-current #f
                :start start-vertex-drag
                :motion find-and-update-vertex-item
                :stop stop-vertex-drag)
    Cid))



(define-class <test-vertex-item> ()
   ((vertex-object            :accessor vertex-object)
))

(define-generic vertex-object?)
(define-method vertex-object? ((v <vertex-object>))
	(describe v)
	#t)

(define-method vertex-object? ((v <top>))
	#f)

(define-generic move-vertex)
(define-method move-vertex ((go <guarded-oval>) (x <integer>) (y <integer>)
                             (sz <integer>))
	(let ((offset (quotient sz 2)))
               (slot-set! go 'coords (list (- x offset) (- y offset)
                                           (+ x offset) (+ y offset)))))

 (define-method move-vertex ((go <Image-item>) (x <integer>) (y <integer>)
				(sz <integer>))
	(slot-set! go 'coords (list x y)))

(define-generic vertex-object-coords)
(define-method vertex-object-coords ((ov <guarded-oval>) (sz <integer>))
     (let* ((cs (slot-ref ov 'coords))
            (os (quotient sz 2))
            (x1 (+ (list-ref cs 0) os))
            (y1 (+ (list-ref cs 1) os)))
         (list x1 y1)))

(define-method vertex-object-coords ((im <my-image-item>) (sz <integer>))
	(slot-ref im 'coords))

(define-generic set-vertex-object-coords!)
(define-method set-vertex-object-coords! ((ov <guarded-oval>) 
				   (x <number>) (y <number>)
                                   (sz <integer>))
      (let* ((os (quotient sz 2)))
         (set! (coords ov) (list (- x os)
                                 (- y os)
                                 (+ x os)
                                 (+ y os)))))

(define-method set-vertex-object-coords! ((im <my-image-item>) 
				   (x <number>) (y <number>)
                                   (sz <integer>))
	(set! (coords im) (list x y)))

;;-------------------------------------------------------------------
;; to include photos:
;
;(define gv (show-graph (graph)))
;(define gt (slot-ref gv 'graph-toplevel))
;(define gc (slot-ref gv 'graph-canvas))

;(define img (make <Photo-image> :file "todd.gif"))
;
;
;(define ti (make <Image-item> :parent gc :image-name img
;                      :coords '(100 100)))
;(define ti2 (make <my-image-item> :parent gc :image-name img
;                      :coords '(100 100)))
;
;(bind-for-dragging gc :tag (cid ti2))
;(define erri (make <Bitmap-item> :parent gc :bitmap-name "error"
;                      :coords '(20 20)))
;
;(bind-for-dragging gc :tag (cid ti))
;(bind-for-dragging gc :tag (cid erri))
;
;----------------------------------------------------------------------
;

(provide "vertex-object")
