Update of /project/mcclim/cvsroot/mcclim/Extensions In directory clnet:/tmp/cvs-serv23102/d
Modified Files: tab-layout.lisp Log Message: Pixie tab layout. Slight refactoring of the basic tab layout necessary so that the implementation can be reused.
Tweaked space allocation of pixie buttons.
--- /project/mcclim/cvsroot/mcclim/Extensions/tab-layout.lisp 2007/02/04 14:53:32 1.2 +++ /project/mcclim/cvsroot/mcclim/Extensions/tab-layout.lisp 2007/03/20 01:51:22 1.3 @@ -273,7 +273,7 @@ :pages (list ,@(mapcar (lambda (spec) `(make-tab-page ,@spec :presentation-type - ,ptypevar)) + ,ptypevar)) body)) ,@initargs))))
@@ -309,26 +309,6 @@
;;; 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)) - (defclass tab-bar-view (gadget-view) ())
@@ -369,33 +349,64 @@ (tab-page-drawing-options tab-page)) (stream-increment-cursor-position stream 10 0))
+(defclass tab-layout-pane (tab-layout) + ((header-pane :accessor tab-layout-header-pane + :initarg :header-pane) + (header-display-function + :accessor header-display-function + :initarg :header-display-function + :initform 'default-display-tab-header)) + (: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)) + +(defun default-display-tab-header (tab-layout pane) + (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 tab-layout))) + +(defclass tab-bar-pane (application-pane) + () + (:default-initargs :default-view +tab-bar-view+)) + +(defmethod compose-space ((pane tab-bar-pane) &key width height) + (declare (ignore width height)) + (make-space-requirement :min-height 22 :height 22 :max-height 22)) + (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+ + (make-pane 'tab-bar-pane :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)))))) + (declare (ignore frame)) + (funcall (header-display-function instance) instance pane))))) (setf (tab-layout-header-pane instance) header) (sheet-adopt-child instance header) (setf (sheet-enabled-p header) t))) @@ -430,6 +441,8 @@ (defmethod clim-tab-layout:note-tab-page-changed ((layout tab-layout-pane) page) (redisplay-frame-pane (pane-frame layout) + (tab-layout-header-pane layout) + #+NIL (car (sheet-children (car (sheet-children (tab-layout-header-pane layout)))))