(U+7081): Use `->subsumptive'; unify S-4044; add `<-formed' for
[chise/xemacs-chise.git.1] / lisp / generic-widgets.el
1 ;;; generic-widgets.el --- Generic UI building
2
3 ;; Copyright (C) 2000 Free Software Foundation
4
5 ;; Maintainer: William Perry <wmperry@gnu.org>
6 ;; Keywords: extensions, dumped
7
8 ;; This file is part of XEmacs.
9
10 ;; XEmacs is free software; you can redistribute it and/or modify it
11 ;; under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
14
15 ;; XEmacs is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18 ;; General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
23 ;; 02111-1307, USA.
24
25 ;;; Synched up with: Not in FSF
26
27 ;;; Commentary:
28
29 ;; This file is dumped with XEmacs.
30
31 (defun build-ui (ui)
32   (if (null ui)
33       (gtk-label-new "[empty]")
34     (let ((builder-func (intern-soft (format "build-ui::%s" (car ui))))
35           (widget nil))
36       (if (and builder-func (fboundp builder-func))
37           (progn
38             (setq widget (funcall builder-func ui))
39             (setcdr ui (plist-put (cdr ui) :x-internal-widget widget))
40             widget)
41         (error "Unknown ui element: %s" (car ui))))))
42
43 (defun show-ui (ui)
44   (let ((widget (plist-get (cdr ui) :x-internal-widget)))
45     (if (not widget)
46         (error "Attempting to show unrealized UI"))
47     (gtk-widget-show-all widget)
48     (gtk-signal-connect widget 'destroy
49                         (lambda (widget ui)
50                           (setcdr ui (plist-put (cdr ui) :x-internal-widget nil))) ui)))
51
52
53 (defun build-ui::window (spec)
54   "Create a top-level window for containing other widgets.
55 Properties:
56 :items          list                    A list of child UI specs.  Only the first is used.
57 :type           toplevel/dialog/popup   What type of window to create.  Window managers
58                                         can (and usually do) treat each type differently.
59 "
60   (let ((plist (cdr spec))
61         (window nil)
62         (child nil))
63     (setq window (gtk-window-new (plist-get plist :type 'toplevel))
64           child (build-ui (car (plist-get plist :items))))
65     (gtk-container-add window child)
66     window))
67
68 (defun build-ui::box (spec)
69   "Create a box for containing other widgets.
70 Properties:
71 :items          list                    A list of child UI specs.
72 :homogeneous    t/nil                   Whether all children are the same width/height.
73 :spacing        number                  Spacing between children.
74 :orientation    horizontal/vertical     How the widgets are stacked.
75
76 Additional properties on child widgets:
77 :expand         t/nil           Whether the new child is to be given extra space
78                                 allocated to box. The extra space will be divided
79                                 evenly between all children of box that use this
80                                 option.
81 :fill           t/nil           Whether space given to child by the expand option is
82                                 actually allocated to child, rather than just padding
83                                 it. This parameter has no effect if :expand is set to
84                                 nil. A child is always allocated the full height of a
85                                 horizontal box and the full width of a vertical box.
86                                 This option affects the other dimension.
87 :padding        number          Extra padding around this widget.
88 "
89   (let* ((plist (cdr spec))
90          (orientation (plist-get plist :orientation 'horizontal))
91          (children (plist-get plist :items))
92          (box nil)
93          (child-widget nil)
94          (child-plist nil))
95     (case orientation
96       (vertical (setq box (gtk-vbox-new (plist-get plist :homogeneous)
97                                         (plist-get plist :spacing))))
98       (horizontal (setq box (gtk-hbox-new (plist-get plist :homogeneous)
99                                           (plist-get plist :spacing))))
100       (otherwise (error "Unknown orientation for box: %s" orientation)))
101     (mapc
102      (lambda (child)
103        (setq child-plist (cdr child)
104              child-widget (build-ui child))
105        (if (listp child-widget)
106            (mapc (lambda (w)
107                    (gtk-box-pack-start box w
108                                        (plist-get child-plist :expand)
109                                        (plist-get child-plist :fill)
110                                        (plist-get child-plist :padding))) child-widget)
111          (gtk-box-pack-start box child-widget
112                              (plist-get child-plist :expand)
113                              (plist-get child-plist :fill)
114                              (plist-get child-plist :padding))))
115      children)
116     box))
117
118 (defun build-ui::tab-control (spec)
119   "Create a notebook widget.
120 Properties:
121 :items          list            A list of UI specs to use as notebook pages.
122 :homogeneous    t/nil           Whether all tabs are the same width.
123 :orientation    top/bottom/left/right   Position of tabs
124 :show-tabs      t/nil           Show the tabs on screen?
125 :scrollable     t/nil           Allow scrolling to view all tab widgets?
126
127 Additional properties on child widgets:
128 :tab-label      ui              A UI spec to use for the tab label.
129 "
130   (let* ((plist (cdr spec))
131          (notebook (gtk-notebook-new))
132          (children (plist-get plist :items))
133          (page-counter 1)
134          (label-widget nil)
135          (child-widget nil)
136          (child-plist nil))
137     ;; Set all the properties
138     (gtk-notebook-set-homogeneous-tabs notebook (plist-get plist :homogeneous))
139     (gtk-notebook-set-scrollable notebook (plist-get plist :scrollable t))
140     (gtk-notebook-set-show-tabs notebook (plist-get plist :show-tabs t))
141     (gtk-notebook-set-tab-pos notebook (plist-get plist :orientation 'top))
142
143     ;; Now fill in the tabs
144     (mapc
145      (lambda (child)
146        (setq child-plist (cdr child)
147              child-widget (build-ui child)
148              label-widget (build-ui (plist-get child-plist :tab-label
149                                                (list 'label :text (format "tab %d" page-counter))))
150              page-counter (1+ page-counter))
151        (gtk-notebook-append-page notebook child-widget label-widget))
152      children)
153     notebook))
154
155 (defun build-ui::text (spec)
156   "Create a multi-line text widget.
157 Properties:
158 :editable       t/nil           Whether the user can change the contents
159 :word-wrap      t/nil           Automatic word wrapping?
160 :line-wrap      t/nil           Automatic line wrapping?
161 :text           string          Initial contents of the widget
162 :file           filename        File for initial contents (takes precedence over :text)
163 :face           facename        XEmacs face to use in the widget.
164 "
165   (let* ((plist (cdr spec))
166          (text (gtk-text-new nil nil))
167          (face (plist-get plist :face 'default))
168          (info (plist-get plist :text))
169          (file (plist-get plist :file)))
170     (gtk-text-set-editable text (plist-get plist :editable))
171     (gtk-text-set-word-wrap text (plist-get plist :word-wrap))
172     (gtk-text-set-line-wrap text (plist-get plist :line-wrap))
173     (gtk-widget-set-style text 'default)
174
175     ;; Possible convert the file portion
176     (if (and file (not (stringp file)))
177         (setq file (eval file)))
178
179     (if (and info (not (stringp info)))
180         (setq info (eval info)))
181
182     (if (and file (file-exists-p file) (file-readable-p file))
183         (save-excursion
184           (set-buffer (get-buffer-create " *improbable buffer name*"))
185           (insert-file-contents file)
186           (setq info (buffer-string))))
187
188     (gtk-text-insert text
189                      (face-font face)
190                      (face-foreground face)
191                      (face-background face)
192                      info (length info))
193     text))
194
195 (defun build-ui::label (spec)
196   "Create a label widget.
197 Properties:
198 :text           string                  Text inside the label
199 :face           facename                XEmacs face to use in the widget.
200 :justification  right/left/center       How to justify the text.
201 "
202   (let* ((plist (cdr spec))
203          (label (gtk-label-new (plist-get plist :text))))
204     (gtk-label-set-line-wrap label t)
205     (gtk-label-set-justify label (plist-get plist :justification))
206     (gtk-widget-set-style label (plist-get plist :face 'default))
207     label))
208
209 (defun build-ui::pixmap (spec)
210   "Create a multi-line text widget.
211 Properties:
212 :text           string                  Text inside the label
213 :face           facename                XEmacs face to use in the widget.
214 :justification  right/left/center       How to justify the text.
215 "
216   (let* ((plist (cdr spec))
217          (label (gtk-label-new (plist-get plist :text))))
218     (gtk-label-set-line-wrap label t)
219     (gtk-label-set-justify label (plist-get plist :justification))
220     (gtk-widget-set-style label (plist-get plist :face 'default))
221     label))
222
223 (defun build-ui::radio-group (spec)
224   "A convenience when specifying a group of radio buttons."
225   (let ((build-ui::radio-group nil))
226     (mapcar 'build-ui (plist-get (cdr spec) :items))))
227
228 (defun build-ui::button (spec)
229   "Create a button widget.
230 Properties:
231 :type           radio/check/toggle/nil  What type of button to create.
232 :text           string                  Text in the button.
233 :glyph          glyph                   Image in the button.
234 :label          ui                      A UI spec to use for the label.
235 :relief         normal/half/none        How to draw button edges.
236
237 NOTE: Radio buttons must be in a radio-group object for them to work.
238 "
239   (let ((plist (cdr spec))
240         (button nil)
241         (button-type (plist-get plist :type 'normal))
242         (label nil))
243     (case button-type
244       (radio
245        (if (not (boundp 'build-ui::radio-group))
246            (error "Attempt to use a radio button outside a radio-group"))
247        (setq button (gtk-radio-button-new build-ui::radio-group)
248              build-ui::radio-group (gtk-radio-button-group button)))
249       (check
250        (setq button (gtk-check-button-new)))
251       (toggle
252        (setq button (gtk-toggle-button-new)))
253       (normal
254        (setq button (gtk-button-new)))
255       (otherwise
256        (error "Unknown button type: %s" button-type)))
257     (gtk-container-add
258      button
259      (build-ui (plist-get plist :label
260                           (list 'label :text
261                                 (plist-get plist
262                                            :text (format "%s button" button-type))))))
263     button))
264
265 (defun build-ui::progress-gauge (spec)
266   "Create a progress meter.
267 Properties:
268 :orientation            left-to-right/right-to-left/top-to-bottom/bottom-to-top
269 :type                   discrete/continuous
270
271 "
272   (let ((plist (cdr spec))
273         (gauge (gtk-progress-bar-new)))
274     (gtk-progress-bar-set-orientation gauge (plist-get plist :orientation 'left-to-right))
275     (gtk-progress-bar-set-bar-style gauge (plist-get plist :type 'continuous))
276     gauge))
277
278 (provide 'generic-widgets)
279
280 (when (featurep 'gtk)                   ; just loading this file should be OK
281 (gtk-widget-show-all
282   (build-ui
283    '(window :type dialog
284             :items ((tab-control
285                      :homogeneous t
286                      :orientation bottom
287                      :items ((box :orientation vertical
288                                   :tab-label (label :text "vertical")
289                                   :items ((label :text "Vertical")
290                                           (progress-gauge)                                        
291                                           (label :text "Box stacking")))
292                              (box :orientation horizontal
293                                   :spacing 10
294                                   :items ((label :text "Horizontal box")
295                                           (label :text "stacking")))
296
297                              (box :orientation vertical
298                                   :items
299                                   ((radio-group
300                                     :items ((button :type radio
301                                                     :expand nil
302                                                     :fill nil
303                                                     :text "Item 1")
304                                             (button :type radio
305                                                     :expand nil
306                                                     :fill nil
307                                                     :text "Item 2")
308                                             (button :type radio
309                                                     :expand nil
310                                                     :fill nil
311                                                     :text "Item 3")
312                                             (button :type radio
313                                                     :expand nil
314                                                     :fill nil)))))
315                              (box :orientation vertical
316                                   :items ((button :type check
317                                                   :text "Item 1")
318                                           (button :type check
319                                                   :text "Item 2")
320                                           (button :type normal
321                                                   :text "Item 3")
322                                           (button :type toggle)))
323                              (text :editable t
324                                    :word-wrap t
325                                    :file (locate-data-file "COPYING"))
326                              (text :editable t
327                                    :face display-time-mail-balloon-enhance-face
328                                    :word-wrap t
329                                    :text "Text with a face on it")))))))
330 )