--- /dev/null
+;;; generic-widgets.el --- Generic UI building
+
+;; Copyright (C) 2000 Free Software Foundation
+
+;; Maintainer: William Perry <wmperry@gnu.org>
+;; Keywords: extensions, dumped
+
+;; This file is part of XEmacs.
+
+;; XEmacs is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XEmacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING. If not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
+
+;;; Synched up with: Not in FSF
+
+;;; Commentary:
+
+;; This file is dumped with XEmacs.
+
+(defun build-ui (ui)
+ (if (null ui)
+ (gtk-label-new "[empty]")
+ (let ((builder-func (intern-soft (format "build-ui::%s" (car ui))))
+ (widget nil))
+ (if (and builder-func (fboundp builder-func))
+ (progn
+ (setq widget (funcall builder-func ui))
+ (setcdr ui (plist-put (cdr ui) :x-internal-widget widget))
+ widget)
+ (error "Unknown ui element: %s" (car ui))))))
+
+(defun show-ui (ui)
+ (let ((widget (plist-get (cdr ui) :x-internal-widget)))
+ (if (not widget)
+ (error "Attempting to show unrealized UI"))
+ (gtk-widget-show-all widget)
+ (gtk-signal-connect widget 'destroy
+ (lambda (widget ui)
+ (setcdr ui (plist-put (cdr ui) :x-internal-widget nil))) ui)))
+
+
+(defun build-ui::window (spec)
+ "Create a top-level window for containing other widgets.
+Properties:
+:items list A list of child UI specs. Only the first is used.
+:type toplevel/dialog/popup What type of window to create. Window managers
+ can (and usually do) treat each type differently.
+"
+ (let ((plist (cdr spec))
+ (window nil)
+ (child nil))
+ (setq window (gtk-window-new (plist-get plist :type 'toplevel))
+ child (build-ui (car (plist-get plist :items))))
+ (gtk-container-add window child)
+ window))
+
+(defun build-ui::box (spec)
+ "Create a box for containing other widgets.
+Properties:
+:items list A list of child UI specs.
+:homogeneous t/nil Whether all children are the same width/height.
+:spacing number Spacing between children.
+:orientation horizontal/vertical How the widgets are stacked.
+
+Additional properties on child widgets:
+:expand t/nil Whether the new child is to be given extra space
+ allocated to box. The extra space will be divided
+ evenly between all children of box that use this
+ option.
+:fill t/nil Whether space given to child by the expand option is
+ actually allocated to child, rather than just padding
+ it. This parameter has no effect if :expand is set to
+ nil. A child is always allocated the full height of a
+ horizontal box and the full width of a vertical box.
+ This option affects the other dimension.
+:padding number Extra padding around this widget.
+"
+ (let* ((plist (cdr spec))
+ (orientation (plist-get plist :orientation 'horizontal))
+ (children (plist-get plist :items))
+ (box nil)
+ (child-widget nil)
+ (child-plist nil))
+ (case orientation
+ (vertical (setq box (gtk-vbox-new (plist-get plist :homogeneous)
+ (plist-get plist :spacing))))
+ (horizontal (setq box (gtk-hbox-new (plist-get plist :homogeneous)
+ (plist-get plist :spacing))))
+ (otherwise (error "Unknown orientation for box: %s" orientation)))
+ (mapc
+ (lambda (child)
+ (setq child-plist (cdr child)
+ child-widget (build-ui child))
+ (if (listp child-widget)
+ (mapc (lambda (w)
+ (gtk-box-pack-start box w
+ (plist-get child-plist :expand)
+ (plist-get child-plist :fill)
+ (plist-get child-plist :padding))) child-widget)
+ (gtk-box-pack-start box child-widget
+ (plist-get child-plist :expand)
+ (plist-get child-plist :fill)
+ (plist-get child-plist :padding))))
+ children)
+ box))
+
+(defun build-ui::tab-control (spec)
+ "Create a notebook widget.
+Properties:
+:items list A list of UI specs to use as notebook pages.
+:homogeneous t/nil Whether all tabs are the same width.
+:orientation top/bottom/left/right Position of tabs
+:show-tabs t/nil Show the tabs on screen?
+:scrollable t/nil Allow scrolling to view all tab widgets?
+
+Additional properties on child widgets:
+:tab-label ui A UI spec to use for the tab label.
+"
+ (let* ((plist (cdr spec))
+ (notebook (gtk-notebook-new))
+ (children (plist-get plist :items))
+ (page-counter 1)
+ (label-widget nil)
+ (child-widget nil)
+ (child-plist nil))
+ ;; Set all the properties
+ (gtk-notebook-set-homogeneous-tabs notebook (plist-get plist :homogeneous))
+ (gtk-notebook-set-scrollable notebook (plist-get plist :scrollable t))
+ (gtk-notebook-set-show-tabs notebook (plist-get plist :show-tabs t))
+ (gtk-notebook-set-tab-pos notebook (plist-get plist :orientation 'top))
+
+ ;; Now fill in the tabs
+ (mapc
+ (lambda (child)
+ (setq child-plist (cdr child)
+ child-widget (build-ui child)
+ label-widget (build-ui (plist-get child-plist :tab-label
+ (list 'label :text (format "tab %d" page-counter))))
+ page-counter (1+ page-counter))
+ (gtk-notebook-append-page notebook child-widget label-widget))
+ children)
+ notebook))
+
+(defun build-ui::text (spec)
+ "Create a multi-line text widget.
+Properties:
+:editable t/nil Whether the user can change the contents
+:word-wrap t/nil Automatic word wrapping?
+:line-wrap t/nil Automatic line wrapping?
+:text string Initial contents of the widget
+:file filename File for initial contents (takes precedence over :text)
+:face facename XEmacs face to use in the widget.
+"
+ (let* ((plist (cdr spec))
+ (text (gtk-text-new nil nil))
+ (face (plist-get plist :face 'default))
+ (info (plist-get plist :text))
+ (file (plist-get plist :file)))
+ (gtk-text-set-editable text (plist-get plist :editable))
+ (gtk-text-set-word-wrap text (plist-get plist :word-wrap))
+ (gtk-text-set-line-wrap text (plist-get plist :line-wrap))
+ (gtk-widget-set-style text 'default)
+
+ ;; Possible convert the file portion
+ (if (and file (not (stringp file)))
+ (setq file (eval file)))
+
+ (if (and info (not (stringp info)))
+ (setq info (eval info)))
+
+ (if (and file (file-exists-p file) (file-readable-p file))
+ (save-excursion
+ (set-buffer (get-buffer-create " *improbable buffer name*"))
+ (insert-file-contents file)
+ (setq info (buffer-string))))
+
+ (gtk-text-insert text
+ (face-font face)
+ (face-foreground face)
+ (face-background face)
+ info (length info))
+ text))
+
+(defun build-ui::label (spec)
+ "Create a label widget.
+Properties:
+:text string Text inside the label
+:face facename XEmacs face to use in the widget.
+:justification right/left/center How to justify the text.
+"
+ (let* ((plist (cdr spec))
+ (label (gtk-label-new (plist-get plist :text))))
+ (gtk-label-set-line-wrap label t)
+ (gtk-label-set-justify label (plist-get plist :justification))
+ (gtk-widget-set-style label (plist-get plist :face 'default))
+ label))
+
+(defun build-ui::pixmap (spec)
+ "Create a multi-line text widget.
+Properties:
+:text string Text inside the label
+:face facename XEmacs face to use in the widget.
+:justification right/left/center How to justify the text.
+"
+ (let* ((plist (cdr spec))
+ (label (gtk-label-new (plist-get plist :text))))
+ (gtk-label-set-line-wrap label t)
+ (gtk-label-set-justify label (plist-get plist :justification))
+ (gtk-widget-set-style label (plist-get plist :face 'default))
+ label))
+
+(defun build-ui::radio-group (spec)
+ "A convenience when specifying a group of radio buttons."
+ (let ((build-ui::radio-group nil))
+ (mapcar 'build-ui (plist-get (cdr spec) :items))))
+
+(defun build-ui::button (spec)
+ "Create a button widget.
+Properties:
+:type radio/check/toggle/nil What type of button to create.
+:text string Text in the button.
+:glyph glyph Image in the button.
+:label ui A UI spec to use for the label.
+:relief normal/half/none How to draw button edges.
+
+NOTE: Radio buttons must be in a radio-group object for them to work.
+"
+ (let ((plist (cdr spec))
+ (button nil)
+ (button-type (plist-get plist :type 'normal))
+ (label nil))
+ (case button-type
+ (radio
+ (if (not (boundp 'build-ui::radio-group))
+ (error "Attempt to use a radio button outside a radio-group"))
+ (setq button (gtk-radio-button-new build-ui::radio-group)
+ build-ui::radio-group (gtk-radio-button-group button)))
+ (check
+ (setq button (gtk-check-button-new)))
+ (toggle
+ (setq button (gtk-toggle-button-new)))
+ (normal
+ (setq button (gtk-button-new)))
+ (otherwise
+ (error "Unknown button type: %s" button-type)))
+ (gtk-container-add
+ button
+ (build-ui (plist-get plist :label
+ (list 'label :text
+ (plist-get plist
+ :text (format "%s button" button-type))))))
+ button))
+
+(defun build-ui::progress-gauge (spec)
+ "Create a progress meter.
+Properties:
+:orientation left-to-right/right-to-left/top-to-bottom/bottom-to-top
+:type discrete/continuous
+
+"
+ (let ((plist (cdr spec))
+ (gauge (gtk-progress-bar-new)))
+ (gtk-progress-bar-set-orientation gauge (plist-get plist :orientation 'left-to-right))
+ (gtk-progress-bar-set-bar-style gauge (plist-get plist :type 'continuous))
+ gauge))
+
+(provide 'generic-widgets)
+
+(when (featurep 'gtk) ; just loading this file should be OK
+(gtk-widget-show-all
+ (build-ui
+ '(window :type dialog
+ :items ((tab-control
+ :homogeneous t
+ :orientation bottom
+ :items ((box :orientation vertical
+ :tab-label (label :text "vertical")
+ :items ((label :text "Vertical")
+ (progress-gauge)
+ (label :text "Box stacking")))
+ (box :orientation horizontal
+ :spacing 10
+ :items ((label :text "Horizontal box")
+ (label :text "stacking")))
+
+ (box :orientation vertical
+ :items
+ ((radio-group
+ :items ((button :type radio
+ :expand nil
+ :fill nil
+ :text "Item 1")
+ (button :type radio
+ :expand nil
+ :fill nil
+ :text "Item 2")
+ (button :type radio
+ :expand nil
+ :fill nil
+ :text "Item 3")
+ (button :type radio
+ :expand nil
+ :fill nil)))))
+ (box :orientation vertical
+ :items ((button :type check
+ :text "Item 1")
+ (button :type check
+ :text "Item 2")
+ (button :type normal
+ :text "Item 3")
+ (button :type toggle)))
+ (text :editable t
+ :word-wrap t
+ :file (locate-data-file "COPYING"))
+ (text :editable t
+ :face display-time-mail-balloon-enhance-face
+ :word-wrap t
+ :text "Text with a face on it")))))))
+)
projects / chise / xemacs-chise.git / blobdiff