From d520140e95b8e6caca1ec6d1d82ee6aaacfa28ea Mon Sep 17 00:00:00 2001 Message-Id: From: Mark Wooding Date: Thu, 5 Oct 2000 17:30:07 +0000 Subject: [PATCH] More widgets made working, numerous improvements Organization: Straylight/Edgeware From: espen --- gtk/gtk.lisp | 862 +++++++++++++++++++++++----------------------- gtk/gtktypes.lisp | 579 +++++++++++++++++++++++-------- 2 files changed, 867 insertions(+), 574 deletions(-) diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp index 7dce09d..658d238 100644 --- a/gtk/gtk.lisp +++ b/gtk/gtk.lisp @@ -15,7 +15,7 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;; $Id: gtk.lisp,v 1.2 2000-09-04 22:23:34 espen Exp $ +;; $Id: gtk.lisp,v 1.3 2000-10-05 17:30:07 espen Exp $ (in-package "GTK") @@ -41,10 +41,6 @@ (defun gtk-version () -;;; should be moved to gobject - - - ;;; Label (define-foreign label-new () label @@ -107,13 +103,13 @@ (define-foreign pixmap-set () nil (defun (setf pixmap-source) (source pixmap) (if (typep source 'gdk:pixmap) - (pixmap-set pximap source (pixmap-mask pixmap)) + (pixmap-set pixmap source (pixmap-mask pixmap)) (multiple-value-bind (source mask) (gdk:pixmap-create source) (pixmap-set pixmap source mask))) source) (defun (setf pixmap-mask) (mask pixmap) - (pixmap-set pximap (pixmap-source pixmap) mask) + (pixmap-set pixmap (pixmap-source pixmap) mask) mask) (define-foreign ("gtk_pixmap_get" pixmap-source) () nil @@ -140,6 +136,20 @@ (defun (setf bin-child) (child bin) (container-add bin child) child) +(defmethod initialize-instance ((bin bin) &rest initargs &key child) + (declare (ignore initargs)) + (call-next-method) + (cond + ((consp child) + (container-add bin (first child)) + (setf + (slot-value (first child) 'child-slots) + (apply + #'make-instance + (slot-value (class-of bin) 'child-class) + :parent bin :child (first child) (cdr child)))) + (child + (container-add bin child)))) ;;; Alignment @@ -246,34 +256,34 @@ (defmethod (setf button-label) ((label string) (button check-button)) ;;; Radio button -(define-foreign %radio-button-new () radio-button - (group (or null radio-button-group))) - (define-foreign %radio-button-new-with-label-from-widget () radio-button - (widget (or null widget)) + (widget (or null radio-button)) (label string)) (define-foreign %radio-button-new-from-widget () radio-button - (widget (or null widget))) + (widget (or null radio-button))) -(define-foreign %radio-button-new-with-label () radio-button - (group (or null radio-button-group)) - (label string)) +(defun radio-button-new (&optional label group-with) + (if label + (%radio-button-new-with-label-from-widget group-with label)) + (%radio-button-new-from-widget group-with)) -(defun radio-button-new (group &key label from-widget) - (cond - ((and from-widget label) - (%radio-button-new-with-label-from-widget group label)) - (from-widget - (%radio-button-new-from-widget group)) - (label - (%radio-button-new-with-label group label)) - (t - (%radio-button-new group)))) - -; (define-foreign radio-button-group () radio-button-group -; (radio-button radio-button)) +(define-foreign ("gtk_radio_button_group" %radio-button-get-group) () pointer + (radio-button radio-button)) + +(define-foreign %radio-button-set-group () nil + (radio-button radio-button) + (group pointer)) +(defun radio-button-add-to-group (button1 button2) + "Add BUTTON1 to the group which BUTTON2 belongs to." + (%radio-button-set-group button1 (%radio-button-get-group button2))) + +(defmethod initialize-instance ((button radio-button) + &rest initargs &key group) + (call-next-method) + (when group + (radio-button-add-to-group item group))) ;;; Option menu @@ -391,19 +401,40 @@ (define-foreign check-menu-item-toggled () nil ;;; Radio menu item -(define-foreign %radio-menu-item-new - () radio-menu-item - (group (or null radio-menu-item-group))) +(define-foreign %radio-menu-item-new () radio-menu-item + (group pointer)) (define-foreign %radio-menu-item-new-with-label () radio-menu-item - (group (or null radio-menu-item-group)) + (group pointer) (label string)) -(defun radio-menu-item-new (group &optional label) - (if label - (%radio-menu-item-new-with-label group label) - (%radio-menu-item-new group))) - +(define-foreign + ("gtk_radio_menu_item_group" %radio-menu-item-get-group) () pointer + (radio-menu-item radio-menu-item)) + +(define-foreign %radio-menu-item-set-group () nil + (radio-menu-item radio-menu-item) + (group pointer)) + +(defun radio-menu-item-new (&optional label group-with) + (let ((group + (if group-with + (%radio-menu-item-get-group group-with) + (make-pointer 0)))) + (if label + (%radio-menu-item-new-with-label group label) + (%radio-menu-item-new group)))) + +(defun radio-menu-item-add-to-group (item1 item2) + "Add ITEM1 to the group which ITEM2 belongs to." + (%radio-menu-item-set-group item1 (%radio-menu-item-get-group item2))) + +(defmethod initialize-instance ((item radio-menu-item) + &rest initargs &key group) + (call-next-method) + (when group + (radio-menu-item-add-to-group item group))) + ;;; Tearoff menu item @@ -513,18 +544,16 @@ (define-foreign window-set-transient-for () nil -;;; Color selection dialog - -; (define-foreign color-selection-dialog-new () color-selection-dialog -; (title string)) - - - ;;; Dialog (define-foreign dialog-new () dialog) +;;; Color selection dialog + +(define-foreign color-selection-dialog-new () color-selection-dialog + (title string)) + ;;; Input dialog @@ -534,18 +563,18 @@ (define-foreign input-dialog-new () dialog) ;;; File selection -; (define-foreign file-selection-new () file-selection -; (title string)) +(define-foreign file-selection-new () file-selection + (title string)) -; (define-foreign file-selection-complete () nil -; (file-selection file-selection) -; (pattern string)) +(define-foreign file-selection-complete () nil + (file-selection file-selection) + (pattern string)) -; (define-foreign file-selection-show-fileop-buttons () nil -; (file-selection file-selection)) +(define-foreign file-selection-show-fileop-buttons () nil + (file-selection file-selection)) -; (define-foreign file-selection-hide-fileop-buttons () nil -; (file-selection file-selection)) +(define-foreign file-selection-hide-fileop-buttons () nil + (file-selection file-selection)) @@ -627,61 +656,26 @@ (define-foreign box-set-child-packing () nil ;;; Button box (define-foreign ("gtk_button_box_get_child_size_default" - button-box-default-child-size) () nil + button-box-get-default-child-size) () nil (min-width int :out) (min-height int :out)) -(define-foreign ("gtk_button_box_get_child_ipadding_default" - button-box-default-child-ipadding) () nil - (ipad-x int :out) - (ipad-y int :out)) - -(define-foreign %button-box-set-child-size-default () nil +(define-foreign ("gtk_button_box_set_child_size_default" + button-box-set-default-child-size) () nil (min-width int) (min-height int)) -(defun (setf button-box-default-child-size) (size) - (%button-box-set-child-size-default (svref size 0) (svref size 1)) - (values (svref size 0) (svref size 1))) - -(define-foreign %button-box-set-child-ipadding-default () nil - (ipad-x int) - (ipad-y int)) - -(defun (setf button-box-default-child-ipadding) (ipad) - (%button-box-set-child-ipadding-default (svref ipad 0) (svref ipad 1)) - (values (svref ipad 0) (svref ipad 1))) - -(define-foreign - ("gtk_button_box_get_child_size" button-box-child-size) () nil - (button-box button-box) - (min-width int :out) - (min-height int :out)) - -(define-foreign - ("gtk_button_box_get_child_ipadding" button-box-child-ipadding) () nil - (button-box button-box) +(define-foreign ("gtk_button_box_get_child_ipadding_default" + button-box-get-default-child-ipadding) () nil (ipad-x int :out) (ipad-y int :out)) -(define-foreign %button-box-set-child-size () nil - (button-box button-box) - (min-width int) - (min-height int)) - -(defun (setf button-box-child-size) (size button-box) - (%button-box-set-child-size button-box (svref size 0) (svref size 1)) - (values (svref size 0) (svref size 1))) -(define-foreign %button-box-set-child-ipadding () nil - (button-box button-box) +(define-foreign ("gtk_button_box_get_child_ipadding_default" + button-box-set-default-child-ipadding) () nil (ipad-x int) (ipad-y int)) -(defun (setf button-box-child-ipadding) (ipad button-box) - (%button-box-set-child-ipadding button-box (svref ipad 0) (svref ipad 1)) - (values (svref ipad 0) (svref ipad 1))) - ;;; HButton box @@ -691,17 +685,21 @@ (define-foreign hbutton-box-new () hbutton-box) (define-foreign ("gtk_hbutton_box_get_spacing_default" hbutton-box-default-spacing) () int) -(define-foreign ("gtk_hbutton_box_set_spacing_default" - (setf hbutton-box-default-spacing)) () nil +(define-foreign %hbutton-box-set-spacing-default () nil (spacing int)) + +(defun (setf hbutton-box-default-spacing) (spacing) + (%hbutton-box-set-spacing-default spacing)) (define-foreign ("gtk_hbutton_box_get_layout_default" hbutton-box-default-layout) () button-box-style) -(define-foreign ("gtk_hbutton_box_set_layout_default" - (setf hbutton-box-default-layout)) () nil +(define-foreign %hbutton-box-set-layout-default () nil (layout button-box-style)) +(defun (setf hbutton-box-default-layout) (layout) + (%hbutton-box-set-layout-default layout)) + ;;; VButton Box @@ -711,17 +709,21 @@ (define-foreign vbutton-box-new () vbutton-box) (define-foreign ("gtk_vbutton_box_get_spacing_default" vbutton-box-default-spacing) () int) -(define-foreign ("gtk_vbutton_box_set_spacing_default" - (setf vbutton-box-default-spacing)) () nil +(define-foreign %vbutton-box-set-spacing-default () nil (spacing int)) + +(defun (setf vbutton-box-default-spacing) (spacing) + (%vbutton-box-set-spacing-default spacing)) (define-foreign ("gtk_vbutton_box_get_layout_default" vbutton-box-default-layout) () button-box-style) -(define-foreign ("gtk_vbutton_box_set_layout_default" - (setf vbutton-box-default-layout)) () nil +(define-foreign %vbutton-box-set-layout-default () nil (layout button-box-style)) +(defun (setf vbutton-box-default-layout) (layout) + (%vbutton-box-set-layout-default layout)) + ;;; VBox @@ -734,46 +736,79 @@ (define-foreign vbox-new () vbox ;;; Color selection -; (define-foreign color-selection-new () color-selection) +(define-foreign color-selection-new () color-selection) -; ;; gtkglue.c -; (define-foreign %color-selection-set-color-by-values () nil -; (colorsel color-selection) -; (red double-float) -; (green double-float) -; (blue double-float) -; (opacity double-float)) - -; (defun (setf color-selection-color) (color colorsel) -; (%color-selection-set-color-by-values -; colorsel -; (svref color 0) (svref color 1) (svref color 2) -; (if (> (length color) 3) -; (svref color 3) -; 1.0)) -; color) +(define-foreign %color-selection-get-color () nil + (colorsel color-selection) + (color pointer)) -; ;; gtkglue.c -; (define-foreign %color-selection-get-color-as-values () nil -; (colorsel color-selection) -; (red double-float :out) -; (green double-float :out) -; (blue double-float :out) -; (opacity double-float :out)) +(defun color-selection-color (colorsel) + (let ((color (allocate-memory (* (size-of 'double-float) 4)))) + (%color-selection-get-color colorsel color) + (funcall (get-from-alien-function '(vector double-float 4)) color))) + +(define-foreign %color-selection-set-color () nil + (colorsel color-selection) + (color (vector double-float 4))) + +(defun (setf color-selection-color) (color colorsel) + (%color-selection-set-color colorsel color) + color) + +(define-foreign %color-selection-get-old-color () nil + (colorsel color-selection) + (color pointer)) -; (defun color-selection-color (colorsel) -; (multiple-value-bind (red green blue opacity) -; (%color-selection-get-color-as-values colorsel) -; (if (color-selection-use-opacity-p colorsel) -; (vector red green blue opacity) -; (vector red green blue)))) +(defun color-selection-old-color (colorsel) + (let ((color (allocate-memory (* (size-of 'double-float) 4)))) + (%color-selection-get-old-color colorsel color) + (funcall (get-from-alien-function '(vector double-float 4)) color))) +(define-foreign %color-selection-set-old-color () nil + (colorsel color-selection) + (color (vector double-float 4))) +(defun (setf color-selection-old-color) (color colorsel) + (%color-selection-set-old-color colorsel color) + color) +(define-foreign %color-selection-get-palette-color () boolean + (colorsel color-selection) + (x int) + (y int) + (color (vector double-float 4) :out)) -; ;;; Gamma curve +(defun color-selection-palette-color (colorsel x y) + (multiple-value-bind (color-set-p color) + (%color-selection-get-palette-color colorsel x y) + (and color-set-p color))) -; (define-foreign gamma-curve-new () gamma-curve) +(define-foreign %color-selection-set-palette-color () nil + (colorsel color-selection) + (x int) + (y int) + (color (vector double-float 4))) + +(define-foreign %color-selection-unset-palette-color () nil + (colorsel color-selection) + (x int) + (y int)) + +(defun (setf color-selection-palette-color) (color colorsel x y) + (if color + (%color-selection-set-palette-color colorsel x y color) + (%color-selection-unset-palette-color colorsel x y)) + color) + +(define-foreign ("gtk_color_selection_is_adjusting" + color-selection-is-adjusting-p) () boolean + (colorsel color-selection)) + + + +;;; Gamma curve + +;(define-foreign gamma-curve-new () gamma-curve) @@ -801,7 +836,7 @@ (define-foreign combo-set-value-in-list () nil (define-foreign %combo-set-popdown-strings () nil (combo combo) - (strings (double-list string))) + (strings (glist string))) (defun (setf combo-popdown-strings) (strings combo) (%combo-set-popdown-strings combo strings) @@ -855,7 +890,7 @@ (define-foreign fixed-move () nil -; ;;; Notebook +;;; Notebook (define-foreign notebook-new () notebook) @@ -939,8 +974,6 @@ (defun (setf notebook-tab-label) (tab-label notebook reference) reference (notebook-nth-page-child notebook reference)) tab-label-widget) - (when (stringp tab-label) - (widget-unref tab-label-widget)) tab-label-widget)) (define-foreign @@ -966,8 +999,6 @@ (defun (setf notebook-menu-label) (menu-label notebook reference) reference (notebook-nth-page-child notebook reference)) menu-label-widget) - (when (stringp menu-label) - (widget-unref menu-label-widget)) menu-label-widget)) (define-foreign notebook-query-tab-label-packing (notebook ref) nil @@ -998,96 +1029,96 @@ (define-foreign notebook-reorder-child () nil -; ;;; Font selection +;;; Font selection -; ;;; Paned +;;; Paned -; (define-foreign paned-add1 () nil -; (paned paned) -; (child widget)) +(define-foreign paned-pack1 () nil + (paned paned) + (child widget) + (resize boolean) + (shrink boolean)) -; (define-foreign paned-add2 () nil -; (paned paned) -; (child widget)) +(define-foreign paned-pack2 () nil + (paned paned) + (child widget) + (resize boolean) + (shrink boolean)) -; (define-foreign paned-pack1 () nil -; (paned paned) -; (child widget) -; (resize boolean) -; (shrink boolean)) +;; gtkglue.c +(define-foreign paned-child1 () widget + (paned paned) + (resize boolean :out) + (shrink boolean :out)) -; (define-foreign paned-pack2 () nil -; (paned paned) -; (child widget) -; (resize boolean) -; (shrink boolean)) +;; gtkglue.c +(define-foreign paned-child2 () widget + (paned paned) + (resize boolean :out) + (shrink boolean :out)) -; ; (define-foreign ("gtk_paned_set_position" (setf paned-position)) () nil -; ; (paned paned) -; ; (position int)) +(defun (setf paned-child1) (child paned) + (paned-pack1 paned child nil t)) -; ;; gtkglue.c -; (define-foreign paned-child1 () widget -; (paned paned) -; (resize boolean :out) -; (shrink boolean :out)) +(defun (setf paned-child2) (child paned) + (paned-pack2 paned child t t)) -; ;; gtkglue.c -; (define-foreign paned-child2 () widget -; (paned paned) -; (resize boolean :out) -; (shrink boolean :out)) -; (define-foreign vpaned-new () vpaned) +(define-foreign vpaned-new () vpaned) -; (define-foreign hpaned-new () hpaned) +(define-foreign hpaned-new () hpaned) -; ;;; Layout +;;; Layout -; (define-foreign layout-new (&optional hadjustment vadjustment) layout -; (hadjustment (or null adjustment)) -; (vadjustment (or null adjustment))) +(define-foreign layout-new (&optional hadjustment vadjustment) layout + (hadjustment (or null adjustment)) + (vadjustment (or null adjustment))) -; (define-foreign layout-put () nil -; (layout layout) -; (widget widget) -; (x int) (y int)) +(define-foreign layout-put () nil + (layout layout) + (widget widget) + (x int) + (y int)) -; (define-foreign layout-move () nil -; (layout layout) -; (widget widget) -; (x int) (y int)) +(define-foreign layout-move () nil + (layout layout) + (widget widget) + (x int) + (y int)) -; (define-foreign %layout-set-size () nil -; (layout layout) -; (width int) -; (height int)) +(define-foreign layout-set-size () nil + (layout layout) + (width int) + (height int)) -; (defun (setf layout-size) (size layout) -; (%layout-set-size layout (svref size 0) (svref size 1)) -; (values (svref size 0) (svref size 1))) +;; gtkglue.c +(define-foreign layout-get-size () nil + (layout layout) + (width int :out) + (height int :out)) -; ;; gtkglue.c -; (define-foreign layout-size () nil -; (layout layout) -; (width int :out) -; (height int :out)) +(defun layout-x-size (layout) + (nth-value 0 (layout-get-size layout))) + +(defun layout-y-size (layout) + (nth-value 1 (layout-get-size layout))) + +(defun (setf layout-x-size) (x layout) + (layout-set-size layout x (layout-y-size layout))) -; (define-foreign layout-freeze () nil -; (layout layout)) +(defun (setf layout-y-size) (y layout) + (layout-set-size layout (layout-x-size layout) y)) -; (define-foreign layout-thaw () nil -; (layout layout)) +(define-foreign layout-freeze () nil + (layout layout)) -; (define-foreign layout-offset () nil -; (layout layout) -; (x int :out) -; (y int :out)) +(define-foreign layout-thaw () nil + (layout layout)) @@ -1102,19 +1133,19 @@ (define-foreign notebook-reorder-child () nil ; (define-foreign list-append-items () nil ; (list list-widget) -; (items (double-list list-item))) +; (items (glist list-item))) ; (define-foreign list-prepend-items () nil ; (list list-widget) -; (items (double-list list-item))) +; (items (glist list-item))) ; (define-foreign %list-remove-items () nil ; (list list-widget) -; (items (double-list list-item))) +; (items (glist list-item))) ; (define-foreign %list-remove-items-no-unref () nil ; (list list-widget) -; (items (double-list list-item))) +; (items (glist list-item))) ; (defun list-remove-items (list items &key no-unref) ; (if no-unref @@ -1191,7 +1222,7 @@ (define-foreign notebook-reorder-child () nil ; (list list-widget)) ; ;; gtkglue.c -; (define-foreign list-selection () (double-list list-item) +; (define-foreign list-selection () (glist list-item) ; (list list-widget)) @@ -1267,10 +1298,13 @@ (define-foreign menu-popdown () nil (define-foreign ("gtk_menu_get_active" menu-active) () widget (menu menu)) -(define-foreign ("gtk_menu_set_active" (setf menu-active)) () nil +(define-foreign %menu-set-active () nil (menu menu) (index unsigned-int)) +(defun (setf menu-active) (menu index) + (%menu-set-active menu index)) + ;(defun menu-attach-to-widget ...) (define-foreign menu-detach () nil @@ -1378,7 +1412,7 @@ (define-foreign %table-set-col-spacing () nil (spacing unsigned-int)) (defun (setf table-column-spacing) (spacing table column) - (%table-set-column-spacing table column spacing) + (%table-set-col-spacing table column spacing) spacing) ;; gtkglue.c @@ -1390,18 +1424,17 @@ (define-foreign table-column-spacing (table col) unsigned-int (defun %set-table-child-option (object slot flag value) - (let ((options (container-child-slot-value object slot))) + (let ((options (child-slot-value object slot))) (cond ((and value (not (member flag options))) - (setf (container-child-slot-value object slot) (cons flag options))) + (setf (child-slot-value object slot) (cons flag options))) ((and (not value) (member flag options)) - (setf - (container-child-slot-value object slot) (delete flag options)))))) + (setf (child-slot-value object slot) (delete flag options)))))) (macrolet ((define-option-accessor (name slot flag) `(progn (defun ,name (object) - (member ,flag (container-child-slot-value object ,slot))) + (member ,flag (child-slot-value object ,slot))) (defun (setf ,name) (value object) (%set-table-child-option object ,slot ,flag value))))) (define-option-accessor table-child-x-expand-p :x-options :expand) @@ -1528,56 +1561,56 @@ (defun toolbar-disable-tooltips (toolbar) ;;; Tree -(define-foreign tree-new () tree) +; (define-foreign tree-new () tree) -(define-foreign tree-append () nil - (tree tree) - (tree-item tree-item)) +; (define-foreign tree-append () nil +; (tree tree) +; (tree-item tree-item)) -(define-foreign tree-prepend () nil - (tree tree) - (tree-item tree-item)) +; (define-foreign tree-prepend () nil +; (tree tree) +; (tree-item tree-item)) -(define-foreign tree-insert () nil - (tree tree) - (tree-item tree-item) - (position int)) +; (define-foreign tree-insert () nil +; (tree tree) +; (tree-item tree-item) +; (position int)) -(define-foreign tree-remove-items () nil - (tree tree) - (items (double-list tree-item))) +; (define-foreign tree-remove-items () nil +; (tree tree) +; (items (glist tree-item))) -(define-foreign tree-clear-items () nil - (tree tree) - (start int) - (end int)) +; (define-foreign tree-clear-items () nil +; (tree tree) +; (start int) +; (end int)) -(define-foreign tree-select-item () nil - (tree tree) - (item int)) +; (define-foreign tree-select-item () nil +; (tree tree) +; (item int)) -(define-foreign tree-unselect-item () nil - (tree tree) - (item int)) +; (define-foreign tree-unselect-item () nil +; (tree tree) +; (item int)) -(define-foreign tree-select-child () nil - (tree tree) - (tree-item tree-item)) +; (define-foreign tree-select-child () nil +; (tree tree) +; (tree-item tree-item)) -(define-foreign tree-unselect-child () nil - (tree tree) - (tree-item tree-item)) +; (define-foreign tree-unselect-child () nil +; (tree tree) +; (tree-item tree-item)) -(define-foreign tree-child-position () int - (tree tree) - (tree-item tree-item)) +; (define-foreign tree-child-position () int +; (tree tree) +; (tree-item tree-item)) -(defun root-tree-p (tree) - (eq (tree-root-tree tree) tree)) +; (defun root-tree-p (tree) +; (eq (tree-root-tree tree) tree)) -;; gtkglue.c -(define-foreign tree-selection () (double-list tree-item) - (tree tree)) +; ;; gtkglue.c +; (define-foreign tree-selection () (glist tree-item) +; (tree tree)) @@ -1757,88 +1790,91 @@ (define-foreign ruler-draw-ticks () nil (define-foreign ruler-draw-pos () nil (ruler ruler)) +(define-foreign hruler-new () hruler) +(define-foreign vruler-new () vruler) -; ;;; Range -; (define-foreign range-draw-background () nil -; (range range)) +;;; Range -; (define-foreign range-clear-background () nil -; (range range)) +(define-foreign range-draw-background () nil + (range range)) -; (define-foreign range-draw-trough () nil -; (range range)) +(define-foreign range-clear-background () nil + (range range)) -; (define-foreign range-draw-slider () nil -; (range range)) +(define-foreign range-draw-trough () nil + (range range)) -; (define-foreign range-draw-step-forw () nil -; (range range)) +(define-foreign range-draw-slider () nil + (range range)) -; (define-foreign range-slider-update () nil -; (range range)) +(define-foreign range-draw-step-forw () nil + (range range)) -; (define-foreign range-trough-click () int -; (range range) -; (x int) -; (y int) -; (jump-perc single-float :out)) +(define-foreign range-slider-update () nil + (range range)) -; (define-foreign range-default-hslider-update () nil -; (range range)) +(define-foreign range-trough-click () int + (range range) + (x int) + (y int) + (jump-perc single-float :out)) -; (define-foreign range-default-vslider-update () nil -; (range range)) +(define-foreign range-default-hslider-update () nil + (range range)) -; (define-foreign range-default-htrough-click () int -; (range range) -; (x int) -; (y int) -; (jump-perc single-float :out)) +(define-foreign range-default-vslider-update () nil + (range range)) -; (define-foreign range-default-vtrough-click () int -; (range range) -; (x int) -; (y int) -; (jump-perc single-float :out)) +(define-foreign range-default-htrough-click () int + (range range) + (x int) + (y int) + (jump-perc single-float :out)) -; (define-foreign range-default-hmotion () int -; (range range) -; (x-delta int) -; (y-delta int)) +(define-foreign range-default-vtrough-click () int + (range range) + (x int) + (y int) + (jump-perc single-float :out)) -; (define-foreign range-default-vmotion () int -; (range range) -; (x-delta int) -; (y-delta int)) +(define-foreign range-default-hmotion () int + (range range) + (x-delta int) + (y-delta int)) +(define-foreign range-default-vmotion () int + (range range) + (x-delta int) + (y-delta int)) -; ;;; Scale -; (define-foreign scale-draw-value () nil -; (scale scale)) +;;; Scale -; (define-foreign hscale-new () hscale -; (adjustment adjustment)) +(define-foreign scale-draw-value () nil + (scale scale)) -; (define-foreign vscale-new () hscale -; (adjustment adjustment)) +(define-foreign hscale-new () hscale + (adjustment adjustment)) + +(define-foreign vscale-new () hscale + (adjustment adjustment)) -; ;;; Scrollbar +;;; Scrollbar -; (define-foreign hscrollbar-new () hscrollbar -; (adjustment adjustment)) +(define-foreign hscrollbar-new () hscrollbar + (adjustment adjustment)) -; (define-foreign vscrollbar-new () vscrollbar -; (adjustment adjustment)) +(define-foreign vscrollbar-new () vscrollbar + (adjustment adjustment)) -; ;;; Separator +;;; Separator (define-foreign vseparator-new () vseparator) @@ -1846,43 +1882,34 @@ (define-foreign hseparator-new () hseparator) -; ;;; Preview - +;;; Preview -; ;;; Progress -; (define-foreign progress-configure () adjustment -; (progress progress) -; (value single-float) -; (min single-float) -; (max single-float)) +;;; Progress -; (define-foreign ("gtk_progress_get_text_from_value" -; progress-text-from-value) () string -; (progress progress)) - -; (define-foreign ("gtk_progress_get_percentage_from_value" -; progress-percentage-from-value) () single-float -; (progress progress)) +(define-foreign progress-configure () adjustment + (progress progress) + (value single-float) + (min single-float) + (max single-float)) +(define-foreign ("gtk_progress_get_text_from_value" + progress-text-from-value) () string + (progress progress)) +(define-foreign ("gtk_progress_get_percentage_from_value" + progress-percentage-from-value) () single-float + (progress progress)) -; ;;; Progress bar -; (define-foreign %progress-bar-new () progress-bar) -; (define-foreign %progress-bar-new-with-adjustment () progress-bar -; (adjustment adjustment)) +;;; Progress bar -; (defun progress-bar-new (&optional adjustment) -; (if adjustment -; (%progress-bar-new-with-adjustment adjustment) -; (%progress-bar-new))) +(define-foreign progress-bar-new () progress-bar) -; (define-foreign progress-bar-update () nil -; (progress-bar progress-bar) -; (percentage single-float)) +(define-foreign progress-bar-pulse () nil + (progress-bar progress-bar)) @@ -1911,52 +1938,45 @@ (define-foreign adjustment-clamp-page () nil ;;; Tooltips -; (define-foreign tooltips-new () tooltips) +(define-foreign tooltips-new () tooltips) -; (define-foreign tooltips-enable () nil -; (tooltips tooltips)) +(define-foreign tooltips-enable () nil + (tooltips tooltips)) -; (define-foreign tooltips-disable () nil -; (tooltips tooltips)) +(define-foreign tooltips-disable () nil + (tooltips tooltips)) -; (define-foreign tooltips-set-tip () nil -; (tooltips tooltips) -; (widget widget) -; (tip-text string) -; (tip-private string)) - -; (declaim (inline tooltips-set-colors-real)) -; (define-foreign ("gtk_tooltips_set_colors" tooltips-set-colors-real) () nil -; (tooltips tooltips) -; (background gdk:color) -; (foreground gdk:color)) - -; (defun tooltips-set-colors (tooltips background foreground) -; (gdk:with-colors ((background background) -; (foreground foreground)) -; (tooltips-set-colors-real tooltips background foreground))) +(define-foreign tooltips-set-tip () nil + (tooltips tooltips) + (widget widget) + (tip-text string) + (tip-private string)) -; (define-foreign tooltips-force-window () nil -; (tooltips tooltips)) +(define-foreign tooltips-set-colors (tooltips background foreground) nil + (tooltips tooltips) + ((gdk:ensure-color background) gdk:color) + ((gdk:ensure-color foreground) gdk:color)) +(define-foreign tooltips-force-window () nil + (tooltips tooltips)) -; ;;; Rc +;;; Rc -; (define-foreign rc-add-default-file (filename) nil -; ((namestring (truename filename)) string)) +(define-foreign rc-add-default-file (filename) nil + ((namestring (truename filename)) string)) -; (define-foreign rc-parse (filename) nil -; ((namestring (truename filename)) string)) +(define-foreign rc-parse (filename) nil + ((namestring (truename filename)) string)) -; (define-foreign rc-parse-string () nil -; (rc-string string)) +(define-foreign rc-parse-string () nil + (rc-string string)) -; (define-foreign rc-reparse-all () nil) +(define-foreign rc-reparse-all () nil) -; ;(define-foreign rc-get-style () style -; ; (widget widget)) +(define-foreign rc-get-style () style + (widget widget)) @@ -2065,86 +2085,54 @@ (define-foreign accel-group-handle-remove ; (define-foreign style-copy () style ; (style style)) -; (define-foreign style-ref () style -; (style style)) - -; (define-foreign style-unref () nil -; (style style)) - -; (define-foreign style-get-color () gdk:color -; (style style) -; (color-type color-type) -; (state-type state-type)) - -; (define-foreign -; ("gtk_style_set_color" style-set-color-from-color) () gdk:color -; (style style) -; (color-type color-type) -; (state-type state-type) -; (color gdk:color)) - -; (defun style-set-color (style color-type state-type color) -; (gdk:with-colors ((color color)) -; (style-set-color-from-color style color-type state-type color))) - -; (define-foreign ("gtk_style_get_font" style-font) () gdk:font -; (style style)) - -; (define-foreign style-set-font () gdk:font -; (style style) -; (font gdk:font)) - -; (defun (setf style-font) (font style) -; (let ((font (gdk:ensure-font font))) -; (gdk:font-unref (style-font style)) -; (style-set-font style font))) - -; (defun style-fg (style state) -; (style-get-color style :foreground state)) - -; (defun (setf style-fg) (color style state) -; (style-set-color style :foreground state color)) - -; (defun style-bg (style state) -; (style-get-color style :background state)) - -; (defun (setf style-bg) (color style state) -; (style-set-color style :background state color)) - -; (defun style-text (style state) -; (style-get-color style :text state)) - -; (defun (setf style-text) (color style state) -; (style-set-color style :text state color)) - -; (defun style-base (style state) -; (style-get-color style :base state)) +(define-foreign %style-get-color () gdk:color + (style style) + (color-type color-type) + (state-type state-type)) -; (defun (setf style-base) (color style state) -; (style-set-color style :base state color)) +(define-foreign %style-set-color () gdk:color + (style style) + (color-type color-type) + (state-type state-type) + (color gdk:color)) -; (defun style-white (style) -; (style-get-color style :white :normal)) +(defun style-fg (style state) + (%style-get-color style :foreground state)) -; (defun (setf style-white) (color style) -; (style-set-color style :white :normal color)) +(defun (setf style-fg) (color style state) + (%style-set-color style :foreground state color)) -; (defun style-black (style) -; (style-get-color style :black :normal)) +(defun style-bg (style state) + (%style-get-color style :background state)) -; (defun (setf style-black) (color style) -; (style-set-color style :black :normal color)) +(defun (setf style-bg) (color style state) + (%style-set-color style :background state color)) -; (define-foreign style-get-gc -; (style color-type &optional (state-type :normal)) gdk:gc -; (style style) -; (color-type color-type) -; (state-type state-type)) +(defun style-text (style state) + (%style-get-color style :text state)) +(defun (setf style-text) (color style state) + (%style-set-color style :text state color)) +(defun style-base (style state) + (%style-get-color style :base state)) +(defun (setf style-base) (color style state) + (%style-set-color style :base state color)) +(defun style-white (style) + (%style-get-color style :white :normal)) +(defun (setf style-white) (color style) + (%style-set-color style :white :normal color)) +(defun style-black (style) + (%style-get-color style :black :normal)) +(defun (setf style-black) (color style) + (%style-set-color style :black :normal color)) +(define-foreign style-get-gc () gdk:gc + (style style) + (color-type color-type) + (state-type state-type)) diff --git a/gtk/gtktypes.lisp b/gtk/gtktypes.lisp index 336e94d..aca3578 100644 --- a/gtk/gtktypes.lisp +++ b/gtk/gtktypes.lisp @@ -15,28 +15,43 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;; $Id: gtktypes.lisp,v 1.3 2000-09-04 22:17:07 espen Exp $ +;; $Id: gtktypes.lisp,v 1.4 2000-10-05 17:30:07 espen Exp $ (in-package "GTK") -; (deftype color-type -; (enum -; :foreground -; :background -; :light -; :dark -; :mid -; :text -; :base -; :white -; :black)) +(deftype color-type () + '(enum + :foreground + :background + :light + :dark + :mid + :text + :base + :white + :black)) -(defclass style (gobject) - () +(defclass style (gobject) + ((white + :allocation :virtual + :location style-white + :initarg :white + :type gdk:color) + (black + :allocation :virtual + :location style-black + :initarg :black + :type gdk:color) + (font + :allocation :virtual + :location ("gtk_style_get_font" "gtk_style_set_font") + :accessor style-font + :initarg :font + :type gdk:font)) (:metaclass gobject-class) (:alien-name "GtkStyle")) @@ -49,11 +64,18 @@ (defclass accel-group (alien-object) (deftype accel-entry () 'pointer) ; internal? -;; These types are actully a single linked lists of widgets. As long as -;; we don't have to access the individual widgets defining them this way -;; is adequate and most efficient. -(deftype radio-button-group () 'pointer) -(deftype radio-menu-item-group () 'pointer) + +;; Forward declaration of widget and container +(defclass widget (object) + () + (:metaclass object-class) + (:alien-name "GtkWidget")) + +(defclass container (widget) + () + (:metaclass widget-class) + (:alien-name "GtkContainer")) + (defclass data (object) @@ -113,9 +135,121 @@ (defclass tooltips (data) (:alien-name "GtkTooltips")) -;; Forward declaration, the real definition is in gtkwidget.lisp (defclass widget (object) - () + ((child-slots + :allocation :instance + :accessor widget-child-slots + :type container-child) + (name + :allocation :arg + :accessor widget-name + :initarg :name + :type string) + (parent + :allocation :arg + :accessor widget-parent +; :initarg :parent + :type container) + (x + :allocation :arg + :accessor widget-x-position + :initarg :x + :type int) + (y + :allocation :arg + :accessor widget-y-position + :initarg :y + :type int) + (width + :allocation :arg + :accessor widget-width + :initarg :width + :type int) + (height + :allocation :arg + :accessor widget-height + :initarg :height + :type int) + (visible + :allocation :arg + :accessor widget-visible-p + :initarg :visible + :type boolean) + (sensitive + :allocation :arg + :accessor widget-sensitive-p + :initarg :sensitive + :type boolean) + (app-paintable + :allocation :arg + :reader widget-app-paintable-p + :type boolean) + (can-focus + :allocation :arg + :accessor widget-can-focus-p + :initarg :can-focus + :type boolean) + (has-focus + :allocation :arg + :accessor widget-has-focus-p + :initarg :has-focus + :type boolean) + (can-default + :allocation :arg + :accessor widget-can-default-p + :initarg :can-default + :type boolean) + (has-default + :allocation :arg + :accessor widget-has-default-p + :initarg :has-default + :type boolean) + (receives-default + :allocation :arg + :accessor widget-receives-default-p + :initarg :receives-default + :type boolean) + (composite-child + :allocation :arg + :accessor widget-composite-child-p + :initarg :composite-child + :type boolean) + (style + :allocation :arg + :accessor widget-style + :initarg :style + :type style) + (events + :allocation :arg + :accessor widget-events + :initarg :events + :type gdk:event-mask) + (extension-events + :allocation :arg + :accessor widget-extension-events + :initarg :extpension-events + :type gdk:event-mask) + (state + :allocation :virtual + :location ("gtk_widget_get_state" "gtk_widget_set_state") + :accessor widget-state + :initarg :state + :type state-type) + (window + :allocation :virtual + :location "gtk_widget_get_window" + :reader widget-window + :type gdk:window) + (colormap + :allocation :virtual + :location "gtk_widget_get_colormap" + :reader widget-colormap + :type gdk:colormap) + (visual + :allocation :virtual + :location "gtk_widget_get_visual" + :reader widget-visual + :type gdk:visual)) (:metaclass object-class) (:alien-name "GtkWidget")) @@ -244,9 +378,38 @@ (defclass pixmap (misc) (:alien-name "GtkPixmap")) -;; Forward declaration, the real definition is in gtkcontainer.lisp (defclass container (widget) - () + ((border-width + :allocation :arg + :accessor container-border-width + :initarg :border-width + :type unsigned-long) + (resize-mode + :allocation :arg + :accessor container-resize-mode + :initarg :resize-mode + :type resize-mode) + (children + :allocation :virtual + :location container-children) + (focus-child + :allocation :virtual + :location ("gtk_container_get_focus_child" "gtk_container_set_focus_child") + :accessor container-focus-child + :initarg :focus-child + :type widget) + (focus-hadjustment + :allocation :virtual + :location (nil "gtk_container_set_focus_hadjustment") + :writer (setf container-focus-hadjustment) + :initarg :focus-hadjustment + :type adjustment) + (focus-vadjustment + :allocation :virtual + :location (nil "gtk_container_set_focus_vadjustment") + :writer (setf container-focus-vadjustment) + :initarg :focus-vadjustment + :type adjustment)) (:metaclass widget-class) (:alien-name "GtkContainer")) @@ -263,7 +426,6 @@ (defclass bin (container) ((child :allocation :virtual :location bin-child - :initarg :child :type widget)) (:metaclass container-class) (:alien-name "GtkBin")) @@ -300,7 +462,8 @@ (defclass alignment-child (bin-child)) (defclass frame (bin) ((label - :allocation :arg + :allocation :virtual + :location ("gtk_frame_get_label" "gtk_frame_set_label") :accessor frame-label :initarg :label :type string) @@ -401,18 +564,12 @@ (defclass check-button-child (toggle-button-child) (:metaclass child-class)) -;; Forward declaration -(defclass radio-button (check-button) - () - (:metaclass container-class) - (:alien-name "GtkRadioButton")) - (defclass radio-button (check-button) ((group - :allocation :arg -; :accessor radio-button-group - :initarg :group - :type radio-button)) + :allocation :virtual + :location ("gtk_radio_button_group") + :reader radio-button-group + :type (static (gslist widget)))) (:metaclass container-class) (:alien-name "GtkRadioButton")) @@ -523,9 +680,9 @@ (defclass check-menu-item-child (menu-item-child) (defclass radio-menu-item (check-menu-item) ((group :allocation :virtual - :location ("gtk_radio_menu_item_group" "gtk_radio_menu_item_set_group") - :accessor radio-menu-item-group - :type radio-menu-item-group)) + :location ("gtk_radio_menu_item_group") + :reader radio-menu-item-group + :type (static (gslist widget)))) (:metaclass container-class) (:alien-name "GtkRadioMenuItem")) @@ -623,27 +780,15 @@ (defclass window-child (bin-child) (:metaclass child-class)) -; (defclass color-selection-dialog window -; :slots -; ;; slots not accessible through the arg mechanism -; ((colorsel :read-only t :type widget) -; (main-vbox :read-only t :type widget) -; (ok-button :read-only t :type widget) -; (reset-button :read-only t :type widget) -; (cancel-button :read-only t :type widget) -; (help-button :read-only t :type widget))) - (defclass dialog (window) - ((action-area - :allocation :virtual - :location "gtk_dialog_get_action_area" - :reader dialog-action-area + ((main-box + :allocation :alien + :reader dialog-main-box :type widget) - (box - :allocation :virtual - :location "gtk_dialog_get_vbox" - :reader dialog-box - :type widget)) + (action-area + :allocation :alien + :reader dialog-action-area + :type widget)) (:metaclass container-class) (:alien-name "GtkDialog")) @@ -652,6 +797,31 @@ (defclass dialog-child (window-child) (:metaclass child-class)) +(defclass color-selection-dialog (dialog) + ((colorsel + :allocation :alien + :reader color-selection-dialog-colorsel + :type widget) + (ok-button + :allocation :alien + :reader color-selection-dialog-ok-button + :type widget) + (cancel-button + :allocation :alien + :reader color-selection-dialog-cancel-button + :type widget) + (help-button + :allocation :alien + :reader color-selection-dialog-help-button + :type widget)) + (:metaclass container-class) + (:alien-name "GtkColorSelectionDialog")) + +(defclass color-selection-dialog-child (dialog-child) + () + (:metaclass child-class)) + + (defclass input-dialog (dialog) () (:metaclass container-class) @@ -662,13 +832,36 @@ (defclass input-dialog-child (dialog-child) (:metaclass child-class)) -; (defclass file-selection window -; :slots -; ;; slots not accessible through the arg mechanism -; ((filename :type string) -; (action-area :read-only t :type widget) -; (ok-button :read-only t :type widget) -; (cancel-button :read-only t :type widget))) +(defclass file-selection (window) + ((filename + :allocation :virtual + :location ("gtk_file_selection_get_filename" + "gtk_file_selection_set_filename") + :accessor file-selection-filename + :initarg :filename + :type string) + (action-area + :allocation :virtual + :location "gtk_file_selection_get_action_area" + :reader file-selection-action-area + :type widget) + (ok-button + :allocation :virtual + :location "gtk_file_selection_get_ok_button" + :reader file-selection-ok-button + :type widget) + (cancel-button + :allocation :virtual + :location "gtk_file_selection_get_cancel_button" + :reader file-selection-cancel-button + :type widget)) + (:metaclass container-class) + (:alien-name "GtkFileSelection")) + +(defclass file-selection-child (window-child) + () + (:metaclass child-class)) + ; (defclass plug window) @@ -831,11 +1024,34 @@ (defclass button-box (box) :allocation :virtual :location ("gtk_button_box_get_spacing" "gtk_button_box_set_spacing") :accessor button-box-spacing + :initarg :spacing + :type int) + (child-min-width + :allocation :alien + :offset #.(size-of 'int) + :accessor button-box-child-min-width + :initarg :child-min-width + :type int) + (child-min-height + :allocation :alien + :accessor button-box-child-min-height + :initarg :child-min-height + :type int) + (child-ipad-x + :allocation :alien + :accessor button-box-child-ipad-x + :initarg :child-ipad-x + :type int) + (child-ipad-y + :allocation :alien + :accessor button-box-child-ipad-y + :initarg :child-ipad-y :type int) (layout :allocation :virtual :location ("gtk_button_box_get_layout" "gtk_button_box_set_layout") :accessor button-box-layout + :initarg :layout :type button-box-style)) (:metaclass container-class) (:alien-name "GtkButtonBox")) @@ -875,16 +1091,36 @@ (defclass vbox-child (box-child) (:metaclass child-class)) -; (defclass color-selection vbox -; :slots -; ((policy :c-writer "gtk_color_selection_set_update_policy" -; :read-method :arg :type update-type) -; (use-opacity :c-writer "gtk_color_selection_set_opacity" -; :read-method :arg :type boolean) -; ;; slots not accessible through the arg mechanism -; (color :access-method :lisp))) +(defclass color-selection (vbox) + ((use-opacity + :allocation :virtual + :location ("gtk_color_selection_get_use_opacity" + "gtk_color_selection_set_use_opacity") + :accessor color-selection-use-opacity-p + :initarg :use-opacity + :type boolean) + (use-palette + :allocation :virtual + :location ("gtk_color_selection_get_use_palette" + "gtk_color_selection_set_use_palette") + :accessor color-selection-use-palette-p + :initarg :use-palette + :type boolean) + (color + :allocation :virtual + :location color-selection-color + :initarg :color) + (old-color + :allocation :virtual + :location color-selection-old-color + :initarg :old-color + :type (vector double-float 4))) + (:metaclass container-class) + (:alien-name "GtkColorSelection")) -; (defclass gamma-curve vbox) +(defclass color-selection-child (vbox-child) + () + (:metaclass child-class)) (defclass hbox (box) @@ -906,41 +1142,6 @@ (defclass statusbar-child (hbox-child) () (:metaclass child-class)) -;; CList and CTree is deprecated -; (defclass clist container -; :c-name "GtkCList" -; :c-prefix "gtk_clist_" -; :slots -; ((n-columns :read-only t :initarg t :access-method :arg -; :type unsigned-int) -; (shadow-type :read-method :arg :type shadow-type) -; (selection-mode :read-method :arg :type selection-mode) -; (row-height :read-method :arg :type unsigned-int) -; (reorderable :read-method :arg :type boolean) -; (titles-visible :write-method :lisp :type boolean) -; (titles-active :access-method :arg :type boolean) -; (use-drag-icons :read-method :arg :type boolean) -; (sort-type :read-method :arg :type sort-type) -; ;; slots not accessible through the arg mechanism -; (hadjustment :type adjustment) -; (vadjustment :type adjustment) -; (sort-column :type int) -; (focus-row :reader %clist-focus-row :read-only t :type int) -; (n-rows :read-only t :type int))) - -; (defclass ctree clist -; :c-name "GtkCTree" -; :c-prefix "gtk_ctree_" -; :slots -; ((n-columns :read-only t :initarg t :access-method :arg -; :type unsigned-int) -; (tree-column :read-only t :initarg t :access-method :arg -; :type unsigned-int) -; (indent :read-method :arg :type unsigned-int) -; (spacing :read-method :arg :type unsigned-int) -; (show-stub :read-method :arg :type boolean) -; (line-style :read-method :arg :type ctree-line-style) -; (expander-style :read-method :arg :type ctree-expander-style))) (defclass fixed (container) () @@ -1056,7 +1257,17 @@ (defclass paned (container) :location ("gtk_paned_get_position" "gtk_paned_set_position") :accessor paned-position :initarg :position - :type int)) + :type int) + (child1 + :allocation :virtual + :location paned-child1 + :initarg :child1 + :type widget) + (child2 + :allocation :virtual + :location paned-child2 + :initarg :child2 + :type widget)) (:metaclass container-class) (:alien-name "GtkPaned")) @@ -1097,7 +1308,26 @@ (defclass layout (container) :location ("gtk_layout_get_vadjustment" "gtk_layout_set_vadjustment") :accessor layout-vadjustment :initarg :vadjustment - :type adjustment)) + :type adjustment) + (x-size + :allocation :virtual + :location layout-x-size + :initarg :x-size) + (y-size + :allocation :virtual + :location layout-y-size + :initarg :y-size) + (x-offset + :allocation :alien + :offset #.(+ (size-of 'pointer) (* (size-of 'int) 2)) + :accessor layout-x-offset + :initarg :x-offset + :type unsigned-int) + (y-offset + :allocation :alien + :accessor layout-y-offset + :initarg :y-offset + :type unsigned-int)) (:metaclass container-class) (:alien-name "GtkLayout")) @@ -1189,8 +1419,8 @@ (default-pad-y :type unsigned-int) (default-ipad-x :allocation :arg - :accessor packer-default-ipad-y - :initarg :default-ipad-y + :accessor packer-default-ipad-x + :initarg :default-ipad-x :type unsigned-int) (default-ipad-y :allocation :arg @@ -1709,31 +1939,106 @@ (defclass vseparator (separator) ; :slots ; ((expand :read-method :arg :type boolean))) -; (defclass progress widget -; :slots -; ((activity-mode :read-method :arg :type boolean) -; (show-text :read-method :arg :type boolean) -; (text-xalign :access-method :arg :type single-float) -; (text-yalign :access-method :arg :type single-float) -; ;; slots not accessible through the arg mechanism -; (format-string :type string) -; (adjustment :type adjustment) -; (percentage :c-reader "gtk_progress_get_current_percentage" -; :type single-float) -; (value :type single-float) -; (text :c-reader "gtk_progress_get_current_text" -; :read-only t :type string))) - -; (defclass progress-bar progress -; :slots -; ((adjustment :c-writer "gtk_progress_set_adjustment" -; :read-method :arg :type adjustment) -; (orientation :read-method :arg :type progress-bar-orientation) -; (bar-style :read-method :arg :accessor progress-bar-style -; :type progress-bar-style) -; (activity-step :read-method :arg :type unsigned-int) -; (activity-blocks :read-method :arg :type unsigned-int) -; (discrete-blocks :read-method :arg :type unsigned-int))) +(defclass progress (widget) + ((activity-mode + :allocation :arg + :accessor progress-activity-mode-p + :initarg :activity-mode + :type boolean) + (show-text + :allocation :arg + :accessor progress-show-text-p + :initarg :show-text + :type boolean) + (text-xalign + :allocation :arg + :accessor progress-text-xalign + :initarg :text-xalign + :type single-float) + (text-yalign + :allocation :arg + :accessor progress-text-yalign + :initarg :text-yalign + :type single-float) + (format-string + :allocation :virtual + :location ("gtk_progress_get_format_string" + "gtk_progress_set_format_string") + :accessor progress-format-string + :initarg :format-string + :type string) + (adjustment + :allocation :virtual + :location ("gtk_progress_get_adjustment" + "gtk_progress_set_adjustment") + :accessor progress-adjustment + :initarg :adjustment + :type adjustment) + (percentage + :allocation :virtual + :location ("gtk_progress_get_current_percentage" + "gtk_progress_set_percentage") + :accessor progress-percentage + :initarg :percentage + :type single-float) + (value + :allocation :virtual + :location ("gtk_progress_get_value" "gtk_progress_set_value") + :accessor progress-value + :initarg :value + :type single-float) + (text + :allocation :virtual + :location ("gtk_progress_get_current_text") + :reader progress-text + :type string)) + (:metaclass widget-class) + (:alien-name "GtkProgress")) + + +(defclass progress-bar (progress) + ((orientation + :allocation :arg + :accessor progress-bar-orientation + :initarg :orientation + :type progress-bar-orientation) + (bar-style + :allocation :arg + :accessor progress-bar-style + :initarg :bar-style + :type progress-bar-style) + (activity-step + :allocation :arg + :accessor progress-bar-activity-step + :initarg :activity-step + :type unsigned-int) + (activity-blocks + :allocation :arg + :accessor progress-bar-activity-blocks + :initarg :activity-blocks + :type unsigned-int) + (discrete-blocks + :allocation :arg + :accessor progress-bar-discrete-blocks + :initarg :discrete-blocks + :type unsigned-int) + (fraction + :allocation :arg + :accessor progress-bar-fraction + :initarg :fraction + :type single-float) + (pulse-step + :allocation :arg + :accessor progress-bar-pulse-step + :initarg :pulse-step + :type single-float) + (text + :allocation :virtual + :location ("gtk_progress_get_current_text" "gtk_progress_bar_set_text") + :accessor progress-bar-text + :type string)) + (:metaclass widget-class) + (:alien-name "GtkProgressBar")) ; (defclass item-factory object) -- [mdw]