Index: mcclim.asd
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/mcclim.asd,v
retrieving revision 1.45
diff -u -u -r1.45 mcclim.asd
--- mcclim.asd	26 Dec 2006 16:44:45 -0000	1.45
+++ mcclim.asd	29 Dec 2006 14:34:09 -0000
@@ -341,7 +341,10 @@
           :pathname #.(make-pathname :directory '(:relative "Goatee") :name "presentation-history" :type "lisp"))
    (:file "input-editing-goatee")
    (:file "input-editing-drei")
-   (:file "text-editor-gadget")))
+   (:file "text-editor-gadget")
+   ;; need to compile this unconditionally, since Gtkairo and the Pixie look
+   ;; want to customize it:
+   (:file "Extensions/tab-layout")))
 
 (defsystem :clim-clx
     :depends-on (:clim #+(or sbcl openmcl ecl allegro) :clx)
@@ -455,7 +458,7 @@
                (:file "postscript-test")
                (:file "puzzle")
                (:file "transformations-test")
-	       (:file "demodemo")
+	       (:file "demodemo" :depends-on ("tabdemo"))
                (:file "stream-test")
                (:file "presentation-test")
                (:file "dragndrop")
@@ -469,7 +472,8 @@
                (:file "drawing-benchmark")
                (:file "logic-cube")
                (:file "views")
-               (:file "font-selector")))
+               (:file "font-selector")
+               (:file "tabdemo")))
      (:module "Goatee"
 	      :components
 	      ((:file "goatee-test")))))
Index: package.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/package.lisp,v
retrieving revision 1.59
diff -u -u -r1.59 package.lisp
--- package.lisp	24 Dec 2006 14:27:43 -0000	1.59
+++ package.lisp	29 Dec 2006 14:34:09 -0000
@@ -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))
Index: Backends/CLX/frame-manager.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Backends/CLX/frame-manager.lisp,v
retrieving revision 1.21
diff -u -u -r1.21 frame-manager.lisp
--- Backends/CLX/frame-manager.lisp	31 Oct 2004 01:46:31 -0000	1.21
+++ Backends/CLX/frame-manager.lisp	29 Dec 2006 14:34:09 -0000
@@ -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))
   
Index: Backends/gtkairo/event.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp,v
retrieving revision 1.18
diff -u -u -r1.18 event.lisp
--- Backends/gtkairo/event.lisp	27 Dec 2006 14:47:24 -0000	1.18
+++ Backends/gtkairo/event.lisp	29 Dec 2006 14:34:09 -0000
@@ -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)
Index: Backends/gtkairo/ffi.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp,v
retrieving revision 1.15
diff -u -u -r1.15 ffi.lisp
--- Backends/gtkairo/ffi.lisp	26 Dec 2006 16:44:46 -0000	1.15
+++ Backends/gtkairo/ffi.lisp	29 Dec 2006 14:34:09 -0000
@@ -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 *
Index: Backends/gtkairo/frame-manager.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp,v
retrieving revision 1.10
diff -u -u -r1.10 frame-manager.lisp
--- Backends/gtkairo/frame-manager.lisp	10 Dec 2006 19:33:05 -0000	1.10
+++ Backends/gtkairo/frame-manager.lisp	29 Dec 2006 14:34:09 -0000
@@ -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))
 
Index: Backends/gtkairo/gadgets.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp,v
retrieving revision 1.20
diff -u -u -r1.20 gadgets.lisp
--- Backends/gtkairo/gadgets.lisp	27 Dec 2006 14:47:24 -0000	1.20
+++ Backends/gtkairo/gadgets.lisp	29 Dec 2006 14:34:09 -0000
@@ -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))
Index: Backends/gtkairo/port.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp,v
retrieving revision 1.15
diff -u -u -r1.15 port.lisp
--- Backends/gtkairo/port.lisp	25 Dec 2006 21:34:57 -0000	1.15
+++ Backends/gtkairo/port.lisp	29 Dec 2006 14:34:09 -0000
@@ -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
Index: Doc/make-docstrings.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Doc/make-docstrings.lisp,v
retrieving revision 1.1
diff -u -u -r1.1 make-docstrings.lisp
--- Doc/make-docstrings.lisp	21 Dec 2006 12:22:02 -0000	1.1
+++ Doc/make-docstrings.lisp	29 Dec 2006 14:34:09 -0000
@@ -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"))
 
Index: Doc/mcclim.texi
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi,v
retrieving revision 1.4
diff -u -u -r1.4 mcclim.texi
--- Doc/mcclim.texi	24 Dec 2006 14:27:48 -0000	1.4
+++ Doc/mcclim.texi	29 Dec 2006 14:34:09 -0000
@@ -97,6 +97,7 @@
 * PostScript Backend::
 * Drei::
 * Fonts and Extended Text Styles::
+* Tab Layout::
 
 Utility Programs
 * Listener::
@@ -1661,6 +1662,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
 
Index: Examples/demodemo.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp,v
retrieving revision 1.17
diff -u -u -r1.17 demodemo.lisp
--- Examples/demodemo.lisp	27 Dec 2006 14:47:24 -0000	1.17
+++ Examples/demodemo.lisp	29 Dec 2006 14:34:09 -0000
@@ -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)
Index: Examples/tabdemo.lisp
===================================================================
RCS file: Examples/tabdemo.lisp
diff -N Examples/tabdemo.lisp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ Examples/tabdemo.lisp	29 Dec 2006 14:34:09 -0000
@@ -0,0 +1,150 @@
+(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)
Index: Extensions/tab-layout.lisp
===================================================================
RCS file: Extensions/tab-layout.lisp
diff -N Extensions/tab-layout.lisp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ Extensions/tab-layout.lisp	29 Dec 2006 14:34:09 -0000
@@ -0,0 +1,406 @@
+;;; -*- Mode: Lisp; show-trailing-whitespace: t; indent-tabs: nil; -*-
+
+;;;  (c) copyright 2005 by Max-Gerd Retzlaff
+;;;  (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))
+		      (present page 'tab-page :stream pane)))
+		  (tab-layout-pages instance))))))
+    (setf (tab-layout-header-pane instance) header)
+    (sheet-adopt-child instance header)
+    (setf (sheet-enabled-p header) t)))
+
+;;;;
+;;;; End of original MGR source code
+;;;;
+
+(defmethod compose-space ((pane tab-layout-pane) &key width height)
+  (declare (ignore width height))
+  (let ((q (compose-space (tab-layout-header-pane pane))))
+    (space-requirement+*
+     (reduce (lambda (x y)
+	       (space-requirement-combine #'max x y))
+	     (mapcar #'compose-space (sheet-children pane))
+	     :initial-value
+	     (make-space-requirement :width 0 :min-width 0 :max-width 0
+				     :height 0 :min-height 0 :max-height 0))
+     :height (space-requirement-height q)
+     :min-height (space-requirement-min-height q)
+     :max-height (space-requirement-max-height q))))
+
+(defmethod allocate-space ((pane tab-layout-pane) width height)
+  (let* ((header (tab-layout-header-pane pane))
+	 (y (space-requirement-height (compose-space header))))
+    (move-and-resize-sheet header 0 0 width y)
+    (allocate-space header width y)
+    (dolist (page (tab-layout-pages pane))
+      (let ((child (tab-page-pane page)))
+	(move-and-resize-sheet child 0 y width (- height y))
+	(allocate-space child width (- height y))))))
+
+(defmethod internal-child-p (child (parent tab-layout-pane))
+  (eq child (tab-layout-header-pane parent)))