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") |
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. |