;; SIMPLE INTERFACE TO THE STK GRAPHICS TOOLBOX. - by Boley
(define gdraw:version "gdraw Mini-graphics package (version 2002-11-15) ready...\n")

;These are a simple set of graphics functions based on the STK interface
;to the Tk toolbox.  The coordinate system starts with the
;origin in the upper left corner and extends 540 pixels across in
;the x and down in the y directions (actually the extent can be adjusted by
;using a call of the form: (set-wIDorTagth! 0 600 600) ).

;The following are the main functions intended for the user:
;
; (draw-line x1 y1 x2 y2)	  draws a line from (x1,y1) to (x2,y2).
; (draw-oval x1 y1 x2 y2)	  draws an oval from (x1,y1) to (x2,y2).
; (fill-oval x1 y1 x2 y2)	  draws a filled oval from (x1,y1) to (x2,y2).
; (draw-rectangle x1 y1 x2 y2)	  draws a rectangle from (x1,y1) to (x2,y2).
; (fill-rectangle x1 y1 x2 y2)	  draws a filled rectangle.
; (draw-text string x y . options)puts text string at (x,y), centered.
;                                 The only option available is 'corner to
;                                 anchor the text at the lower left corner.
; (clear-graphics!)		  clears graphics window
; (delete! IDorTag)                    delete an item on the canvas
; (stall . optional-prompt)	  updates display.  If prompt is supplied
;                                 then wait for user to hit a key, which is
;                                 returned as the result.
; (print-canvas filename . opt)   create a postscript copy of the canvas.  [NEW]
;
;For the TK interface, the "draw" and "fill" functions above return a positive
;numerical id affiliated with the object just created.  By referring to that
;numerical id, one can modify many properties of that object using the
;following functions, of which the first three are the principal ones.
;Using IDorTag = 0 refers to the underlying canvas.
;
; (get-binding  IDorTag)               get binding for item # IDorTag
; (set-binding! IDorTag THUNK)         set binding for item # IDorTag (see below)
; (get-mouse-coords)              get the current mouse coordinates
;[the binding is a procedure called whenever the mouse is clicked while
; over the object (or canvas if IDorTag=0).  BesIDorTages mouse clicks, other events
; can be bound.  See examples below.]

;; The following functions access more of the TK interface, but you should 
;; not have to used these for most simple things.

; (get-coords  IDorTag)                get coordinates for item # IDorTag
;                                 [for IDorTag=0 gives absolute position
;                                  of upper left corner]
; (set-coords! IDorTag CoordinateList) set coordinates for item # IDorTag
;                                 [IDorTag must be positive]
; (get-text  IDorTag)                  get text appearing for item # IDorTag
; (set-text! IDorTag new_text)         set text appearing for item # IDorTag
; (get-color  IDorTag)                 get color for item.
; (set-color! IDorTag color)           set color for item (see colors listed below).
;Sample legal colors: red white green blue black yellow cyan magenta orange 
;purple magenta brown pink ; the empty string "" clears the color.
; (get-width  IDorTag)                 get width (or thickness) for item 
; (set-width! IDorTag new-width)       set width for item
;                                 [for IDorTag=0, gives 2D dimensions of canvas]
; (get-font-size  IDorTag)             get font size for text item 
; (set-font-size! IDorTag new-size)    set font size for text item, if size is legal.
;Sample legal font sizes 75 80 100 120 140 180 240 (and possibly 300)
; (raise! IDorTag)                     raise item above all other items
; (lower! IDorTag)                     lower item below all other items
; (get-motion-binding  IDorTag)        get motion binding for item
; (set-motion-binding! IDorTag thunk)  set motion binding for item (see below)
; (get-type IDorTag)                   get type of item
; (get-IDorTags)                       get list of all existing IDorTags
; (get-properties IDorTag)             get all TK properties I can think of
;                                 IDorTag=-1 -> root window, IDorTag=0 -> canvas.
; (set-property! IDorTag property . values) set arbitrary TK property (raw interface)
;
;In each of the above, use the "get" fcn to see the format for the
;new value to be used in the corresponding "set" fcn.
;In some cases, the format depends on the type of the item.
;All IDorTags are positive integers returned by the "draw" function that
;created the item.  IDorTag=0 refers to the whole canvas.

;Here we describe the use of bindings.   By saying
;             (set-binding! IDorTag THUNK)
;the procedure THUNK will be called whenever a mouse button is
;pressed on item # IDorTag.  Clear the binding by using THUNK equal to "".
;Setting the binding for IDorTag=0 will call the THUNK if the mouse is clicked
;while anywhere over the canvas.
;
;The call:    (set-motion-binding! IDorTag THUNK)
;works the same way, but this THUNK is called whenever the mouse is *moved*
;while over item IDorTag (or while anywhere over the canvas if IDorTag=0).
;
;Here is an example: enter these commands, then click on the rectangle.....
;        (define txt (draw-text "SURPRISE!!!" 200 300))
;        (define rect (draw-rectangle 100 200 300 400))
;        (set-color! rect "red")
;        (set-binding! rect (lambda () (set-color! rect "")))
;Here is an example using motion.  Type in the above followed by:
;        (set-binding! txt
;          (lambda ()
;            (set-motion-binding! 0
;              (lambda ()
;                (set-binding! 0 (lambda () (set-binding! 0 "")
;                                           (set-motion-binding! 0 "")))
;                (set-coords! txt (get-mouse-coords))))))
;Then click on the text to drag it around.  This works as follows:
;When you click on the text, the outer lambda is called, which sets the
;the motion binding (the second lambda) for the whole canvas.  
;The heart of the motion binding is the last line, which sets the text's
;current position to the current mouse position.  The rest of the second
;lambda ["(set-binding! 0 ... )"] serves to turn off the motion when the
;mouse is clicked a second time [after at least one motion].
;
;Note about Clicking on HIDorTagden or Transparent Objects:
;      You can set bindings to any object, but the binding won't activate
;      if the object is hIDorTagden or if you click in the interior of a shape
;      that is not filled (i.e. no color).  However, a canvas-wIDorTage binding
;      (on IDorTag 0) will always activate on any click anywhere over the canvas.

;To create slow motion, use (after N P) where N is a delay in milliseconds [NEW]
;and P is a thunk that updates an object's coordinates and repeats.  Example:
;        (define rect (fill-rectangle 10 20 100 150))
;        (define (add-one n) (+ 1 n))
;        (define continue #T)
;        (define (move-once object)
;                (set-coords! object (map add-one (get-coords object))))
;        (define (crawl)
;                (move-once rect)
;                (if continue (after 50 crawl)))
;The command (after 50 crawl) means "call the crawl fcn after 50 msec".
;
;Now type          (crawl)               and watch the rectangle crawl.
;To stop it type:  (set! continue #F)    .
;
;You could instead trigger the motion with a mouse click by typing:
;        (set-binding! rect
;                      (lambda () (set! continue (not continue))
;                                 (crawl)))
;Now click on the rectangle *twice*.  Click on the rectangle again to stop it.

;;; End of explanation

(define (set-canvas-size x y)
  (set-width! 0 y x))

(define (retrieve-coordinates options)
   (if (or (null? options) (not (number? (car options))))
      '()
      (cons (car options) (retrieve-coordinates (cdr options)))))
      
(define (remove-coordinates options)
   (if (or (null? options) (not (number? (car options))))
      options
      (remove-coordinates (cddr options))))    


(define (make-options options-list)
   (if (null? options-list)
      '()
      (cons `(word '- ',(car options-list)) (cons `',(cadr options-list)
            (make-options (cddr options-list))))))

(define (draw-line . options)     ;; draws a line 
      (if (or (memq 'fill options) (member "fill" options))
         (eval (append '(.drawwindow 'create 'line)  
                                       (retrieve-coordinates options)
                                       (make-options (remove-coordinates options))))   
         (eval (append '(.drawwindow 'create 'line)  
                                       (retrieve-coordinates options)
                                       (list :fill *fill-color*)
                                       (make-options (remove-coordinates options)))))) 

(define (draw-curved-line . options)     ;; draws a curved-line
      (apply draw-line (append options (list 'smooth #t)))) 

(define (draw-text string x y . options) ;; draws text at (x,y)
   (if (or (memq 'fill options) (member "fill" options))
      (eval (append `(.drawwindow 'create 'text 
                                  ,x ,y
                                  :text ',string 
				  :font "-*-Arial-r-r-Normal--*-150-*-*-*-*-*-*"
				  )
                                  (make-options options)))   
      (eval (append `(.drawwindow 'create 'text  
                                  ,x ,y
                                  :text ',string  
                                  :fill *fill-color*
				  :font "-*-Arial-r-r-Normal--*-150-*-*-*-*-*-*"
				  )
                                  (make-options options))))) 

(define (draw-oval x1 y1 x2 y2 . options)     ;; draws an oval from (x1,y1) to (x2,y2).
   (eval (append `(.drawwindow 'create 'oval  
                                       ,x1 ,y1
                                       ,x2 ,y2)
                  (if (not (or (memq 'outline options) (member "outline" options)))
                     `('-outline *outline-color*)
                     '())
                  (if (not (or (memq 'fill options) (member "fill" options)))
                     `('-fill *fill-color*)
                     '())
                     (make-options options))))                                                         

(define (draw-rectangle x1 y1 x2 y2 . options);; draws a rectangle from (x1,y1) to (x2,y2)
   (eval (append `(.drawwindow 'create 'rectangle 
                                       ,x1 ,y1
                                       ,x2 ,y2)
                  (if (not (or (memq 'outline options) (member "outline" options)))
                     `('-outline *outline-color*)
                     '())
                  (if (not (or (memq 'fill options) (member "fill" options)))
                     `('-fill *fill-color*)
                     '())
                     (make-options options))))  

(define (draw-polygon . options)
    (eval (append '(.drawwindow 'create 'polygon)
                   (retrieve-coordinates options) 
                  (if (not (or (memq 'outline options) (member "outline" options)))
                     `('-outline *outline-color*)
                     '())
                  (if (not (or (memq 'fill options) (member "fill" options)))
                     `('-fill *fill-color*)
                     '())
                     (make-options (remove-coordinates options)))))
                     

(define (draw-arc x1 y1 x2 y2 . options)     ;; draws an arc from (x1,y1) to (x2,y2).
   (eval (append `(.drawwindow 'create 'arc  
                                       ,x1 ,y1
                                       ,x2 ,y2)
                  (if (not (or (memq 'outline options) (member "outline" options)))
                     `('-outline *outline-color*)
                     '())
                  (if (not (or (memq 'fill options) (member "fill" options)))
                     `('-fill *fill-color*)
                     '())
                     (make-options options))))     

(define (draw-image x y name . options)
  (eval (append `(.drawwindow 'create 'image ,x ,y 
			      '-image ,(image 'create 'photo :file 
					      (if (and (symbol-bound? '*gamesman-path*) *gamesman-path*)
						  (string-append *gamesman-path* "images/" name)
						  name)))
		(make-options options))))
                               
(define (clear-graphics!)
  (for-each (lambda (item) (.drawwindow 'delete item))
	    (.drawwindow 'find 'all)))

(define (stall . optional-prompts) ; update display; optionally seek user input
  (if (null? optional-prompts)
      (begin (flush) (update) #T)
      (begin (for-each display optional-prompts) (flush) (update)
	     (read-char))))

;; now create a new empty canvas. ;; How to put it in a new window?
(define (init-graphics)
  (let ((window-exists (winfo 'exists '.drawwindow)))
    (if (number? window-exists)
	(display "You are using an old version of STK. This graphics package may not work.\n"))
    (if (or (not window-exists)
	    (and (number? window-exists) (= 0 window-exists)))
	(begin
	  (canvas '.drawwindow :height "6i" :width "6i" :bg "white")
	  (pack .drawwindow :fill "both" :expand #T)
	  (display gdraw:version))
	(clear-graphics!))))

(define (print-canvas filename . options)
  ; save a postscript image of the canvas
  ; options:
  ;     :colormap       varName 
  ;     :colormode      "color" | "grey" | "mono"
  ;     :file           fileName        e.g. "all.ps"
  ;     :fontmap        varName
  ;     :height         size            e.g. "8i"
  ;     :pageanchor     anchor
  ;     :pageheight     size            e.g. "8i"
  ;     :pagewidth      size            e.g. "8i"
  ;     :pagex          position
  ;     :pagey          position
  ;     :rotate         boolean
  ;     :width          size            e.g. "8i"
  ;     :x              position
  ;     :y              position
  (define item .drawwindow)
  (if (not (null? options))
      (cond ((procedure? (car options))     (set! item (car options))
                                            (set! options (cdr options)))
            ((not (keyword? (car options))) (set! options (cdr options)))))
  (apply item 'postscript :file filename options))

(define *fill-color* "black")
(define *outline-color* "black")

;;;  UTILITIES

(define (gdraw:last L)     ;; get last item in a list (used for properties)
  (if (pair? (cdr L)) (gdraw:last (cdr L)) (car L)))

;;; GET AND SET PROPERTIES....

(define (get-fill-color IDorTag)         ;; get color for item.
      (if (or (not (number? IDorTag)) (positive? IDorTag))
         (gdraw:last (.drawwindow 'itemconfigure IDorTAG :fill))
         (error "Canvas has no fill color")))

(define (get-outline-color IDorTag)         ;; get color for item.
      (if (or (not (number? IDorTag)) (positive? IDorTag))
         (gdraw:last (.drawwindow 'itemconfigure IDorTag :outline))
         (error "Canvas has no outline color")))

(define (get-bg-color IDorTag)
      (if (and (number? IDorTag) (= IDorTag 0))
         (gdraw:last (.drawwindow 'configure :background))
         (gdraw:last (.drawwindow 'itemconfigure IDorTag :background))))

(define (set-fill-color! IDorTag color)  ;; set color for item.
  (if (or (null? color) (not color)) (set! color ""))
  (if (and (number? IDorTag) (= IDorTag 0)) 
      (.drawwindow 'configure :fill color)
      (.drawwindow 'itemconfigure IDorTag :fill color)))
      
(define (set-outline-color! IDorTag color)  ;; set color for item.
  (if (or (null? color) (not color)) (set! color ""))
  (if (and (number? IDorTag) (= IDorTag 0)) 
      (.drawwindow 'configure :outline color)
      (.drawwindow 'itemconfigure IDorTag :outline color)))
      
(define (set-bg-color! IDorTag color)  ;; set color for item.
  (if (or (null? color) (not color)) (set! color ""))
  (if (and (number? IDorTag) (= IDorTag 0)) 
      (.drawwindow 'configure :background color)
      (.drawwindow 'itemconfigure IDorTag :background color)))

(define (get-text IDorTag)          ;; get displayed text for item
  (if (or (not (number? IDorTag)) (positive? IDorTag))
      (gdraw:last (.drawwindow 'itemconfigure IDorTag :text))
      ""))
      
(define (set-text! IDorTag new-text);; set displayed text for item
  (if (or (not (number? IDorTag)) (positive? IDorTag))
      (.drawwindow 'itemconfigure IDorTag :text new-text)))

(define (get-width IDorTag)          ;; get width for item 
  (if (or (not (number? IDorTag)) (positive? IDorTag))
      (gdraw:last (.drawwindow 'itemconfigure IDorTag :width))
      (map (lambda (I) (gdraw:last (.drawwindow 'configure I)))
	   (list :height :width))))
    
(define (set-width! IDorTag new-width . more) ;; set width for item, if legal.
  ;; for IDorTag=0, accepts either 2 numbers or a list of 2 numbers.
  (if (or (not (number? IDorTag)) (positive? IDorTag))
      (.drawwindow 'itemconfigure IDorTag :width new-width)
      (map (lambda (I V) (.drawwindow 'configure I V))
	   (list :height :width)
	   (if (null? more) new-width (cons new-width more)))))

(define (get-font-size IDorTag)       ;; get font size.
  (cadr (gdraw:get-font IDorTag)))
(define (set-font-size! IDorTag size) ;; set new font size
  (define result #F)
  (define font (gdraw:get-font IDorTag))
  (if (catch
       (set! result
	     (.drawwindow 'itemconfigure IDorTag :font
			  (string-append (car font)
					 "-" 
					 (& size)
					 "-"
					 (caddr font)))))
      (begin
       (.drawwindow 'itemconfigure IDorTag :font (cadddr font))
       (display (list 'set-font-size! IDorTag size " - FAILED, IGNORED.")) (newline)
       #F)
      result))

(define (set-image! IDorTag name)
   (if (or (not (number? IDorTag)) (positive? IDorTag))
      (let ((image (gdraw:last (.drawwindow 'itemconfigure IdorTag :image))))
         (image 'blank)
         (image 'configure :file
                (if (and (symbol-bound? '*gamesman-path*) *gamesman-path*) 
		    (string-append *gamesman-path* "images/" name)
		    name)))))

(define (gdraw:get-font IDorTag)
  (gdraw:extract-font-info
   (gdraw:last (.drawwindow 'itemconfigure IDorTag :font))))
(define (gdraw:extract-font-info font) ;; internal fcn to extract font info
  (define positions (cond (((string->regexp "-[0-9]*[0-9]-") font) => car)
			  (else #F)))
  (if positions
      (list (substring font 0 (car positions))
	    (string->number (substring font
				       (+ 1 (car positions))
				       (+ -1 (cadr positions))))
	    (substring font (cadr positions) (string-length font))
	    font)
      (begin (display "can't recognize fontname format\n")
	     (list #F #F #F font))))

(define (get-coords IDorTag)        ;; get X-Y coordinates of item
  (if (or (not (number? IDorTag)) (positive? IDorTag))
      (.drawwindow 'coords IDorTag)
      (list (winfo 'rootx .drawwindow)
	    (winfo 'rooty .drawwindow))))

(define (set-coords! IDorTag coords . more) ;; set X-Y coordinates of item
  ;; accepts either individual numbers or a single list of numbers.
  (if (not (list? coords)) (set! coords (cons coords more)))
  (if (or (not (number? IDorTag)) (positive? IDorTag))
      (apply .drawwindow 'coords IDorTag coords)
      (display "Use set-width! to change the shape of the canvas\n")))

(define (get-binding IDorTag)             ;; get procedure binding for item
  (define binding-present
	  (member "<Button>"
		 (if (or (not (number? IDorTag)) (positive? IDorTag))
		     (.drawwindow 'bind IDorTag)
		     (bind .drawwindow))))
  (if binding-present
      (if (or (not (number? IDorTag)) (positive? IDorTag))
	  (car (.drawwindow 'bind IDorTag "<Button>"))
	  (car (bind .drawwindow "<Button>")))
      #F))


(define (set-default-outline-color! color)
      (set! *outline-color* color))

(define (set-default-fill-color! color)
      (set! *fill-color* color))
  
(define (set-binding! IDorTag thunk)       ;; set procedure binding for item
  (define binding
	  (if (or (null? thunk) (not thunk))
	      ""
	      thunk))
  (if (or (not (number? IDorTag)) (positive? IDorTag))
      (.drawwindow 'bind IDorTag "<Button>" binding)
      (bind .drawwindow "<Button>" binding)))

(define (raise! IDorTag . above)                         ;; raise item on canvas
  (if (or (not (number? IDorTag)) (positive? IDorTag) )
     (if (null? above) 
        (.drawwindow 'raise IDorTag)
        (.drawwindow 'raise IDorTag (car above)))))
    
(define (lower! IDorTag . below)                         ;; lower item on canvas
  (if (or (not (number? IDorTag)) (positive? IDorTag))
     (if (null? below) 
        (.drawwindow 'lower IDorTag)
        (.drawwindow 'lower IDorTag (car below)))))

(define (get-motion-binding IDorTag)             ;; get procedure binding for item
  (define binding-present
	  (member "<Motion>"
		 (if (positive? IDorTag)
		     (.drawwindow 'bind IDorTag)
		     (bind .drawwindow))))
  (if binding-present
      (if (or (not (number? IDorTag)) (positive? IDorTag))
	  (car (.drawwindow 'bind IDorTag "<Motion>"))
	  (car (bind .drawwindow "<Motion>")))
      #F))
(define (set-motion-binding! IDorTag thunk)      ;; set motion binding for item
  (define binding
	  (if (or (null? thunk) (not thunk))
	      ""
	      thunk))
  (if (or (positive? IDorTag) (not (number? IDorTag)))
      (.drawwindow 'bind IDorTag "<Motion>" binding)
      (bind .drawwindow "<Motion>" binding)))

(define (get-type  IDorTag)            ;;get type
  (if (or (number? IDorTag) (not (number? IDorTag)))
      (.drawwindow 'type IDorTag)
      'canvas))

(define (get-mouse-coords) ;; get the mouse coordinates
  (map - (winfo 'pointerxy .drawwindow)
       (list (winfo 'rootx .drawwindow)
	     (winfo 'rooty .drawwindow))))

(define (gdraw:delete! IDorTag)                ;; delete an item on the canvas
  (cond ((eq? IDorTag 'all)         (clear-graphics!))
	((or (member IDorTag (get-IDs))
             (not (empty? (get-ids-with-tag IDorTag))))
              (.drawwindow 'delete IDorTag))
	((equal? IDorTag 0)         (clear-graphics!))
	(else                  #F)))
(define gdelete! gdraw:delete!)
(define delete! gdraw:delete!)

(define (remove-tag IDorTag tag-to-delete)
   (.drawwindow 'dtag IDorTag tag-to-delete))
      
(define (addtag IDorTag tag-to-add)
   (if (number? IDorTag)
      (.drawwindow 'itemconfigure IDorTag :tags (cons tag-to-add (get-tags IDorTag)))
      (.drawwindow 'addtag tag-to-add 'withtag IDorTag)))

(define (get-tags ID)
   (gdraw:last (.drawwindow 'itemconfigure ID :tags)))

(define (get-ids-with-tag tag)  ;;get a list of all id's with tag
      (.drawwindow 'find 'withtag tag))

(define (get-IDs)                  ;; get list of all existing IDs
  (.drawwindow 'find 'all))

(define (catch-winfo . args)
  (define result #F)
  (if (catch (set! result (apply winfo args)))
      #F
      result))

(define (get-properties IDorTag)        ;; get all properties I can think of...
  (cond ((or (not (number? IDorTag)) (positive? IDorTag))
	 (list (cons 'bind
		     (map (lambda (binding)
				  (cons binding (.drawwindow 'bind IDorTag binding)))
			  (.drawwindow 'bind IDorTag)))
	       (cons 'bbox (.drawwindow 'bbox IDorTag))
	       (cons 'coords (.drawwindow 'coords IDorTag))
	       (cons 'itemconfigure (.drawwindow 'itemconfigure IDorTag))
	       (list 'type  (.drawwindow 'type IDorTag))))
	((and (number? IDorTag) (zero? IDorTag))
	 (list (cons 'bind
		     (map (lambda (binding)
				  (cons binding (bind .drawwindow binding)))
			  (bind .drawwindow)))
	       (cons 'configure (.drawwindow 'configure))
	       (cons 'read-only-winfo
		     (map (lambda (prop)
				  (list prop (catch-winfo prop .drawwindow)))
			  '(atom  atomname  cells  children  class colormapfull
				  containing  depth  exists  fpixels  geometry
				  height IDorTag interps  ismapped  manager  name
				  parent  pathname pixels  pointerx pointerxy
				  pointery  reqheight  reqwIDorTagth rgb  rootx
				  rooty  screen screencells  screendepth
				  screenheight  screenmmheight  screenmmwIDorTagth
				  screenvisual screenwIDorTagth  server  toplevel
				  viewable  visual  visualIDorTag visualsavailable
				  vrootheight  vrootwIDorTagth  vrootx  vrooty wIDorTagth
				  x y)
			  ))))
	(else 
	 (list (cons 'configure (*root* 'configure))
	       (cons 'read-only-winfo
		     (map (lambda (prop) (list prop (catch-winfo prop *root*)))
			  '(atom  atomname  cells  children
				  class colormapfull  containing  depth
				  exists fpixels  geometry  height
				  IDorTag interps  ismapped  manager  name
				  parent  pathname  pixels  pointerx
				  pointerxy  pointery  reqheight
				  reqwIDorTagth  rgb  rootx  rooty  screen
				  screencells  screendepth  screenheight
				  screenmmheight  screenmmwIDorTagth
				  screenvisual  screenwIDorTagth  server
				  toplevel  viewable  visual  visualIDorTag
				  visualsavailable  vrootheight
				  vrootwIDorTagth  vrootx  vrooty  wIDorTagth  x y)
			  ))))))

(define (set-property! IDorTag property . values)
  (cond ((equal? "" (& property)) #F)
	((or (not (number? IDorTag)) (positive? IDorTag))
	 (cond ((char=? #\< (string-ref (& property) 0))
		(apply .drawwindow 'bind IDorTag property values))
	       ((char=? #\: (string-ref (& property) 0))
		(apply .drawwindow 'itemconfigure IDorTag property values))
	       ((equal? (& 'coords) (& property))
		(apply .drawwindow 'coords IDorTag values))
	       (else
		(apply .drawwindow property IDorTag values))))
	((and (number? IDorTag) (zero? IDorTag))
	 (cond ((char=? #\< (string-ref (& property) 0))
		(apply bind .drawwindow property values))
	       ((char=? #\: (string-ref (& property) 0))
		(apply .drawwindow 'configure property values))
	       (else
		(apply .drawwindow property values))))
	(else ; assume root-window
	 (cond ((char=? #\< (string-ref (& property) 0))
		(apply bind *root* property values))
	       ((char=? #\: (string-ref (& property) 0))
		(apply *root* 'configure property values))
	       (else
		(apply *root* property values))))))

(define (position-modif coords xInc yInc)
	(let ((x1 (car coords))
	      (y1 (cadr coords))
	      (x2 (caddr coords))
	      (y2 (cadddr coords)))
	 (list (+ x1 xInc) (+ y1 yInc) (+ x2 xInc) (+ y2 yInc))))

(define (fly-to x y ID speed position-modif)
	(let* ((c (get-coords  ID))
	 	(x1 (car c))
	 	(y1 (cadr c))
	 	(xInc (ceiling (/ (abs (- x x1)) 30) ))
	 	(yInc (ceiling (/ (abs (- y y1)) 30) )))
	 (if (<= x x1)
	 	(set! xInc (- xInc)))
	 (if (<= y y1)
	 	(set! yInc (- yInc)))
	 (fly-to-help x y c xInc yInc speed position-modif ID)
	 ))
	 
	 
(define (fly-to-help xTo yTo coords xInc yInc speed position-modif ID)
	(if (and ( or (<= (abs (- (car coords) xTo)) (abs xInc)) (= xInc 0))
		 ( or (<= (abs (- (cadr coords)  yTo)) (abs yInc)) (= yInc 0)))
	    'done
	    (begin
	    	(if (<= (abs (- (car coords) xTo)) (abs xInc))
	    		(set! xInc 0))
	    	(if (<= (abs (- (cadr coords)  yTo)) (abs yInc))
	    		(set! yInc 0))
;	    	(after speed (lambda ()
;			       (set-coords! ID (position-modif coords xInc yInc))
;			       (fly-to-help xTo yTo (position-modif coords xInc yInc) xInc yInc speed position-modif ID))))))
	    	(begin
		  (update 'idletasks)
		  (set-coords! ID (position-modif coords xInc yInc))
		  (fly-to-help xTo yTo (position-modif coords xInc yInc) xInc yInc speed position-modif ID)))))