February 2007 - mcclim-cvs@common-lisp.net

[mcclim-cvs] CVS mcclim/Extensions
by dlichteblau 04 Feb '07

04 Feb '07

Update of /project/mcclim/cvsroot/mcclim/Extensions In directory clnet:/tmp/cvs-serv1773/Extensions Added Files: tab-layout.lisp Log Message: Added the tab layout. * Extensions/tab-layout.lisp: New file. * Examples/tabdemo.lisp: New file. * mcclim.asd (CLIM): Added Extensions/tab-layout.lisp. (CLIM-EXAMPLES): Add tabdemo.lisp * package.lisp (CLIM-TAB-LAYOUT): New package. * Examples/demodemo.lisp: Added a button for the tabdemo. * Doc/make-docstrings.lisp: Process the clim-tab-layout package. * Doc/mcclim.texi: New chapter about the tab-layout. * Backends/CLX/frame-manager.lisp (GENERATE-STANDARD-PANE-SPECS, FIND-CONCRETE-PANE-CLASS): Obey define-abstract-pane-mapping even for names not the internal packages. * Backends/gtkairo/event.lisp (TAB-BUTTON-HANDLER): New. * Backends/gtkairo/frame-manager.lisp ((MAKE-PANE-2 TAB-LAYOUT-PANE)): New. (RESOLVE-ABSTRACT-PANE-NAME): Renamed. * Backends/gtkairo/gadgets.lisp (TAB-BUTTON-EVENT, TAB-PRESS-EVENT, TAB-RELEASE-EVENT, GTK-TAB-LAYOUT): New classes. (REALIZE-NATIVE-WIDGET, CONTAINER-PUT, (SETF CLIM-TAB-LAYOUT:TAB-LAYOUT-PAGES), REORDER-NOTEBOOK-PAGES, CONTAINER-MOVE, ALLOCATE-SPACE, (SETF CLIM-TAB-LAYOUT:TAB-LAYOUT-ENABLED-PAGE), CONNECT-NATIVE-SIGNALS, CLIM-TAB-LAYOUT:NOTE-TAB-PAGE-CHANGED, SET-TAB-PAGE-ATTRIBUTES, HANDLE-EVENT): New functions and methods on gtk-tab-layout. (PARENT-AD-HOC-PRESENTATION): New class. * Backends/gtkairo/port.lisp (GTK-WIDGET-MODIFY-FG): New function. * Backends/gtkairo/ffi.lisp: Regenerated. --- /project/mcclim/cvsroot/mcclim/Extensions/tab-layout.lisp 2007/02/04 12:55:45 NONE +++ /project/mcclim/cvsroot/mcclim/Extensions/tab-layout.lisp 2007/02/04 12:55:45 1.1 ;;; -*- Mode: Lisp; show-trailing-whitespace: t; indent-tabs: nil; -*- ;;; Based on the tab-layout by: ;;; --------------------------------------------------------------------------- ;;; Title: A Tab Layout Pane ;;; Created: 2005/09/16-19 ;;; Author: Max-Gerd Retzlaff <m.retzlaff(a)gmx.net>, http://bl0rg.net/~mgr ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2005 by Max-Gerd Retzlaff ;;; ;;; Available from: ;;; http://bl0rg.net/~mgr/flux/tab-layout_2005-09-19_02-52+0200.tar.bz2 ;;; ;;; License given on IRC: ;;; http://tunes.org/~nef/logs/lisp/07.01.15 ;;; 04:04:49 <mgr> _8work: the license will not be a problem. not with me, not ;;; with Gilbert. BSD or LGPL, or both. but I'm on the move.. see you later ;;; 04:05:22 <mgr> _8work: in fact, I wanted to commit it to mcclim long time ;;; ago, but I have not yet because there seemed to be a lack of interest. ;;; Based on the stack layout by: ;;; --------------------------------------------------------------------------- ;;; Title: Embryo Stack Layout Pane Class ;;; Created: 2003-06-01 ;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> ;;; License: As public domain as it can get. ;;; --------------------------------------------------------------------------- ;;; Available from: ;;; http://bauhh.dyndns.org:8000/mcclim/cookbook/ ;;; --------------------------------------------------------------------------- ;;; Adapted for inclusion into McCLIM: ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2006 David Lichteblau (in-package :clim-tab-layout) ;;; abstract TAB-LAYOUT superclass (climi::define-abstract-pane-mapping 'tab-layout 'tab-layout-pane) (defclass tab-layout (climi::composite-pane) ((pages :initform nil :reader tab-layout-pages :initarg :pages) (enabled-page :initform nil :accessor tab-layout-enabled-page)) (:documentation "The abstract tab layout pane is a composite pane arranging its children so that exactly one child is visible at any time, with a row of buttons allowing the user to choose between them. Use WITH-TAB-LAYOUT to define a tab layout and its children, or use the :PAGES argument to specify its contents when creating it dynamically using MAKE-PANE.")) (defmethod initialize-instance :after ((instance tab-layout) &key pages) (when (eq (class-of instance) (find-class 'tab-layout)) (error "tab-layout is an abstract class, you cannot instantiate it!")) (dolist (page pages) (setf (tab-page-tab-layout page) instance) (sheet-adopt-child instance (tab-page-pane page))) (setf (tab-layout-enabled-page instance) (car pages))) (defclass tab-page () ((tab-layout :initform nil :accessor tab-page-tab-layout) (title :initform nil :accessor tab-page-title :initarg :title) (pane :initform nil :accessor tab-page-pane :initarg :pane) (presentation-type :initform 'tab-page :accessor tab-page-presentation-type :initarg :presentation-type) (enabled-callback :initform nil :accessor tab-page-enabled-callback :initarg :enabled-callback) ;; fixme: drawing-options in this generality are a feature of the old ;; concrete tab pane. Gtkairo will only look for the :INK in this list. (drawing-options :initform nil :accessor tab-page-drawing-options :initarg :drawing-options)) (:documentation "Instances of TAB-PAGE represent the pages in a TAB-LAYOUT. For each child pane, there is a TAB-PAGE providing the page's title and additional information about the child. Valid initialization arguments are :TITLE, :PANE (required) and :PRESENTATION-TYPE,:DRAWING-OPTIONS (optional).")) (defmethod print-object ((object tab-page) stream) (print-unreadable-object (object stream :identity t :type t) (princ (tab-page-title object) stream))) (defgeneric tab-layout-pages (tab-layout) (:documentation "Return all TAB-PAGEs in this tab layout, in order from left to right. Do not modify the resulting list destructively. Use the SETF function of the same name to assign a new list of pages. The SETF function will automatically add tabs for new page objects, remove old pages, and reorder the pages to conform to the new list.")) (defgeneric tab-layout-enabled-page (tab-layout) (:documentation "The currently visible tab page of this tab-layout, or NIL if the tab layout does not have any pages currently. Use the SETF function of the name to change focus to another tab page.")) (defgeneric tab-page-tab-layout (tab-page) (:documentation "Return the TAB-LAYOUT this page belongs to.")) (defgeneric tab-page-pane (tab-page) (:documentation "Return the CLIM pane this page displays. See also SHEET-TO-PAGE, the reverse operation.")) (defgeneric tab-page-title (tab-page) (:documentation "Return the title displayed in the tab for this PAGE. Use the SETF function of the same name to set the title dynamically.")) (defgeneric tab-page-presentation-type (tab-page) (:documentation "Return the type of the presentation used when this page's header gets clicked. Use the SETF function of the same name to set the presentation type dynamically. The default is TAB-PAGE.")) (defgeneric tab-page-drawing-options (tab-page) (:documentation "Return the drawing options of this page's header. Use the SETF function of the same name to set the drawing options dynamically. Note: Not all implementations of the tab layout will understand all drawing options. In particular, the Gtkairo backends understands only the :INK option at this time.")) (defgeneric (setf tab-layout-enabled-page) (newval tab-layout)) (defgeneric note-tab-page-changed (layout page) (:documentation "This internal function is called by the SETF methods for TAB-PAGE-TITLE and -DRAWING-OPTIONS to inform the page's tab-layout about the changes, allowing it to update its display. Only called by the TAB-LAYOUT implementation and specialized by its subclasses.")) (defmethod (setf tab-layout-enabled-page) :around (page (parent tab-layout)) ;; As a rule, we always want exactly one enabled page -- unless we ;; don't have any pages at all. (assert (or page (null (tab-layout-pages parent)))) ;; This must be an around method, so that we can see the old value, yet ;; do the call only after the change has been done: (let ((old-page (tab-layout-enabled-page parent))) (prog1 (call-next-method) (when (and page (not (equal page old-page))) (note-tab-page-enabled page))))) (defmethod (setf tab-layout-pages) (newval (parent tab-layout)) (unless (equal newval (remove-duplicates newval)) (error "page list must not contain duplicates: ~A" newval)) (let* ((oldval (tab-layout-pages parent)) (add (set-difference newval oldval)) (remove (set-difference oldval newval))) ;; check for errors (dolist (page add) (unless (null (tab-page-tab-layout page)) (error "~A has already been added to a different tab layout" page))) ;; remove old pages first, because sheet-disown-child still needs access ;; to the original page list: (dolist (page remove) (sheet-disown-child parent (tab-page-pane page))) ;; install the pages before adding their sheets (matters for gtkairo) (setf (slot-value parent 'pages) newval) ;; add new pages: (dolist (page add) (setf (tab-page-tab-layout page) parent) (sheet-adopt-child parent (tab-page-pane page))))) (defmethod sheet-disown-child :before ((parent tab-layout) child &key errorp) (declare (ignore errorp)) (unless (internal-child-p child parent) (let* ((page (sheet-to-page child)) (current-page (tab-layout-enabled-page parent)) (currentp (equal child (tab-page-pane current-page))) (successor (when currentp (page-successor current-page)))) (setf (slot-value parent 'pages) (remove page (tab-layout-pages parent))) (when currentp (setf (tab-layout-enabled-page parent) successor)) (setf (tab-page-tab-layout page) nil)))) (defun sheet-to-page (sheet) "For a SHEET that is a child of a tab layout, return the page corresponding to this sheet. See also TAB-PAGE-PANE, the reverse operation." (find sheet (tab-layout-pages (sheet-parent sheet)) :key #'tab-page-pane)) (defun find-tab-page-named (name tab-layout) "Find the tab page with the specified TITLE in TAB-LAYOUT. Note that uniqueness of titles is not enforced; the first page found will be returned." (find name (tab-layout-pages tab-layout) :key #'tab-page-title ;; fixme: don't we want the case-sensitive STRING= here? :test #'string-equal)) (defmethod (setf tab-page-title) :after (newval (page tab-page)) (declare (ignore newval)) (let ((layout (tab-page-tab-layout page))) (when layout (note-tab-page-changed layout page)))) (defmethod (setf tab-page-drawing-options) :after (newval (page tab-page)) (declare (ignore newval)) (let ((layout (tab-page-tab-layout page))) (when layout (note-tab-page-changed layout page)))) (defmethod note-tab-page-changed ((layout tab-layout) page) nil) ;;; GTK+ distinguishes between children user code creates and wants to ;;; see, and "internal" children the container creates and mostly hides ;;; from the user. Let's steal that concept to ignore the header pane. (defgeneric internal-child-p (child parent)) (defmethod internal-child-p (child (parent tab-layout)) nil) (defun page-successor (page) "The page we should enable when PAGE is currently enabled but gets removed." (loop for (a b c) on (tab-layout-pages (tab-page-tab-layout page)) do (cond ((eq a page) (return b)) ((eq b page) (return (or c a)))))) (defun note-tab-page-enabled (page) (let ((callback (tab-page-enabled-callback page))) (when callback (funcall callback page)))) ;;; convenience functions: (defun add-page (page tab-layout &optional enable) "Add PAGE at the left side of TAB-LAYOUT. When ENABLE is true, move focus to the new page. This function is a convenience wrapper; you can also push page objects directly into TAB-LAYOUT-PAGES and enable them using (SETF TAB-LAYOUT-ENABLED-PAGE)." (push page (tab-layout-pages tab-layout)) (when enable (setf (tab-layout-enabled-page tab-layout) page))) (defun switch-to-page (page) "Move the focus in page's tab layout to this page. This function is a one-argument convenience version of (SETF TAB-LAYOUT-ENABLED-PAGE), which can also be called directly." (setf (tab-layout-enabled-page (tab-page-tab-layout page)) page)) (defun remove-page (page) "Remove PAGE from its tab layout. This is a convenience wrapper around SHEET-DISOWN-CHILD, which can also be used directly to remove the page's pane with the same effect." (sheet-disown-child (tab-page-tab-layout page) (tab-page-pane page))) (defun remove-page-named (title tab-layout) "Remove the tab page with the specified TITLE from TAB-LAYOUT. Note that uniqueness of titles is not enforced; the first page found will be removed. This is a convenience wrapper, you can also use FIND-TAB-PAGE-NAMED to find and the remove a page yourself." (remove-page (find-tab-page-named title tab-layout))) ;;; creation macro (defmacro with-tab-layout ((default-presentation-type &rest initargs &key name &allow-other-keys) &body body) "Return a TAB-LAYOUT. Any keyword arguments, including its name, will be passed to MAKE-PANE. Child pages of the TAB-LAYOUT can be specified using BODY, using lists of the form (TITLE PANE &KEY PRESENTATION-TYPE DRAWING-OPTIONS ENABLED-CALLBACK). DEFAULT-PRESENTATION-TYPE will be passed as :PRESENTATION-TYPE to pane creation forms that specify no type themselves." (let ((ptypevar (gensym))) `(let ((,ptypevar ,default-presentation-type)) (make-pane 'tab-layout :name ,(or name `',(gensym "tab-layout-")) :pages (list ,@(mapcar (lambda (spec) `(make-tab-page ,@spec :presentation-type ,ptypevar)) body)) ,@initargs)))) (defun make-tab-page (title pane &key presentation-type drawing-options enabled-callback) (make-instance 'tab-page :title title :pane pane :presentation-type presentation-type :drawing-options drawing-options :enabled-callback enabled-callback)) ;;; presentation/command system integration (define-command (com-switch-to-tab-page :command-table clim:global-command-table) ((page 'tab-page :prompt "Tab page")) (switch-to-page page)) (define-presentation-to-command-translator switch-via-tab-button (tab-page com-switch-to-tab-page clim:global-command-table :gesture :select :documentation "Switch to this page" :pointer-documentation "Switch to this page") (object) (list object)) (define-command (com-remove-tab-page :command-table clim:global-command-table) ((page 'tab-page :prompt "Tab page")) (remove-page page)) ;;; generic TAB-LAYOUT-PANE implementation (defclass tab-layout-pane (tab-layout) ((header-pane :accessor tab-layout-header-pane :initarg :header-pane)) (:documentation "A pure-lisp implementation of the tab-layout, this is the generic implementation chosen by the CLX frame manager automatically. Users should create panes for type TAB-LAYOUT, not TAB-LAYOUT-PANE, so that the frame manager can customize the implementation.")) (defmethod (setf tab-layout-enabled-page) (page (parent tab-layout-pane)) (let ((old-page (tab-layout-enabled-page parent))) (unless (equal page old-page) (when old-page (setf (sheet-enabled-p (tab-page-pane old-page)) nil)) (when page (setf (sheet-enabled-p (tab-page-pane page)) t))) (when page (setf (sheet-enabled-p (tab-page-pane page)) t))) (call-next-method)) ;;;; ;;;; Beginning of original MGR source code -- license not confirmed ;;;; (defclass tab-bar-view (gadget-view) ()) (defparameter +tab-bar-view+ (make-instance 'tab-bar-view)) (define-presentation-method present (tab-page (type tab-page) stream (view tab-bar-view) &key) (stream-increment-cursor-position stream 5 0) (multiple-value-bind (x y) (stream-cursor-position stream) (let* ((length-top-line (+ x 6 (text-size stream (tab-page-title tab-page)) 3)) (tab-button-polygon (list x (+ y 14) (+ x 6) y (+ x 6) y length-top-line y length-top-line y (+ length-top-line 6) (+ y 14)))) ;; grey-filled polygone for the disabled panes (unless (sheet-enabled-p (tab-page-pane tab-page)) (draw-polygon* stream tab-button-polygon :ink +grey+)) ;; black non-filled polygon (draw-polygon* stream tab-button-polygon :ink +black+ :filled nil) ;; "breach" the underline for the enabled pane (when (sheet-enabled-p (tab-page-pane tab-page)) (draw-line stream (apply #'make-point (subseq tab-button-polygon 0 2)) (apply #'make-point (subseq tab-button-polygon (- (length tab-button-polygon) 2))) :ink +background-ink+)))) (stream-increment-cursor-position stream 8 0) (apply #'invoke-with-drawing-options stream (lambda (rest) (declare (ignore rest)) (write-string (tab-page-title tab-page) stream)) (tab-page-drawing-options tab-page)) (stream-increment-cursor-position stream 10 0)) (defmethod initialize-instance :after ((instance tab-layout-pane) &key pages) (let ((current (tab-layout-enabled-page instance))) (dolist (page pages) (setf (sheet-enabled-p (tab-page-pane page)) (eq page current)))) (let ((header (make-clim-stream-pane :default-view +tab-bar-view+ :display-time :command-loop :scroll-bars nil :borders nil :height 22 :display-function (lambda (frame pane) (declare (ignore frame)) (stream-increment-cursor-position pane 0 3) (draw-line* pane 0 17 (slot-value pane 'climi::current-width) 17 :ink +black+) (mapc (lambda (page) (with-output-as-presentation (pane (tab-page-pane page) (tab-page-presentation-type page)) [36 lines skipped]

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 04 Feb '07

04 Feb '07

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv1773/Backends/gtkairo Modified Files: event.lisp ffi.lisp frame-manager.lisp gadgets.lisp port.lisp Log Message: Added the tab layout. * Extensions/tab-layout.lisp: New file. * Examples/tabdemo.lisp: New file. * mcclim.asd (CLIM): Added Extensions/tab-layout.lisp. (CLIM-EXAMPLES): Add tabdemo.lisp * package.lisp (CLIM-TAB-LAYOUT): New package. * Examples/demodemo.lisp: Added a button for the tabdemo. * Doc/make-docstrings.lisp: Process the clim-tab-layout package. * Doc/mcclim.texi: New chapter about the tab-layout. * Backends/CLX/frame-manager.lisp (GENERATE-STANDARD-PANE-SPECS, FIND-CONCRETE-PANE-CLASS): Obey define-abstract-pane-mapping even for names not the internal packages. * Backends/gtkairo/event.lisp (TAB-BUTTON-HANDLER): New. * Backends/gtkairo/frame-manager.lisp ((MAKE-PANE-2 TAB-LAYOUT-PANE)): New. (RESOLVE-ABSTRACT-PANE-NAME): Renamed. * Backends/gtkairo/gadgets.lisp (TAB-BUTTON-EVENT, TAB-PRESS-EVENT, TAB-RELEASE-EVENT, GTK-TAB-LAYOUT): New classes. (REALIZE-NATIVE-WIDGET, CONTAINER-PUT, (SETF CLIM-TAB-LAYOUT:TAB-LAYOUT-PAGES), REORDER-NOTEBOOK-PAGES, CONTAINER-MOVE, ALLOCATE-SPACE, (SETF CLIM-TAB-LAYOUT:TAB-LAYOUT-ENABLED-PAGE), CONNECT-NATIVE-SIGNALS, CLIM-TAB-LAYOUT:NOTE-TAB-PAGE-CHANGED, SET-TAB-PAGE-ATTRIBUTES, HANDLE-EVENT): New functions and methods on gtk-tab-layout. (PARENT-AD-HOC-PRESENTATION): New class. * Backends/gtkairo/port.lisp (GTK-WIDGET-MODIFY-FG): New function. * Backends/gtkairo/ffi.lisp: Regenerated. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/12/27 14:47:24 1.18 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2007/02/04 12:55:43 1.19 @@ -307,6 +307,28 @@ (t 0))))) +(define-signal (tab-button-handler :return-type :int) (widget event) + (cffi:with-foreign-slots + ((type time button state x y x_root y_root) event gdkeventbutton) + (when (eql type GDK_BUTTON_PRESS) + ;; Hack alert: Menus don't work without this. + (gdk_pointer_ungrab GDK_CURRENT_TIME)) + (setf *last-seen-button* button) + (let ((page (widget->sheet widget *port*))) + (enqueue (make-instance + (if (eql type GDK_BUTTON_PRESS) + 'tab-press-event + 'tab-release-event) + :button (ecase button + (1 +pointer-left-button+) + (2 +pointer-middle-button+) + (3 +pointer-right-button+) + (4 +pointer-wheel-up+) + (5 +pointer-wheel-down+)) + :page page + :sheet (clim-tab-layout:tab-page-tab-layout page))))) + 1) + (define-signal enter-handler (widget event) (cffi:with-foreign-slots ((time state x y x_root y_root) event gdkeventcrossing) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/26 16:44:46 1.15 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2007/02/04 12:55:44 1.16 @@ -677,11 +677,6 @@ (arg0 :pointer) ;cairo_t * ) -(defcfun "cairo_stroke_preserve" - :void - (arg0 :pointer) ;cairo_t * - ) - (defcfun "cairo_stroke_extents" :void (arg0 :pointer) ;cairo_t * @@ -691,6 +686,11 @@ (arg4 :pointer) ;double * ) +(defcfun "cairo_stroke_preserve" + :pointer + (arg0 :pointer) ;cairo_t * + ) + (defcfun "cairo_surface_create_similar" :pointer (arg0 :pointer) ;cairo_surface_t * @@ -1115,6 +1115,11 @@ (value :double) ;gdouble ) +(defcfun "gtk_bin_get_child" + :pointer + (bin :pointer) ;GtkBin * + ) + (defcfun "gtk_button_new_with_label" :pointer (label :string) ;const gchar * @@ -1152,6 +1157,20 @@ (widget :pointer) ;GtkWidget * ) +(defcfun "gtk_event_box_new" :pointer) + +(defcfun "gtk_event_box_set_above_child" + :void + (event_box :pointer) ;GtkEventBox * + (above_child :int) ;gboolean + ) + +(defcfun "gtk_event_box_set_visible_window" + :void + (event_box :pointer) ;GtkEventBox * + (visible_window :int) ;gboolean + ) + (defcfun "gtk_events_pending" :int) (defcfun "gtk_fixed_move" @@ -1203,6 +1222,17 @@ (argv :pointer) ;char *** ) +(defcfun "gtk_label_new" + :pointer + (str :string) ;const gchar * + ) + +(defcfun "gtk_label_set_text" + :void + (label :pointer) ;GtkLabel * + (str :string) ;const gchar * + ) + (defcfun "gtk_list_store_append" :void (list_store :pointer) ;GtkListStore * @@ -1265,6 +1295,53 @@ (child :pointer) ;GtkWidget * ) +(defcfun "gtk_notebook_append_page" + :int + (notebook :pointer) ;GtkNotebook * + (child :pointer) ;GtkWidget * + (tab_label :pointer) ;GtkWidget * + ) + +(defcfun "gtk_notebook_get_current_page" + :int + (notebook :pointer) ;GtkNotebook * + ) + +(defcfun "gtk_notebook_get_tab_label" + :pointer + (notebook :pointer) ;GtkNotebook * + (child :pointer) ;GtkWidget * + ) + +(defcfun "gtk_notebook_insert_page" + :int + (notebook :pointer) ;GtkNotebook * + (child :pointer) ;GtkWidget * + (tab_label :pointer) ;GtkWidget * + (position :int) ;gint + ) + +(defcfun "gtk_notebook_new" :pointer) + +(defcfun "gtk_notebook_remove_page" + :void + (notebook :pointer) ;GtkNotebook * + (page_num :int) ;gint + ) + +(defcfun "gtk_notebook_reorder_child" + :void + (notebook :pointer) ;GtkNotebook * + (child :pointer) ;GtkWidget * + (position :int) ;gint + ) + +(defcfun "gtk_notebook_set_current_page" + :void + (notebook :pointer) ;GtkNotebook * + (page_num :int) ;gint + ) + (defcfun "gtk_radio_button_get_group" :pointer (radio_button :pointer) ;GtkRadioButton * @@ -1454,6 +1531,11 @@ (widget :pointer) ;GtkWidget * ) +(defcfun "gtk_widget_get_parent" + :pointer + (widget :pointer) ;GtkWidget * + ) + (defcfun "gtk_widget_get_pointer" :void (widget :pointer) ;GtkWidget * @@ -1490,6 +1572,18 @@ (color :pointer) ;const GdkColor * ) +(defcfun "gtk_widget_modify_fg" + :void + (widget :pointer) ;GtkWidget * + (state GtkStateType) + (color :pointer) ;const GdkColor * + ) + +(defcfun "gtk_widget_queue_draw" + :void + (widget :pointer) ;GtkWidget * + ) + (defcfun "gtk_widget_set_double_buffered" :void (widget :pointer) ;GtkWidget * --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/12/10 19:33:05 1.10 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2007/02/04 12:55:44 1.11 @@ -24,7 +24,9 @@ (defclass gtkairo-frame-manager (frame-manager) ()) -(defun frob-stupid-type-spec (type) +;; fixme! we're supposed to dispatch on the abstract name, not resolve +;; it to the (incorrect) concrete generic class name and dispatch on that. +(defun resolve-abstract-pane-name (type) (when (get type 'climi::concrete-pane-class-name) (setf type (get type 'climi::concrete-pane-class-name))) (class-name @@ -38,7 +40,7 @@ (defmethod make-pane-1 ((fm gtkairo-frame-manager) (frame application-frame) type &rest initargs) (apply #'make-pane-2 - (frob-stupid-type-spec type) + (resolve-abstract-pane-name type) :frame frame :manager fm :port (port frame) @@ -99,6 +101,10 @@ (defmethod make-pane-2 ((type (eql 'clim:generic-list-pane)) &rest initargs) (apply #'make-instance 'gtk-list initargs)) +(defmethod make-pane-2 + ((type (eql 'clim-tab-layout:tab-layout-pane)) &rest initargs) + (apply #'make-instance 'gtk-tab-layout initargs)) + (defmethod make-pane-2 ((type (eql 'clim:label-pane)) &rest initargs) (apply #'make-instance 'gtk-label-pane initargs)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/12/27 14:47:24 1.20 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2007/02/04 12:55:44 1.21 @@ -37,6 +37,13 @@ (defclass list-selection-event (gadget-event) ()) +(defclass tab-button-event (gadget-event) + ((page :initarg :page :accessor event-page) + (button :initarg :button :accessor event-button))) + +(defclass tab-press-event (tab-button-event) ()) +(defclass tab-release-event (tab-button-event) ()) + ;;;; Classes @@ -80,6 +87,11 @@ (label-pane-extra-width :accessor label-pane-extra-width) (label-pane-extra-height :accessor label-pane-extra-height))) +(defclass gtk-tab-layout (native-widget-mixin clim-tab-layout:tab-layout) + ((tab-layout-extra-width :accessor tab-layout-extra-width) + (tab-layout-extra-height :accessor tab-layout-extra-height))) + + ;;;; Constructors (defmethod realize-native-widget ((sheet gtk-button)) @@ -277,6 +289,97 @@ ((pane gtk-list) (event pointer-button-release-event)) nil) +(defmethod realize-native-widget ((sheet gtk-tab-layout)) + (let ((result (gtk_notebook_new)) + (dummy-child (gtk_fixed_new)) + (dummy-label (gtk_label_new "foo"))) + (gtk_notebook_append_page result dummy-child dummy-label) + (gtk_widget_show dummy-child) + (let* ((q + (reduce (lambda (x y) + (space-requirement-combine #'max x y)) + (mapcar #'compose-space (sheet-children sheet)) + :initial-value + (make-space-requirement + :width 0 :min-width 0 :max-width 0 + :height 0 :min-height 0 :max-height 0))) + (width1 (space-requirement-width q)) + (height1 (space-requirement-height q))) + (gtk_widget_set_size_request dummy-child width1 height1) + (cffi:with-foreign-object (r 'gtkrequisition) + (gtk_widget_size_request result r) + (cffi:with-foreign-slots ((width height) r gtkrequisition) + (setf (tab-layout-extra-width sheet) (- width width1)) + (setf (tab-layout-extra-height sheet) (- height height1)))) + (gtk_notebook_remove_page result 0)) + result)) + +(defmethod container-put ((parent gtk-tab-layout) parent-widget child x y) + (declare (ignore x y)) + (let* ((page (clim-tab-layout:sheet-to-page + (widget->sheet child (port parent)))) + (index (position page (clim-tab-layout:tab-layout-pages parent))) + (label (gtk_label_new (clim-tab-layout:tab-page-title page))) + (box (gtk_event_box_new))) + (gtk_event_box_set_visible_window box 0) + (gtk_container_add box label) + (gtk_widget_show_all box) + ;; naja, ein sheet ist das nicht + (setf (widget->sheet box (port parent)) page) + (connect-signal box "button-press-event" 'tab-button-handler) + (gtk_widget_show child) + (gtk_notebook_insert_page parent-widget child box index) + (set-tab-page-attributes page label) + ;; fixme: + (reorder-notebook-pages parent) + (setf (clim-tab-layout:tab-layout-enabled-page parent) + (clim-tab-layout:tab-layout-enabled-page parent)))) + +(defmethod (setf clim-tab-layout:tab-layout-pages) + :after + (newval (parent gtk-tab-layout)) + (declare (ignore newval)) + (reorder-notebook-pages parent)) + +(defun reorder-notebook-pages (parent) + (loop + for page in (clim-tab-layout:tab-layout-pages parent) + for i from 0 + do + (let* ((pane (clim-tab-layout:tab-page-pane page)) + (mirror (climi::port-lookup-mirror (port parent) pane))) + (when mirror + (gtk_notebook_reorder_child + (native-widget parent) + (mirror-widget mirror) + i))))) + +(defmethod container-move ((parent gtk-tab-layout) parent-widget child x y) + (declare (ignore parent-widget child x y))) + +(defmethod allocate-space ((pane gtk-tab-layout) width height) + (dolist (page (clim-tab-layout:tab-layout-pages pane)) + (let ((child (clim-tab-layout:tab-page-pane page))) + (move-sheet child 0 0) ;dummy + (allocate-space child + (- width (tab-layout-extra-width pane)) + (- height (tab-layout-extra-height pane)))))) + +(defmethod allocate-space :around ((pane gtk-tab-layout) width height) + ;; ARGH! Force the around method in panes.lisp to c-n-m. + (setf (climi::pane-current-width pane) nil) + (call-next-method)) + +(defmethod (setf clim-tab-layout:tab-layout-enabled-page) + :after + (newval (parent gtk-tab-layout)) + (when (and (native-widget parent) newval) + ;; fixme: + (reorder-notebook-pages parent) + (gtk_notebook_set_current_page + (native-widget parent) + (position newval (clim-tab-layout:tab-layout-pages parent))))) + (defun option-pane-set-active (sheet widget) (gtk_combo_box_set_active widget @@ -458,6 +561,10 @@ ;; no signals ) +(defmethod connect-native-signals ((sheet gtk-tab-layout) widget) + ;; no signals + ) + (defmethod connect-native-signals ((sheet gtk-option-pane) widget) (connect-signal widget "changed" 'magic-clicked-handler)) @@ -510,6 +617,66 @@ (:command (climi::throw-object-ptype item 'menu-item))))) +;;;(defmethod handle-event +;;; ((pane gtk-tab-layout) (event tab-release-event)) +;;; ) + +(defclass parent-ad-hoc-presentation (climi::ad-hoc-presentation) + ((ad-hoc-children :initarg :ad-hoc-children + :reader output-record-children))) + +(defmethod clim-tab-layout:note-tab-page-changed ((layout gtk-tab-layout) page) + (with-gtk () + (let* ((pane (clim-tab-layout:tab-page-pane page)) + (mirror (climi::port-lookup-mirror (port layout) pane))) + (when mirror + (let ((box (gtk_notebook_get_tab_label (native-widget layout) + (mirror-widget mirror)))) + (set-tab-page-attributes page (gtk_bin_get_child box))))))) + +(defun set-tab-page-attributes (page label) + ;; fixme: wieso funktioniert das in der tabdemo, nicht aber in beirc? + (let ((ink (getf (clim-tab-layout:tab-page-drawing-options page) :ink))) + (when ink + (gtk-widget-modify-fg label ink))) + (gtk_label_set_text label (clim-tab-layout:tab-page-title page)) + (gtk_widget_queue_draw label)) + +(defmethod handle-event + ((pane gtk-tab-layout) (event tab-press-event)) + (let* ((page (event-page event)) + (ptype (clim-tab-layout:tab-page-presentation-type page)) + (inner-presentation + (make-instance 'climi::ad-hoc-presentation + :object page + :single-box t + :type 'clim-tab-layout:tab-page)) + (presentation + (make-instance 'parent-ad-hoc-presentation + :ad-hoc-children (vector inner-presentation) + :object page + :single-box t + :type ptype))) + (case (event-button event) + (#.+pointer-right-button+ + (call-presentation-menu + presentation + *input-context* + *application-frame* + pane + 42 42 + :for-menu t + :label (format nil "Operation on ~A" ptype))) + (#.+pointer-left-button+ + (throw-highlighted-presentation + presentation + *input-context* + (make-instance 'pointer-button-press-event + :sheet pane + :x 42 :y 42 + :modifier-state 0 + :button (event-button event))))))) + (defmethod handle-event ((pane gtk-nonmenu) (event magic-gadget-event)) (funcall (gtk-nonmenu-callback pane) pane nil)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/12/25 21:34:57 1.15 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2007/02/04 12:55:44 1.16 @@ -244,6 +244,10 @@ (with-gdkcolor (c color) (gtk_widget_modify_bg widget 0 c))) +(defun gtk-widget-modify-fg (widget color) + (with-gdkcolor (c color) + (gtk_widget_modify_fg widget 0 c))) + ;; copy&paste from port.lisp|CLX: (defun sheet-desired-color (sheet) (typecase sheet

1 0

[mcclim-cvs] CVS mcclim/Doc
by dlichteblau 04 Feb '07

04 Feb '07

Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv1773/Doc Modified Files: make-docstrings.lisp mcclim.texi Log Message: Added the tab layout. * Extensions/tab-layout.lisp: New file. * Examples/tabdemo.lisp: New file. * mcclim.asd (CLIM): Added Extensions/tab-layout.lisp. (CLIM-EXAMPLES): Add tabdemo.lisp * package.lisp (CLIM-TAB-LAYOUT): New package. * Examples/demodemo.lisp: Added a button for the tabdemo. * Doc/make-docstrings.lisp: Process the clim-tab-layout package. * Doc/mcclim.texi: New chapter about the tab-layout. * Backends/CLX/frame-manager.lisp (GENERATE-STANDARD-PANE-SPECS, FIND-CONCRETE-PANE-CLASS): Obey define-abstract-pane-mapping even for names not the internal packages. * Backends/gtkairo/event.lisp (TAB-BUTTON-HANDLER): New. * Backends/gtkairo/frame-manager.lisp ((MAKE-PANE-2 TAB-LAYOUT-PANE)): New. (RESOLVE-ABSTRACT-PANE-NAME): Renamed. * Backends/gtkairo/gadgets.lisp (TAB-BUTTON-EVENT, TAB-PRESS-EVENT, TAB-RELEASE-EVENT, GTK-TAB-LAYOUT): New classes. (REALIZE-NATIVE-WIDGET, CONTAINER-PUT, (SETF CLIM-TAB-LAYOUT:TAB-LAYOUT-PAGES), REORDER-NOTEBOOK-PAGES, CONTAINER-MOVE, ALLOCATE-SPACE, (SETF CLIM-TAB-LAYOUT:TAB-LAYOUT-ENABLED-PAGE), CONNECT-NATIVE-SIGNALS, CLIM-TAB-LAYOUT:NOTE-TAB-PAGE-CHANGED, SET-TAB-PAGE-ATTRIBUTES, HANDLE-EVENT): New functions and methods on gtk-tab-layout. (PARENT-AD-HOC-PRESENTATION): New class. * Backends/gtkairo/port.lisp (GTK-WIDGET-MODIFY-FG): New function. * Backends/gtkairo/ffi.lisp: Regenerated. --- /project/mcclim/cvsroot/mcclim/Doc/make-docstrings.lisp 2006/12/21 12:22:02 1.1 +++ /project/mcclim/cvsroot/mcclim/Doc/make-docstrings.lisp 2007/02/04 12:55:44 1.2 @@ -6,7 +6,8 @@ :output-directory *output-dir* :packages '(:clim :drei :drei-buffer :drei-undo :drei-kill-ring :drei-base :drei-abbrev :drei-syntax :drei-motion - :drei-editing :drei-core :esa :clim-extensions) + :drei-editing :drei-core :esa :clim-extensions + :clim-tab-layout) :ignored-packages '(:clim-internals) :filetype "texi")) --- /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2007/01/14 21:53:03 1.7 +++ /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2007/02/04 12:55:44 1.8 @@ -101,6 +101,7 @@ * PostScript Backend:: * Drei:: * Fonts and Extended Text Styles:: +* Tab Layout:: Utility Programs * Listener:: @@ -1744,6 +1745,42 @@ @include fun-clim-extensions-font-face-all-sizes.texi @include fun-clim-extensions-font-face-text-style.texi +@node Tab Layout +@chapter Tab Layout + +The tab layout is a composite pane arranging its children so that +exactly one child is visible at any time, with a row of buttons +allowing the user to choose between them. + +See also the tabdemo.lisp example code located under Examples/ in the +McCLIM distribution. It can be started using demodemo. + +@include class-clim-tab-layout-tab-layout.texi +@include class-clim-tab-layout-tab-layout-pane.texi +@include class-clim-tab-layout-tab-page.texi +@include macro-clim-tab-layout-with-tab-layout.texi + +@include fun-clim-tab-layout-tab-layout-pages.texi + +@include fun-clim-tab-layout-tab-page-tab-layout.texi +@include fun-clim-tab-layout-tab-page-title.texi +@include fun-clim-tab-layout-tab-page-pane.texi +@include fun-clim-tab-layout-tab-page-presentation-type.texi +@include fun-clim-tab-layout-tab-page-drawing-options.texi + +@include fun-clim-tab-layout-add-page.texi +@include fun-clim-tab-layout-remove-page.texi +@include fun-clim-tab-layout-tab-layout-enabled-page.texi +@include fun-clim-tab-layout-sheet-to-page.texi +@include fun-clim-tab-layout-find-tab-page-named.texi +@include fun-clim-tab-layout-switch-to-page.texi +@include fun-clim-tab-layout-remove-page-named.texi + +@include fun-clim-tab-layout-note-tab-page-changed.texi + +@c com-switch-to-tab-page +@c com-remove-tab-page + @c @node Utility Programs @c @part Utility Programs

1 0

[mcclim-cvs] CVS mcclim/Examples
by dlichteblau 04 Feb '07

04 Feb '07

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv1773/Examples Modified Files: demodemo.lisp Added Files: tabdemo.lisp Log Message: Added the tab layout. * Extensions/tab-layout.lisp: New file. * Examples/tabdemo.lisp: New file. * mcclim.asd (CLIM): Added Extensions/tab-layout.lisp. (CLIM-EXAMPLES): Add tabdemo.lisp * package.lisp (CLIM-TAB-LAYOUT): New package. * Examples/demodemo.lisp: Added a button for the tabdemo. * Doc/make-docstrings.lisp: Process the clim-tab-layout package. * Doc/mcclim.texi: New chapter about the tab-layout. * Backends/CLX/frame-manager.lisp (GENERATE-STANDARD-PANE-SPECS, FIND-CONCRETE-PANE-CLASS): Obey define-abstract-pane-mapping even for names not the internal packages. * Backends/gtkairo/event.lisp (TAB-BUTTON-HANDLER): New. * Backends/gtkairo/frame-manager.lisp ((MAKE-PANE-2 TAB-LAYOUT-PANE)): New. (RESOLVE-ABSTRACT-PANE-NAME): Renamed. * Backends/gtkairo/gadgets.lisp (TAB-BUTTON-EVENT, TAB-PRESS-EVENT, TAB-RELEASE-EVENT, GTK-TAB-LAYOUT): New classes. (REALIZE-NATIVE-WIDGET, CONTAINER-PUT, (SETF CLIM-TAB-LAYOUT:TAB-LAYOUT-PAGES), REORDER-NOTEBOOK-PAGES, CONTAINER-MOVE, ALLOCATE-SPACE, (SETF CLIM-TAB-LAYOUT:TAB-LAYOUT-ENABLED-PAGE), CONNECT-NATIVE-SIGNALS, CLIM-TAB-LAYOUT:NOTE-TAB-PAGE-CHANGED, SET-TAB-PAGE-ATTRIBUTES, HANDLE-EVENT): New functions and methods on gtk-tab-layout. (PARENT-AD-HOC-PRESENTATION): New class. * Backends/gtkairo/port.lisp (GTK-WIDGET-MODIFY-FG): New function. * Backends/gtkairo/ffi.lisp: Regenerated. --- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/12/27 14:47:24 1.17 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2007/02/04 12:55:44 1.18 @@ -74,7 +74,8 @@ (lambda (&rest ignore) (declare (ignore ignore)) (format *trace-output* "~&You chose: ~A~%" - (select-font)))))) + (select-font)))) + (make-demo-button "Tab Layout" 'tabdemo:tabdemo))) (labelling (:label "Tests") (vertically (:equalize-width t) (make-demo-button "Label Test" 'label-test) --- /project/mcclim/cvsroot/mcclim/Examples/tabdemo.lisp 2007/02/04 12:55:44 NONE +++ /project/mcclim/cvsroot/mcclim/Examples/tabdemo.lisp 2007/02/04 12:55:44 1.1 (in-package :cl-user) (defpackage :tabdemo (:use :clim :clim-lisp :clim-tab-layout) (:export :tabdemo)) (in-package :tabdemo) ;;; example and testing code (define-presentation-type special-page ()) (define-application-frame tabdemo () () (:menu-bar tabdemo-menubar) (:panes (a :text-editor :value "Hello World from page A") (b :text-editor :value "Hello World from page B") (c :text-editor :value "This is page C speaking") (special-page :text-editor :value "This page has a special presentation type") (io :interactor :height 150 :width 600) (pointer-doc :pointer-documentation)) (:layouts (default (vertically () (with-tab-layout ('tab-page :name 'tabdemo-layout :height 200) ("A" a) ("B" b) ("C" c) ("Special Page" special-page :presentation-type 'special-page)) io pointer-doc)))) (define-tabdemo-command (com-remove-tabdemo-page :name t) ((page 'tab-page :prompt "Tab page" :gesture :delete)) (remove-page page)) (make-command-table 'tabdemo-pages-menu :errorp nil :menu '(("Add Extra Pane" :command com-add-extra-pane) ("Randomize" :command com-randomize-tabdemo) ("Quit" :command com-quit-tabdemo))) (make-command-table 'tabdemo-properties-menu :errorp nil :menu '(("Change Page Title" :command com-change-page-title) ("Paint Page Red" :command com-paint-page-red) ("Paint Page Green" :command com-paint-page-green))) (make-command-table 'tabdemo-presentation-tests-menu :errorp nil :menu '(("Choose Any Page" :command com-choose-any-page) ("Choose Special Page" :command com-choose-special-page))) (make-command-table 'tabdemo-menubar :errorp nil :menu '(("Pages" :menu tabdemo-pages-menu) ("Properties" :menu tabdemo-properties-menu) ("Presentation Tests" :menu tabdemo-presentation-tests-menu))) (defun tabdemo () (run-frame-top-level (make-application-frame 'tabdemo))) ;;;(define-presentation-to-command-translator remove-pane ;;; (tab-page com-remove-tab-page tabdemo ;;; :gesture :describe ;;; :documentation "remove this pane" ;;; :pointer-documentation "remove this pane") ;;; (object) ;;; (list object)) ;; FIXME: It only get errors due to bogus frame names with FIND-PANE-NAMED. ;; Ignoring the symbol identity and case works around that. (defun sane-find-pane-named (frame name) (find name (climi::frame-named-panes frame) :key #'pane-name :test #'string-equal)) (defun tabdemo-layout () (sane-find-pane-named *application-frame* 'tabdemo-layout)) (define-tabdemo-command (com-add-extra-pane :name t) () (let ((fm (frame-manager *application-frame*))) (with-look-and-feel-realization (fm *application-frame*) (add-page (make-instance 'tab-page :title "X" :pane (make-pane 'text-editor-pane :value "This is an extra page")) (tabdemo-layout) t)))) (define-tabdemo-command (com-choose-any-page :name t) () (format *standard-input* "You choice: ~A~%" (accept 'tab-page))) (define-tabdemo-command (com-choose-special-page :name t) () (accept 'special-page) (write-line "Correct answer! That's the special page." *standard-input*)) (define-tabdemo-command (com-quit-tabdemo :name t) () (frame-exit *application-frame*)) (define-tabdemo-command (com-randomize-tabdemo :name t) () (setf (tab-layout-pages (tabdemo-layout)) (let ((old (tab-layout-pages (tabdemo-layout))) (new '())) (loop while old for i = (random (length old)) do (push (elt old i) new) (setf old (remove-if (constantly t) old :start i :count 1))) new))) (define-tabdemo-command (com-change-page-title :name t) () (let ((page (tab-layout-enabled-page (tabdemo-layout)))) (when page (setf (tab-page-title page) (accept 'string :prompt "New title" :default (tab-page-title page)))))) (define-tabdemo-command (com-paint-page-red :name t) () (let ((page (tab-layout-enabled-page (tabdemo-layout)))) (when page (setf (getf (tab-page-drawing-options page) :ink) +red+)))) (define-tabdemo-command (com-paint-page-green :name t) () (let ((page (tab-layout-enabled-page (tabdemo-layout)))) (when page (setf (getf (tab-page-drawing-options page) :ink) +green+)))) #+(or) (tabdemo:tabdemo)

1 0

[mcclim-cvs] CVS mcclim
by dlichteblau 04 Feb '07

04 Feb '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv1773 Modified Files: clim-examples.asd mcclim.asd package.lisp Log Message: Added the tab layout. * Extensions/tab-layout.lisp: New file. * Examples/tabdemo.lisp: New file. * mcclim.asd (CLIM): Added Extensions/tab-layout.lisp. (CLIM-EXAMPLES): Add tabdemo.lisp * package.lisp (CLIM-TAB-LAYOUT): New package. * Examples/demodemo.lisp: Added a button for the tabdemo. * Doc/make-docstrings.lisp: Process the clim-tab-layout package. * Doc/mcclim.texi: New chapter about the tab-layout. * Backends/CLX/frame-manager.lisp (GENERATE-STANDARD-PANE-SPECS, FIND-CONCRETE-PANE-CLASS): Obey define-abstract-pane-mapping even for names not the internal packages. * Backends/gtkairo/event.lisp (TAB-BUTTON-HANDLER): New. * Backends/gtkairo/frame-manager.lisp ((MAKE-PANE-2 TAB-LAYOUT-PANE)): New. (RESOLVE-ABSTRACT-PANE-NAME): Renamed. * Backends/gtkairo/gadgets.lisp (TAB-BUTTON-EVENT, TAB-PRESS-EVENT, TAB-RELEASE-EVENT, GTK-TAB-LAYOUT): New classes. (REALIZE-NATIVE-WIDGET, CONTAINER-PUT, (SETF CLIM-TAB-LAYOUT:TAB-LAYOUT-PAGES), REORDER-NOTEBOOK-PAGES, CONTAINER-MOVE, ALLOCATE-SPACE, (SETF CLIM-TAB-LAYOUT:TAB-LAYOUT-ENABLED-PAGE), CONNECT-NATIVE-SIGNALS, CLIM-TAB-LAYOUT:NOTE-TAB-PAGE-CHANGED, SET-TAB-PAGE-ATTRIBUTES, HANDLE-EVENT): New functions and methods on gtk-tab-layout. (PARENT-AD-HOC-PRESENTATION): New class. * Backends/gtkairo/port.lisp (GTK-WIDGET-MODIFY-FG): New function. * Backends/gtkairo/ffi.lisp: Regenerated. --- /project/mcclim/cvsroot/mcclim/clim-examples.asd 2007/01/18 15:01:11 1.1 +++ /project/mcclim/cvsroot/mcclim/clim-examples.asd 2007/02/04 12:55:43 1.2 @@ -20,7 +20,7 @@ (:file "postscript-test") (:file "puzzle") (:file "transformations-test") - (:file "demodemo") + (:file "demodemo" :depends-on ("tabdemo")) (:file "stream-test") (:file "presentation-test") (:file "dragndrop") @@ -34,7 +34,8 @@ (:file "drawing-benchmark") (:file "logic-cube") (:file "views") - (:file "font-selector"))) + (:file "font-selector") + (:file "tabdemo"))) (:module "Goatee" :components ((:file "goatee-test"))))) --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/18 15:01:11 1.53 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/02/04 12:55:43 1.54 @@ -352,7 +352,10 @@ (:file "input-editing-drei") (:file "text-editor-gadget") (:file "Extensions/rgb-image" :pathname #.(make-pathname :directory '(:relative "Extensions") - :name "rgb-image")))) + :name "rgb-image")) + (:file "Extensions/tab-layout" + :pathname #.(make-pathname :directory '(:relative "Extensions") + :name "tab-layout")))) (defsystem :clim-clx :depends-on (:clim #+(or sbcl openmcl ecl allegro) :clx) --- /project/mcclim/cvsroot/mcclim/package.lisp 2006/12/24 14:27:43 1.59 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2007/02/04 12:55:43 1.60 @@ -2104,3 +2104,26 @@ )) +(defpackage :clim-tab-layout + (:use :clim :clim-lisp) + (:export #:tab-layout + #:tab-layout-pane + #:tab-layout-pages + #:tab-page + #:tab-page-tab-layout + #:tab-page-title + #:tab-page-pane + #:tab-page-presentation-type + #:tab-page-drawing-options + #:add-page + #:remove-page + #:tab-layout-enabled-page + #:sheet-to-page + #:find-tab-page-named + #:switch-to-page + #:remove-page-named + #:with-tab-layout + #:com-switch-to-tab-page + #:com-remove-tab-page + #:internal-child-p + #:note-tab-page-changed))

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by dlichteblau 04 Feb '07

04 Feb '07

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv1773/Backends/CLX Modified Files: frame-manager.lisp Log Message: Added the tab layout. * Extensions/tab-layout.lisp: New file. * Examples/tabdemo.lisp: New file. * mcclim.asd (CLIM): Added Extensions/tab-layout.lisp. (CLIM-EXAMPLES): Add tabdemo.lisp * package.lisp (CLIM-TAB-LAYOUT): New package. * Examples/demodemo.lisp: Added a button for the tabdemo. * Doc/make-docstrings.lisp: Process the clim-tab-layout package. * Doc/mcclim.texi: New chapter about the tab-layout. * Backends/CLX/frame-manager.lisp (GENERATE-STANDARD-PANE-SPECS, FIND-CONCRETE-PANE-CLASS): Obey define-abstract-pane-mapping even for names not the internal packages. * Backends/gtkairo/event.lisp (TAB-BUTTON-HANDLER): New. * Backends/gtkairo/frame-manager.lisp ((MAKE-PANE-2 TAB-LAYOUT-PANE)): New. (RESOLVE-ABSTRACT-PANE-NAME): Renamed. * Backends/gtkairo/gadgets.lisp (TAB-BUTTON-EVENT, TAB-PRESS-EVENT, TAB-RELEASE-EVENT, GTK-TAB-LAYOUT): New classes. (REALIZE-NATIVE-WIDGET, CONTAINER-PUT, (SETF CLIM-TAB-LAYOUT:TAB-LAYOUT-PAGES), REORDER-NOTEBOOK-PAGES, CONTAINER-MOVE, ALLOCATE-SPACE, (SETF CLIM-TAB-LAYOUT:TAB-LAYOUT-ENABLED-PAGE), CONNECT-NATIVE-SIGNALS, CLIM-TAB-LAYOUT:NOTE-TAB-PAGE-CHANGED, SET-TAB-PAGE-ATTRIBUTES, HANDLE-EVENT): New functions and methods on gtk-tab-layout. (PARENT-AD-HOC-PRESENTATION): New class. * Backends/gtkairo/port.lisp (GTK-WIDGET-MODIFY-FG): New function. * Backends/gtkairo/ffi.lisp: Regenerated. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/frame-manager.lisp 2004/10/31 01:46:31 1.21 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/frame-manager.lisp 2007/02/04 12:55:43 1.22 @@ -49,9 +49,11 @@ (remove-if #'null (mapcar #'(lambda (x) (find-symbol-from-spec (first x) (rest x))) name-specs))) (defun generate-standard-pane-specs (type) - `((:climi ,(get type 'climi::concrete-pane-class-name)) - (:climi ,type #:-pane) - (:climi ,type))) + (let ((mapping (get type 'climi::concrete-pane-class-name))) + `((,(symbol-package mapping) ,mapping) + (:climi ,mapping) + (:climi ,type #:-pane) + (:climi ,type)))) (defun generate-clx-pane-specs (type) (append @@ -67,7 +69,8 @@ (eql (symbol-package type) (find-package '#:climi)) (eql (symbol-package type) - (find-package '#:keyword))) + (find-package '#:keyword)) + (get type 'climi::concrete-pane-class-name)) (find-first-defined-class (find-symbols (generate-clx-pane-specs type))) type))

1 0