/[gcl]/gcl/gcl-tk/demos/mkItems.lisp
ViewVC logotype

Diff of /gcl/gcl-tk/demos/mkItems.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1.1.1 by wfs, Mon Dec 6 22:44:01 1999 UTC revision 1.2 by camm, Sun May 1 20:17:31 2005 UTC
# Line 29  Line 29 
29      (pack (conc w '.frame2) :side "top" :fill "both" :expand "yes")      (pack (conc w '.frame2) :side "top" :fill "both" :expand "yes")
30      (pack (conc w '.ok) :side "bottom" :pady 5 :anchor "center")      (pack (conc w '.ok) :side "bottom" :pady 5 :anchor "center")
31    
32        (scrollbar (conc w '.frame2.vscroll)  :relief "sunken" :command (tk-conc c " yview"))
33        (scrollbar (conc w '.frame2.hscroll) :orient "horiz" :relief "sunken" :command (tk-conc c " xview"))
34      (canvas c :scrollregion "0c 0c 30c 24c" :width "15c" :height "10c"      (canvas c :scrollregion "0c 0c 30c 24c" :width "15c" :height "10c"
35              :relief "sunken" :borderwidth 2              :relief "sunken" :borderwidth 2
36              :xscrollcommand (tk-conc w ".frame2.hscroll set") :yscrollcommand (tk-conc w ".frame2.vscroll set"))              :xscrollcommand (tk-conc w ".frame2.hscroll set") :yscrollcommand (tk-conc w ".frame2.vscroll set"))
     (scrollbar (conc w '.frame2.vscroll)  :relief "sunken" :command (tk-conc c " yview"))  
     (scrollbar (conc w '.frame2.hscroll) :orient "horiz" :relief "sunken" :command (tk-conc c " xview"))  
37      (pack (conc w '.frame2.hscroll) :side "bottom" :fill "x")      (pack (conc w '.frame2.hscroll) :side "bottom" :fill "x")
38      (pack (conc w '.frame2.vscroll) :side "right" :fill "y")      (pack (conc w '.frame2.vscroll) :side "right" :fill "y")
39      (pack c :in (conc w '.frame2) :expand "yes" :fill "both")      (pack c :in (conc w '.frame2) :expand "yes" :fill "both")
# Line 280  Line 280 
280    
281  ;; Utility procedures to support dragging of items.  ;; Utility procedures to support dragging of items.
282    
283    (defvar *lastX* 0)
284    (defvar *lastY* 0)
285    
286    
287  (defun itemStartDrag (c x y)  (defun itemStartDrag (c x y)
288  ;    (global :lastX lastY)  ;    (global :*lastX* *lastY*)
289      (setq lastX (funcall c :canvasx x :return 'number))      (setq *lastX* (funcall c :canvasx x :return 'number))
290      (setq lastY (funcall c :canvasy y :return 'number))      (setq *lastY* (funcall c :canvasy y :return 'number))
291  )  )
292    
293  (defun itemDrag (c x y)  (defun itemDrag (c x y)
294  ;    (global :lastX lastY)  ;    (global :*lastX* *lastY*)
295      (setq x (funcall c :canvasx x :return 'number))      (setq x (funcall c :canvasx x :return 'number))
296      (setq y (funcall c :canvasy y :return 'number))      (setq y (funcall c :canvasy y :return 'number))
297      (funcall c :move "current" (- x lastX) (- y lastY))      (funcall c :move "current" (- x *lastX*) (- y *lastY*))
298      (setq lastX x)      (setq *lastX* x)
299      (setq lastY y)      (setq *lastY* y)
300  )  )
301    
302  (defvar *recursive* nil)  (defvar *recursive* nil)
303  (defun itemDrag (c x y)  (defun itemDrag (c x y)
304  ;    (global :lastX lastY)  ;    (global :*lastX* *lastY*)
305    (cond (*recursive* )    (cond (*recursive* )
306          (t (let ((*recursive* t))          (t (let ((*recursive* t))
307      (setq x (funcall c :canvasx x :return 'number))      (setq x (funcall c :canvasx x :return 'number))
308      (setq y (funcall c :canvasy y :return 'number))      (setq y (funcall c :canvasy y :return 'number))
309      (funcall c :move "current" (- x lastX) (- y lastY))      (funcall c :move "current" (- x *lastX*) (- y *lastY*))
310      (setq lastX x)      (setq *lastX* x)
311      (setq lastY y)))))      (setq *lastY* y)))))
312    
313  ;; Procedure that's invoked when the button embedded in the "canvas"  ;; Procedure that's invoked when the button embedded in the "canvas"
314  ;; is invoked.  ;; is invoked.

Legend:
Removed from v.1.1.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26