3
;; Create a top-level window containing a canvas that displays the
4
;; various item types and allows them to be selected and moved. This
5
;; demo can be used to test out the point-hit and rectangle-hit code
9
;; w - Name to use for new top-level window.
11
(defvar *color-display* nil)
12
(defun mkItems (&optional (w '.citems))
13
(declare (special c tk_library))
14
(if (winfo :exists w :return 'boolean)
16
(if (winfo :exists w :return 'boolean) (destroy w))
19
(wm :title w "Canvas Item Demonstration")
20
(wm :iconname w "Items")
21
(wm :minsize w 100 100)
22
(setq c (conc w '.frame2.c))
24
(message (conc w '.msg) :font :Adobe-Times-Medium-R-Normal--*-180-* :width "13c"
25
:bd 2 :relief "raised" :text #u"This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area.")
26
(frame (conc w '.frame2) :relief "raised" :bd 2)
27
(button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w))
28
(pack (conc w '.msg) :side "top" :fill "x")
29
(pack (conc w '.frame2) :side "top" :fill "both" :expand "yes")
30
(pack (conc w '.ok) :side "bottom" :pady 5 :anchor "center")
32
(canvas c :scrollregion "0c 0c 30c 24c" :width "15c" :height "10c"
33
:relief "sunken" :borderwidth 2
34
:xscrollcommand (tk-conc w ".frame2.hscroll set") :yscrollcommand (tk-conc w ".frame2.vscroll set"))
35
(scrollbar (conc w '.frame2.vscroll) :relief "sunken" :command (tk-conc c " yview"))
36
(scrollbar (conc w '.frame2.hscroll) :orient "horiz" :relief "sunken" :command (tk-conc c " xview"))
37
(pack (conc w '.frame2.hscroll) :side "bottom" :fill "x")
38
(pack (conc w '.frame2.vscroll) :side "right" :fill "y")
39
(pack c :in (conc w '.frame2) :expand "yes" :fill "both")
41
;; Display a 3x3 rectangular grid.
43
(funcall c :create "rect" "0c" "0c" "30c" "24c" :width 2)
44
(funcall c :create "line" "0c" "8c" "30c" "8c" :width 2)
45
(funcall c :create "line" "0c" "16c" "30c" "16c" :width 2)
46
(funcall c :create "line" "10c" "0c" "10c" "24c" :width 2)
47
(funcall c :create "line" "20c" "0c" "20c" "24c" :width 2)
49
(setq font1 :Adobe-Helvetica-Medium-R-Normal--*-120-*)
50
(setq font2 :Adobe-Helvetica-Bold-R-Normal--*-240-*)
51
(if (> (winfo :depth c :return 'number) 1)
53
(setq *color-display* t)
54
(setq blue "DeepSkyBlue3")
56
(setq bisque "bisque3")
57
(setq green "SeaGreen3"))
62
(setq green "black")))
64
;; Set up demos within each of the areas of the grid.
66
(funcall c :create "text" "5c" ".2c" :text "Lines" :anchor "n")
67
(funcall c :create "line" "1c" "1c" "3c" "1c" "1c" "4c" "3c" "4c" :width "2m" :fill blue
68
:cap "butt" :join "miter" :tags "item")
69
(funcall c :create "line" "4.67c" "1c" "4.67c" "4c" :arrow "last" :tags "item")
70
(funcall c :create "line" "6.33c" "1c" "6.33c" "4c" :arrow "both" :tags "item")
71
(funcall c :create "line"
72
"5c" "6c" "9c" "6c" "9c" "1c" "8c" "1c" "8c" "4.8c" "8.8c" "4.8c" "8.8c" "1.2c"
73
"8.2c" "1.2c" "8.2c" "4.6c" "8.6c" "4.6c" "8.6c" "1.4c" "8.4c" "1.4c" "8.4c" "4.4c" :fill "red"
74
:width 3 :tags "item")
75
(funcall c :create "line" "1c" "5c" "7c" "5c" "7c" "7c" "9c" "7c"
77
:stipple "@" : *tk-library* : "/demos/images/gray25.bmp"
78
:arrow "both" :arrowshape "15 15 7" :tags "item")
79
(funcall c :create "line" "1c" "7c" "1.75c" "5.8c" "2.5c" "7c" "3.25c"
80
"5.8c" "4c" "7c" :width ".5c"
81
:cap "round" :join "round" :tags "item")
83
(funcall c :create "text" "15c" ".2c" :text "Curves (smoothed :lines)" :anchor "n")
84
(funcall c :create "line" "11c" "4c" "11.5c" "1c" "13.5c" "1c" "14c"
86
:fill blue :tags "item")
87
(funcall c :create "line" "15.5c" "1c" "19.5c" "1.5c" "15.5c" "4.5c"
88
"19.5c" "4c" :smooth "on"
89
:arrow "both" :width 3 :tags "item")
90
(funcall c :create "line" "12c" "6c" "13.5c" "4.5c" "16.5c" "7.5c" "18c" "6c"
91
"16.5c" "4.5c" "13.5c" "7.5c" "12c" "6c" :smooth "on" :width "3m" :cap "round"
92
:stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill red :tags "item")
94
(funcall c :create "text" '25c ".2c" :text "Polygons" :anchor "n")
95
(funcall c :create "polygon" "21c" "1.0c" "22.5c" "1.75c" "24c" "1.0c"
97
"24c" "4.0c" "22.5c" "3.25c" "21c" "4.0c" "21.75c" "2.5c"
100
(funcall c :create "polygon" "25c" "4c" "25c" "4c" "25c" "1c" "26c" "1c" "27c" "4c" "28c" "1c"
101
"29c" "1c" "29c" "4c" "29c" "4c" :fill red :smooth "on" :tags "item")
102
(funcall c :create "polygon" "22c" "4.5c" "25c" "4.5c" "25c" "6.75c" "28c" "6.75c"
103
"28c" "5.25c" "24c" "5.25c" "24c" "6.0c" "26c" "6c" "26c" "7.5c" "22c" "7.5c"
104
:stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :tags "item")
106
(funcall c :create "text" "5c" "8.2c" :text "Rectangles" :anchor "n")
107
(funcall c :create "rectangle" "1c" "9.5c" "4c" "12.5c" :outline red :width "3m" :tags "item")
108
(funcall c :create "rectangle" "0.5c" "13.5c" "4.5c" "15.5c" :fill green :tags "item")
109
(funcall c :create "rectangle" "6c" "10c" "9c" "15c" :outline ""
110
:stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill blue :tags "item")
112
(funcall c :create "text" "15c" "8.2c" :text "Ovals" :anchor "n")
113
(funcall c :create "oval" "11c" "9.5c" "14c" "12.5c" :outline red :width "3m" :tags "item")
114
(funcall c :create "oval" "10.5c" "13.5c" "14.5c" "15.5c" :fill green :tags "item")
115
(funcall c :create "oval" "16c" "10c" "19c" "15c" :outline ""
116
:stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill blue :tags "item")
118
(funcall c :create "text" "25c" "8.2c" :text "Text" :anchor "n")
119
(funcall c :create "rectangle" "22.4c" "8.9c" "22.6c" "9.1c")
120
(funcall c :create "text" "22.5c" "9c" :anchor "n" :font font1 :width "4c"
121
:text "A short string of text, word-wrapped, justified left, and anchored north (at :the top). The rectangles show the anchor points for each piece of text." :tags "item")
122
(funcall c :create "rectangle" "25.4c" "10.9c" "25.6c" "11.1c")
123
(funcall c :create "text" "25.5c" "11c" :anchor "w" :font font1 :fill blue
124
:text #u"Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge."
125
:justify "center" :tags "item")
126
(funcall c :create "rectangle" "24.9c" "13.9c" "25.1c" "14.1c")
127
(funcall c :create "text" "25c" "14c" :font font2 :anchor "c" :fill red
128
:stipple "@" : *tk-library* : "/demos/images/gray25.bmp"
129
:text "Stippled characters" :tags "item")
131
(funcall c :create "text" "5c" "16.2c" :text "Arcs" :anchor "n")
132
(funcall c :create "arc" "0.5c" "17c" "7c" "20c" :fill green :outline "black"
133
:start 45 :extent 270 :style "pieslice" :tags "item")
134
(funcall c :create "arc" "6.5c" "17c" "9.5c" "20c" :width "4m" :style "arc"
135
:fill blue :start -135 :extent 270
136
:stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :tags "item")
137
(funcall c :create "arc" "0.5c" "20c" "9.5c" "24c" :width "4m" :style "pieslice"
138
:fill "" :outline red :start 225 :extent -90 :tags "item")
139
(funcall c :create "arc" "5.5c" "20.5c" "9.5c" "23.5c" :width "4m" :style "chord"
140
:fill blue :outline "" :start 45 :extent 270 :tags "item")
142
(funcall c :create "text" "15c" "16.2c" :text "Bitmaps" :anchor "n")
143
(funcall c :create "bitmap" "13c" "20c" :bitmap "@" : *tk-library* : "/demos/images/face.bmp" :tags "item")
144
(funcall c :create "bitmap" "17c" "18.5c"
145
:bitmap "@" : *tk-library* : "/demos/images/noletter.bmp" :tags "item")
146
(funcall c :create "bitmap" "17c" "21.5c"
147
:bitmap "@" : *tk-library* : "/demos/images/letters.bmp" :tags "item")
149
(funcall c :create "text" "25c" "16.2c" :text "Windows" :anchor "n")
150
(button (conc c '.button) :text "Press Me" :command `(butPress ',c ',red))
151
(funcall c :create "window" "21c" "18c" :window (conc c '.button) :anchor "nw" :tags "item")
152
(bind "Entry" "<Control-KeyPress>" '(emacs-move %W %A ))
153
(bind "Entry" "<Control-Key-d>" "")
154
(entry (conc c '.entry) :width 20 :relief "sunken")
155
(funcall (conc c '.entry) :insert "end" "Edit this text")
156
(funcall c :create "window" "21c" "21c" :window (conc c '.entry) :anchor "nw" :tags "item")
157
(scale (conc c '.scale) :from 0 :to 100 :length "6c" :sliderlength '.4c
158
:width ".5c" :tickinterval 0)
159
(funcall c :create "window" "28.5c" "17.5c" :window (conc c '.scale) :anchor "n" :tags "item")
160
(funcall c :create "text" "21c" "17.9c" :text "Button" :anchor "sw")
161
(funcall c :create "text" "21c" "20.9c" :text "Entry" :anchor "sw")
162
(funcall c :create "text" "28.5c" "17.4c" :text "Scale" :anchor "s")
164
;; Set up event bindings for canvas:
166
(funcall c :bind "item" "<Any-Enter>" `(itemEnter ',c))
167
(funcall c :bind "item" "<Any-Leave>" `(itemLeave ',c))
168
(bind c "<2>" (tk-conc c " scan mark %x %y"))
169
(bind c "<B2-Motion>" (tk-conc c " scan dragto %x %y"))
170
(bind c "<3>" `(itemMark ',c |%x| |%y|))
171
(bind c "<B3-Motion>" `(itemStroke ',c |%x| |%y|))
172
(bind c "<Control-f>" `(itemsUnderArea ',c))
173
(bind c "<1>" `(itemStartDrag ',c |%x| |%y|))
174
(bind c "<B1-Motion>" `(itemDrag ',c |%x| |%y|))
175
(bind w "<Any-Enter>" `(focus ',c))
178
;; Utility procedures for highlighting the item under the pointer:
180
(defvar *restorecmd* nil)
182
(defun itemEnter (c &aux type bg)
183
; (global :*restorecmd*)
184
(let ((current (funcall c :find "withtag" "current" :return 'string)))
185
(if (equal current "") (return-from itementer nil))
187
(if (not *color-display*)
190
(return-from itementer nil)))
191
(setq type (funcall c :type current :return 'string))
192
(if (equal type "window")
195
(return-from itemEnter nil)))
196
(if (equal type "bitmap")
199
(funcall c :itemconf current :background
200
:return 'list-strings)))
201
(push `(,c :itemconfig ',current :background ',bg) *restorecmd*)
202
(funcall c :itemconfig current :background "SteelBlue2")
203
(return-from itemEnter nil)))
204
(setq fill (nth 4 (funcall c :itemconfig current :fill
205
:return 'list-strings)))
206
(if (or (member type '("rectangle" "oval" "arg") :test 'equal)
209
(setq outline (nth 4 (funcall c :itemconfig current :outline :return 'list-strings)))
210
(push `(,c :itemconfig ',current :outline ',outline) *restorecmd*)
211
(funcall c :itemconfig current :outline "SteelBlue2"))
213
(push `(,c :itemconfig ',current :fill ,fill) *restorecmd*)
214
(funcall c :itemconfig current :fill "SteelBlue2")))
219
; (global :*restorecmd*)
220
(let ((tem *restorecmd*))
221
(setq *restorecmd* nil)
226
;; Utility procedures for stroking out a rectangle and printing what's
227
;; underneath the rectangle's area.
229
(defun itemMark (c x y)
230
; (global :areaX1 areaY1)
231
(setq areaX1 (funcall c :canvasx x :return 'string))
232
(setq areaY1 (funcall c :canvasy y :return 'string))
233
(funcall c :delete "area")
236
(defun itemStroke (c x y )
237
(declare (special areaX1 areaY1 areaX2 areaY2))
239
(let ((*recursive* t))
240
(setq x (funcall c :canvasx x :return 'string))
241
(setq y (funcall c :canvasy y :return 'string))
245
;; this next return 'stringis simply for TIMING!!!
246
;; to make it wait for the result before going into subsequent!!
247
(funcall c :delete "area" :return 'string)
248
(funcall c :addtag "area" "withtag"
249
(funcall c :create "rect" areaX1 areaY1 x y
250
:outline "black" :return 'string))
254
(defun itemsUnderArea (c)
255
; (global :areaX1 areaY1 areaX2 areaY2)
256
(setq area (funcall c :find "withtag" "area" :return 'string))
260
(funcall c :find "enclosed" areaX1 areaY1 areaX2 areaY2
261
:return 'list-strings))
262
(if (search "item" (funcall c :gettags i :return 'string))
263
(setq items (tk-conc items " " i))))
264
(print (tk-conc "Items enclosed by area: " items))
267
(funcall c :find "overlapping" areaX1 areaY1 areaX2 areaY2
268
:return 'list-strings))
269
(if (search "item" (funcall c :gettags i :return 'string))
270
(setq items (tk-conc items " " i))))
271
(print (tk-conc "Items overlapping area: " items))
281
;; Utility procedures to support dragging of items.
283
(defun itemStartDrag (c x y)
284
; (global :lastX lastY)
285
(setq lastX (funcall c :canvasx x :return 'number))
286
(setq lastY (funcall c :canvasy y :return 'number))
289
(defun itemDrag (c x y)
290
; (global :lastX lastY)
291
(setq x (funcall c :canvasx x :return 'number))
292
(setq y (funcall c :canvasy y :return 'number))
293
(funcall c :move "current" (- x lastX) (- y lastY))
298
(defvar *recursive* nil)
299
(defun itemDrag (c x y)
300
; (global :lastX lastY)
302
(t (let ((*recursive* t))
303
(setq x (funcall c :canvasx x :return 'number))
304
(setq y (funcall c :canvasy y :return 'number))
305
(funcall c :move "current" (- x lastX) (- y lastY))
309
;; Procedure that's invoked when the button embedded in the "canvas"
312
(defun butPress (w color)
313
(setq i (funcall w :create "text" "25c" "18.1c" :text "Ouch!!"
314
:fill color :anchor "n" :return 'string))
315
(after 500 (tk-conc w " delete " i))
318
(defvar *last-kill* "")
319
;(bind ".citems.frame2.c.entry" "<Control-KeyPress>" '(emacs-move %W %A ))
320
(defun emacs-move (a key)
322
;; if this window is from tcl it is not yet a lisp function.
323
;; steal it... build it into coerce-result...
324
(foo (or (fboundp win) (setf (symbol-function win)
325
(make-widget-instance win nil))))
326
(pos (funcall win :index "insert" :return 'number))
330
(case (setq char (aref key 0))
331
(#\^B (max 0 (- pos 1)))
332
(#\^F (max 0 (+ pos 1)))
335
; (print (list a char key))
337
(funcall win :icursor new))
339
(funcall win :delete pos ))
342
(setq *last-kill* (subseq (funcall win :get :return 'string) pos))
343
(funcall win :delete pos "end" ))
345
(funcall win :insert pos *last-kill*))
346
(t (funcall win :insert pos key)))))
added
removed
gcl-tk/demos/mkItems.lisp
