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