Mercurial > hg > xemacs-beta

comparison tests/glyph-test.el @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents 501cfd01ee6d
children e804706bfb8c
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
1 (set-extent-begin-glyph 1 (set-extent-begin-glyph
2 (make-extent (point) (point)) 2 (make-extent (point) (point))
3 (setq im (make-glyph [xpm :file "xemacs-icon.xpm"]))) 3 (setq icon (make-glyph [xpm :file "../etc/xemacs-icon.xpm"])))
4
5 (set-extent-begin-glyph
6 (make-extent (point) (point))
7 (make-glyph [string :data "xemacs"]))
8 4
9 (defun foo () 5 (defun foo ()
10 (interactive) 6 (interactive)
11 (setq ok-select (not ok-select))) 7 (setq ok-select (not ok-select)))
12
13 (defun fee () (interactive) (message "hello"))
14 8
15 ;; button in a group 9 ;; button in a group
16 (setq ok-select nil) 10 (setq ok-select nil)
17 (set-extent-begin-glyph 11 (set-extent-begin-glyph
18 (make-extent (point) (point)) 12 (make-extent (point) (point))
19 (setq radio-button1 13 (make-glyph [button :descriptor ["ok " (setq ok-select t)
20 (make-glyph 14 :style radio :selected ok-select]]))
21 [button :face widget
22 :descriptor ["ok1" (setq ok-select t)
23 :style radio :selected ok-select]])))
24 ;; button in a group 15 ;; button in a group
25 (set-extent-begin-glyph 16 (set-extent-begin-glyph
26 (make-extent (point) (point)) 17 (make-extent (point) (point))
27 (setq radio-button2 18 (make-glyph [button :descriptor ["ok" (setq ok-select nil) :style radio
28 (make-glyph 19 :selected (not ok-select)]]))
29 ` [button :descriptor ["ok2" (setq ok-select nil) :style radio
30 :selected (not ok-select)]])))
31 ;; toggle button
32 (set-extent-begin-glyph
33 (make-extent (point) (point))
34 (setq tbutton
35 (make-glyph [button :descriptor ["ok3" (setq ok-select nil)
36 :style toggle
37 :selected (not ok-select)]])))
38 (set-extent-begin-glyph
39 (make-extent (point) (point))
40 (setq toggle-button
41 (make-glyph [button :descriptor ["ok4" :style toggle
42 :callback
43 (setq ok-select (not ok-select))
44 :selected ok-select]])))
45
46 ;; normal pushbutton 20 ;; normal pushbutton
47 (set-extent-begin-glyph 21 (set-extent-begin-glyph
48 (make-extent (point) (point)) 22 (make-extent (point) (point))
49 (setq push-button 23 (setq pbutton (make-glyph
50 (make-glyph [button :width 10 :height 2 24 [button :width 10 :height 2
51 :face modeline-mousable 25 :face modeline-mousable
52 :descriptor "ok" :callback foo 26 :descriptor "ok" :callback foo
53 :selected t]))) 27 :selected t])))
54 ;; tree view
55 (set-extent-begin-glyph
56 (make-extent (point) (point))
57 (setq tree (make-glyph
58 [tree-view :width 10
59 :descriptor "My Tree"
60 :properties (:items (["One" foo]
61 (["Two" foo]
62 ["Four" foo]
63 "Six")
64 "Three"))])))
65
66 ;; tab control
67 (set-extent-begin-glyph
68 (make-extent (point) (point))
69 (setq tab (make-glyph
70 [tab-control :descriptor "My Tab"
71 :face highlight
72 :orientation right
73 :properties (:items (["One" foo :selected t]
74 ["Two" fee :selected nil]
75 ["Three" foo :selected nil]))])))
76
77 ;; progress gauge 28 ;; progress gauge
78 (set-extent-begin-glyph 29 (set-extent-begin-glyph
79 (make-extent (point) (point)) 30 (make-extent (point) (point))
80 (setq pgauge (make-glyph 31 (setq pgauge (make-glyph
81 [progress-gauge :width 10 :height 2 32 [progress :width 10 :height 2
82 :descriptor "ok"]))) 33 :descriptor "ok"])))
83 ;; progress the progress ... 34 ;; progress the progress ...
84 (let ((x 0)) 35 (let ((x 0))
85 (while (<= x 100) 36 (while (<= x 100)
86 (set-image-instance-property (glyph-image-instance pgauge) :value x) 37 (set-image-instance-property (glyph-image-instance pgauge) :percent x)
87 (setq x (+ x 5)) 38 (setq x (+ x 5))
88 (sit-for 0.1))) 39 (sit-for 0.1)))
89 40
90 ;; progress gauge in the modeline 41 ;; progress gauge in the modeline
91 (setq global-mode-string 42 (setq global-mode-string
92 (cons (make-extent nil nil) 43 (cons (make-extent nil nil)
93 (setq pg (make-glyph 44 (setq pg (make-glyph
94 [progress-gauge :width 5 :pixel-height 16 45 [progress :width 5 :pixel-height 16
95 :descriptor "ok"])))) 46 :descriptor "ok"]))))
96 ;; progress the progress ... 47 ;; progress the progress ...
97 (let ((x 0)) 48 (let ((x 0))
98 (while (<= x 100) 49 (while (<= x 100)
99 (set-image-instance-property (glyph-image-instance pg) :value x) 50 (set-image-instance-property (glyph-image-instance pg) :percent x)
100 (setq x (+ x 5)) 51 (setq x (+ x 5))
101 (sit-for 0.1))) 52 (sit-for 0.1)))
102 53
103 (set-extent-begin-glyph 54 (set-extent-begin-glyph
104 (make-extent (point) (point)) 55 (make-extent (point) (point))
105 (make-glyph 56 (make-glyph
106 [button :face modeline-mousable 57 [button :face modeline-mousable
107 :descriptor "ok" :callback foo 58 :descriptor "ok" :callback foo
108 :image [xpm :file "../etc/xemacs-icon.xpm"]])) 59 :image (make-glyph
60 [xpm :file "../etc/xemacs-icon.xpm"])]))
109 61
110 ;; normal pushbutton 62 ;; normal pushbutton
111 (set-extent-begin-glyph 63 (set-extent-begin-glyph
112 (make-extent (point) (point)) 64 (make-extent (point) (point))
113 (setq pbutton 65 (make-glyph [button :descriptor ["A Big Button" foo ]]))
114 (make-glyph [button :descriptor ["A Big Button" foo ]])))
115
116 ;; edit box 66 ;; edit box
117 (set-extent-begin-glyph 67 (set-extent-begin-glyph
118 (make-extent (point) (point)) 68 (make-extent (point) (point))
119 (setq edit-field (make-glyph [edit-field :pixel-width 50 :pixel-height 30 69 (setq hedit (make-glyph [edit :pixel-width 50 :pixel-height 30
120 :face bold-italic 70 :face bold-italic
121 :descriptor ["Hello"]]))) 71 :descriptor ["Hello"]])))
122 ;; combo box 72 ;; combo box
123 (set-extent-begin-glyph 73 (set-extent-begin-glyph
124 (make-extent (point) (point)) 74 (make-extent (point) (point))
125 (setq combo-box (make-glyph 75 (setq hcombo (make-glyph
126 [combo-box :width 10 :descriptor ["Hello"] 76 [combo :width 10 :height 3 :descriptor ["Hello"]
127 :properties (:items ("One" "Two" "Three"))]))) 77 :properties (:items ("One" "Two" "Three"))])))
128 78
129 ;; label 79 ;; line
130 (set-extent-begin-glyph 80 (set-extent-begin-glyph
131 (make-extent (point) (point)) 81 (make-extent (point) (point))
132 (setq label (make-glyph [label :pixel-width 150 :descriptor "Hello"]))) 82 (make-glyph [label :pixel-width 150 :descriptor "Hello"]))
133
134 ;; string
135 (set-extent-begin-glyph
136 (make-extent (point) (point))
137 (setq str (make-glyph [string :data "Hello There"])))
138 83
139 ;; scrollbar 84 ;; scrollbar
140 ;(set-extent-begin-glyph 85 ;(set-extent-begin-glyph
141 ; (make-extent (point) (point)) 86 ; (make-extent (point) (point))
142 ; (make-glyph [scrollbar :width 50 :height 20 :descriptor ["Hello"]])) 87 ; (make-glyph [scrollbar :width 50 :height 20 :descriptor ["Hello"]]))
143 88
144 ;; generic subwindow 89 ;; generic subwindow
145 (setq sw (make-glyph [subwindow :pixel-width 50 :pixel-height 70])) 90 (setq sw (make-glyph [subwindow :pixel-width 50 :pixel-height 50]))
146 (set-extent-begin-glyph (make-extent (point) (point)) sw) 91 (set-extent-begin-glyph (make-extent (point) (point)) sw)
147 92
148 ;; layout
149 (setq layout
150 (make-glyph
151 [layout :descriptor "The Layout"
152 :orientation vertical
153 :justify left
154 :border [string :data "Hello There Mrs"]
155 :items ([native-layout :orientation horizontal
156 :items (radio-button1 radio-button2)]
157 edit-field toggle-button label str)]))
158 (set-glyph-face layout 'gui-element)
159 (set-extent-begin-glyph
160 (make-extent (point) (point)) layout)
161
162 (setq test-toggle-widget nil)
163
164 (defun test-toggle (widget)
165 (set-extent-begin-glyph
166 (make-extent (point) (point))
167 (make-glyph (vector 'button
168 :descriptor "ok"
169 :style 'toggle
170 :selected `(funcall test-toggle-value
171 ,widget)
172 :callback `(funcall test-toggle-action
173 ,widget)))))
174
175 (defun test-toggle-action (widget &optional event)
176 (if widget
177 (message "Widget is t")
178 (message "Widget is nil")))
179
180 (defun test-toggle-value (widget)
181 (setq widget (not widget))
182 (not widget))