git.chise.org Git - chise/xemacs-chise.git-/blob - 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 )