From dlichteblau at common-lisp.net Sun Feb 4 12:55:43 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 4 Feb 2007 07:55:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070204125543.AFDF3A105@common-lisp.net> 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)) From dlichteblau at common-lisp.net Sun Feb 4 12:55:43 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 4 Feb 2007 07:55:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20070204125543.E9E5714009@common-lisp.net> 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)) From dlichteblau at common-lisp.net Sun Feb 4 12:55:44 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 4 Feb 2007 07:55:44 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20070204125544.3E92514009@common-lisp.net> 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 From dlichteblau at common-lisp.net Sun Feb 4 12:55:44 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 4 Feb 2007 07:55:44 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20070204125544.78E8A140B1@common-lisp.net> 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 + at node Tab Layout + at 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. + + at include class-clim-tab-layout-tab-layout.texi + at include class-clim-tab-layout-tab-layout-pane.texi + at include class-clim-tab-layout-tab-page.texi + at include macro-clim-tab-layout-with-tab-layout.texi + + at include fun-clim-tab-layout-tab-layout-pages.texi + + at include fun-clim-tab-layout-tab-page-tab-layout.texi + at include fun-clim-tab-layout-tab-page-title.texi + at include fun-clim-tab-layout-tab-page-pane.texi + at include fun-clim-tab-layout-tab-page-presentation-type.texi + at include fun-clim-tab-layout-tab-page-drawing-options.texi + + at include fun-clim-tab-layout-add-page.texi + at include fun-clim-tab-layout-remove-page.texi + at include fun-clim-tab-layout-tab-layout-enabled-page.texi + at include fun-clim-tab-layout-sheet-to-page.texi + at include fun-clim-tab-layout-find-tab-page-named.texi + at include fun-clim-tab-layout-switch-to-page.texi + at include fun-clim-tab-layout-remove-page-named.texi + + at include fun-clim-tab-layout-note-tab-page-changed.texi + + at c com-switch-to-tab-page + at c com-remove-tab-page + @c @node Utility Programs @c @part Utility Programs From dlichteblau at common-lisp.net Sun Feb 4 12:55:44 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 4 Feb 2007 07:55:44 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20070204125544.004D319001@common-lisp.net> 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) From dlichteblau at common-lisp.net Sun Feb 4 12:55:45 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 4 Feb 2007 07:55:45 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Extensions Message-ID: <20070204125545.360AD19001@common-lisp.net> 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 , 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 _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 _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 ;;; 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 , at spec :presentation-type ,ptypevar)) body)) , at 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] From dlichteblau at common-lisp.net Sun Feb 4 14:53:33 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 4 Feb 2007 09:53:33 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Extensions Message-ID: <20070204145333.0BFFF1A09C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions In directory clnet:/tmp/cvs-serv27996 Modified Files: tab-layout.lisp Log Message: force redisplay of the tab header bar * Extensions/tab-layout.lisp (clim-tab-layout:note-tab-page-changed): New method. --- /project/mcclim/cvsroot/mcclim/Extensions/tab-layout.lisp 2007/02/04 12:55:45 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/tab-layout.lisp 2007/02/04 14:53:32 1.2 @@ -329,10 +329,6 @@ (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) ()) @@ -404,10 +400,6 @@ (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)))) @@ -434,3 +426,11 @@ (defmethod internal-child-p (child (parent tab-layout-pane)) (eq child (tab-layout-header-pane parent))) + +(defmethod clim-tab-layout:note-tab-page-changed + ((layout tab-layout-pane) page) + (redisplay-frame-pane (pane-frame layout) + (car (sheet-children + (car (sheet-children + (tab-layout-header-pane layout))))) + :force-p t)) From ahefner at common-lisp.net Mon Feb 5 02:54:20 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 21:54:20 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070205025420.92EE2330A1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5009 Modified Files: design.lisp Log Message: Added highlight-shade helper function. --- /project/mcclim/cvsroot/mcclim/design.lisp 2006/03/10 21:58:12 1.25 +++ /project/mcclim/cvsroot/mcclim/design.lisp 2007/02/05 02:54:20 1.26 @@ -856,3 +856,29 @@ (and (= r1 r2) (= g1 g2) (= b1 b2))))) + +;;; Color utilities + +(defgeneric highlight-shade (ink) + (:documentation + "Produce an alternate shade of the given ink for the purpose of highlighting. + Typically the ink will be brightened, but very light inks may be darkened.")) + +(defmethod highlight-shade (ink) ink) + +(defmethod highlight-shade ((ink (eql +background-ink+))) + +foreground-ink+) + +(defmethod highlight-shade ((ink (eql +foreground-ink+))) + +background-ink+) + +(defmethod highlight-shade ((ink standard-color)) + (let ((brighten-factor 0.5) + (darken-factor 0.15)) + (multiple-value-bind (r g b) (color-rgb ink) + (multiple-value-bind (blend-ink factor) + (if (> (- 3.0 r g b) 0.2) + (values +white+ brighten-factor) + (values +black+ darken-factor)) + (compose-over (compose-in blend-ink (make-opacity factor)) + ink))))) From ahefner at common-lisp.net Mon Feb 5 02:55:29 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 21:55:29 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070205025529.57F3E34052@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5175 Modified Files: frames.lisp Log Message: Make :default-initargs work as a parameter to define-application-frame. --- /project/mcclim/cvsroot/mcclim/frames.lisp 2007/01/04 09:13:25 1.123 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2007/02/05 02:55:29 1.124 @@ -238,8 +238,9 @@ (defmethod layout-frame ((frame application-frame) &optional width height) (let ((pane (frame-panes frame))) - (if (and width (not height)) - (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither")) + (when (and (or width height) + (not (and width height))) + (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither")) (if (and (null width) (null height)) (let ((space (compose-space pane))) ;I guess, this might be wrong. --GB 2004-06-01 (setq width (space-requirement-width space)) @@ -600,7 +601,7 @@ #+clim-mp (event-queue (sheet-event-queue t-l-s))) (setf (slot-value frame 'top-level-sheet) t-l-s) (generate-panes fm frame) - (setf (slot-value frame 'state) :disabled) + (setf (slot-value frame 'state) :disabled) #+clim-mp (when (typep event-queue 'port-event-queue) (setf (event-queue-port event-queue) @@ -795,6 +796,7 @@ (others nil) (pointer-documentation nil) (geometry nil) + (user-default-initargs nil) (frame-arg (gensym "FRAME-ARG"))) (loop for (prop . values) in options do (case prop @@ -810,6 +812,7 @@ (:top-level (setq top-level (first values))) (:pointer-documentation (setq pointer-documentation (car values))) (:geometry (setq geometry values)) + (:default-initargs (setq user-default-initargs values)) (t (push (cons prop values) others)))) (when (eq command-definer t) (setf command-definer @@ -838,7 +841,8 @@ :top-level (list ',(car top-level) ,@(cdr top-level)) :top-level-lambda (lambda (,frame-arg) (,(car top-level) ,frame-arg - ,@(cdr top-level)))) + ,@(cdr top-level))) + , at user-default-initargs) , at others) ;; We alway set the frame class default geometry, so that the ;; user can undo the effect of a specified :geometry option. @@ -943,11 +947,14 @@ (graft :initform nil :accessor graft) (manager :initform nil :accessor frame-manager))) +(defclass menu-unmanaged-top-level-sheet-pane (unmanaged-top-level-sheet-pane) + ()) + (defmethod adopt-frame ((fm frame-manager) (frame menu-frame)) (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames))) (setf (frame-manager frame) fm) (let* ((t-l-s (make-pane-1 fm *application-frame* - 'unmanaged-top-level-sheet-pane + 'menu-unmanaged-top-level-sheet-pane :name 'top-level-sheet))) (setf (slot-value frame 'top-level-sheet) t-l-s) (sheet-adopt-child t-l-s (frame-panes frame)) From ahefner at common-lisp.net Mon Feb 5 02:57:18 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 21:57:18 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070205025718.678BC7D164@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5246 Modified Files: gadgets.lisp Log Message: Trivial changes (change :max-height of push-button-pane to +fill+, move functions around). --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/12/27 14:47:23 1.103 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2007/02/05 02:57:18 1.104 @@ -203,13 +203,9 @@ ;; immediate-sheet-input-mixin ;; immediate-repainting-mixin basic-pane - gadget - ) - ;; Half-baked attempt to be compatible with Lispworks. ??? -moore - ;; Inherited from basic-pane with different defaults. - ((foreground :initform +black+) - #+IGNORE (background :initform +white+) ; This is evil.. -Hefner - )) + gadget) + ()) + ;; Where is this standard-gadget from? --GB @@ -701,8 +697,8 @@ (defclass enter/exit-arms/disarms-mixin () () (:documentation - "Mixin class for gadgets, which will be armed, when the mouse enters and - disarmed, when the mouse leaves.")) + "Mixin class for gadgets which are armed when the mouse enters and + disarmed when the mouse leaves.")) (defmethod handle-event :before ((pane enter/exit-arms/disarms-mixin) (event pointer-enter-event)) (declare (ignorable event)) @@ -737,7 +733,12 @@ (declare (ignorable client)) (disarm-gadget gadget)) -;; +;;;; ------------------------------------------------------------------------------------------ +;;;; +;;;; Drawing Utilities for Concrete Gadgets +;;;; + +;;; Labels (defmethod compose-label-space ((gadget labelled-gadget-mixin) &key (wider 0) (higher 0)) (with-slots (label align-x align-y) gadget @@ -769,11 +770,6 @@ :text-style (pane-text-style pane) :ink ink)))) -;;;; ------------------------------------------------------------------------------------------ -;;;; -;;;; Drawing Utilities for Concrete Gadgets -;;;; - ;;; 3D-ish Look ;; DRAW-BORDERED-POLYGON medium point-seq &key border-width style @@ -950,7 +946,10 @@ medium (polygon-points (make-rectangle* x1 y1 x2 y2)) options)) - + +(defun draw-engraved-label* (pane x1 y1 x2 y2) + (draw-label* pane (1+ x1) (1+ y1) (1+ x2) (1+ y2) :ink *3d-light-color*) + (draw-label* pane x1 y1 x2 y2 :ink *3d-dark-color*)) ;;;; ;;;; 3D-BORDER-MIXIN Class @@ -1040,7 +1039,7 @@ :initarg :show-as-default-p :accessor push-button-show-as-default-p)) (:default-initargs - :text-style (make-text-style :sans-serif nil nil) + :text-style (make-text-style :sans-serif nil nil) :background *3d-normal-color* :align-x :center :align-y :center @@ -1076,10 +1075,6 @@ (setf pressedp nil) (dispatch-repaint pane +everywhere+)))) -(defun draw-engraved-label* (pane x1 y1 x2 y2) - (draw-label* pane (1+ x1) (1+ y1) (1+ x2) (1+ y2) :ink *3d-light-color*) - (draw-label* pane x1 y1 x2 y2 :ink *3d-dark-color*)) - (defmethod handle-repaint ((pane push-button-pane) region) (declare (ignore region)) (with-slots (armed pressedp) pane @@ -2044,7 +2039,7 @@ (h (* n (generic-list-pane-item-height pane)))) (make-space-requirement :width w :height h :min-width w :min-height h - :max-width +fill+ :max-height h))) + :max-width +fill+ :max-height +fill+))) (defmethod allocate-space ((pane generic-list-pane) w h) (resize-sheet pane w h)) From ahefner at common-lisp.net Mon Feb 5 02:57:58 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 21:57:58 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070205025758.1E3F57D164@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5296 Modified Files: medium.lisp Log Message: Added merge-line-styles function. --- /project/mcclim/cvsroot/mcclim/medium.lisp 2006/12/24 14:27:43 1.61 +++ /project/mcclim/cvsroot/mcclim/medium.lisp 2007/02/05 02:57:58 1.62 @@ -499,6 +499,19 @@ (eql (line-style-joint-shape style1) (line-style-joint-shape style2)) (eql (line-style-cap-shape style1) (line-style-cap-shape style2)) (eql (line-style-dashes style1) (line-style-dashes style2)))) + +(defun merge-line-styles (a b) + (make-line-style :unit (or (line-style-unit a) + (line-style-unit b)) + :thickness (or (line-style-thickness a) + (line-style-thickness b)) + :joint-shape (or (line-style-joint-shape a) + (line-style-joint-shape b)) + :cap-shape (or (line-style-cap-shape a) + (line-style-cap-shape b)) + :dashes (or (line-style-dashes a) + (line-style-dashes b)))) + ;;; Misc ops From ahefner at common-lisp.net Mon Feb 5 02:58:47 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 21:58:47 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070205025847.0A0647D164@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5329 Modified Files: graphics.lisp Log Message: Added draw-rounded-rectangle* function. --- /project/mcclim/cvsroot/mcclim/graphics.lisp 2006/12/23 11:41:23 1.56 +++ /project/mcclim/cvsroot/mcclim/graphics.lisp 2007/02/05 02:58:46 1.57 @@ -651,10 +651,12 @@ (with-medium-options (sheet args) (if (coordinate<= y-radius x-radius) (let ((x1 (- center-x x-radius)) (x2 (+ center-x x-radius)) - (y1 (- center-y y-radius)) (y2 (+ center-y y-radius))) + (y1 (- center-y y-radius)) (y2 (+ center-y y-radius))) (if filled - (draw-rectangle* sheet x1 y1 x2 y2) - (draw-lines* sheet (list x1 y1 x2 y1 x1 y2 x2 y2))) + ;; Kludge coordinates, sometimes due to rounding the lines don't connect. + (draw-rectangle* sheet (floor x1) y1 (ceiling x2) y2) + (draw-lines* sheet (list (floor x1) y1 (ceiling x2) y1 + (floor x1) y2 (ceiling x2) y2))) (draw-circle* sheet x1 center-y y-radius :filled filled :start-angle (* pi 0.5) @@ -1023,3 +1025,72 @@ :ink (transform-region (make-translation-transformation x y) pattern)))))) + +(defun draw-rounded-rectangle* (sheet x1 y1 x2 y2 + &rest args &key + (radius 7) + (radius-x radius) + (radius-y radius) + (radius-left radius-x) + (radius-right radius-x) + (radius-top radius-y) + (radius-bottom radius-y) + filled &allow-other-keys) + "Draw a rectangle with rounded corners" + + (apply #'invoke-with-drawing-options sheet + (lambda (medium) + (declare (ignore medium)) + (let ((medium sheet)) + (if (not (and (>= (- x2 x1) (* 2 radius-x)) + (>= (- y2 y1) (* 2 radius-y)))) + (draw-rectangle* medium x1 y1 x2 y2) + (with-grown-rectangle* ((ix1 iy1 ix2 iy2) (x1 y1 x2 y2) + :radius-left (- radius-left) + :radius-right (- radius-right) + :radius-top (- radius-top) + :radius-bottom (- radius-bottom)) + (let ((zl (zerop radius-left)) + (zr (zerop radius-right)) + (zt (zerop radius-top)) + (zb (zerop radius-bottom))) + (if filled + (progn ; Filled + (unless (or zl zt) + (draw-ellipse* medium ix1 iy1 radius-left 0 0 radius-top :filled t)) + (unless (or zr zt) + (draw-ellipse* medium ix2 iy1 radius-right 0 0 radius-top :filled t)) + (unless (or zl zb) + (draw-ellipse* medium ix1 iy2 radius-left 0 0 radius-bottom :filled t)) + (unless (or zr zb) + (draw-ellipse* medium ix2 iy2 radius-right 0 0 radius-bottom :filled t)) + (draw-rectangle* medium x1 iy1 x2 iy2 :filled t) + (draw-rectangle* medium ix1 y1 ix2 iy1 :filled t) + (draw-rectangle* medium ix1 iy2 ix2 y2 :filled t)) + (progn ; Unfilled + (unless (or zl zt) + (draw-ellipse* medium ix1 iy1 (- radius-left) 0 0 (- radius-top) + :start-angle (/ pi 2) :end-angle pi + :filled nil)) + (unless (or zr zt) + (draw-ellipse* medium ix2 iy1 (- radius-right) 0 0 (- radius-top) + :start-angle 0 :end-angle (/ pi 2) + :filled nil)) + (unless (or zl zb) + (draw-ellipse* medium ix1 iy2 (- radius-left) 0 0 (- radius-bottom) + :start-angle pi :end-angle (* 3/2 pi) + :filled nil)) + (unless (or zr zb) + (draw-ellipse* medium ix2 iy2 (- radius-right) 0 0 (- radius-bottom) + :start-angle (* 3/2 pi) + :filled nil)) + (labels ((fx (y p x1a x2a x1b x2b) (draw-line* medium (if p x1a x1b) y (if p x2a x2b) y)) + (fy (x p y1a y2a y1b y2b) (draw-line* medium x (if p y1a y1b) x (if p y2a y2b)))) + (fx y1 zt x1 x2 ix1 ix2) + (fy x1 zl y1 y2 iy1 iy2) + (fx y2 zb x1 x2 ix1 ix2) + (fy x2 zr y1 y2 iy1 iy2))))))))) + (with-keywords-removed (args '(:radius :radius-x :radius-y + :radius-left :radius-right + :radius-top :radius-bottom)) + args))) From ahefner at common-lisp.net Mon Feb 5 03:00:57 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 22:00:57 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070205030057.6E3A77E008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5398 Modified Files: menu-choose.lisp Log Message: If we're going to stick with these rather unorthodox menus, at least wrap in a 3D border to make them less jarring. Changed color to use the default 3D gadget background, and made less sensitive to the exact hierarchy of gadgets in the menu frame. --- /project/mcclim/cvsroot/mcclim/menu-choose.lisp 2006/08/05 19:54:31 1.19 +++ /project/mcclim/cvsroot/mcclim/menu-choose.lisp 2007/02/05 03:00:54 1.20 @@ -180,15 +180,16 @@ (fm (frame-manager associated-frame))) (with-look-and-feel-realization (fm associated-frame) ; hmm... checkme (let* ((menu-stream (make-pane-1 fm associated-frame 'clim-stream-pane - :background +gray80+)) + :background *3d-normal-color* #+NIL +gray80+)) (container (scrolling (:scroll-bar scroll-bars) menu-stream)) - (frame (make-menu-frame (if label - (labelling (:label label - :label-alignment :top - :background +gray80+) - container) - container) + (frame (make-menu-frame (raising () + (if label + (labelling (:label label + :name 'label + :label-alignment :top) + container) + container)) :left nil :top nil))) (adopt-frame fm frame) @@ -316,12 +317,11 @@ :resize-frame t))) ;; Modify the size and location of the frame as well. - (let* ((label-pane (sheet-parent (pane-scroller menu))) - (top-level-pane (sheet-parent label-pane))) - (when (not (typep label-pane 'label-pane)) - ;; Oops, we have no label. Rebind... - (setf top-level-pane label-pane) - (setf label-pane nil)) + (let* ((top-level-pane (labels ((searching (pane) + (if (typep pane 'top-level-sheet-pane) + pane + (searching (sheet-parent pane))))) + (searching menu)))) (multiple-value-bind (frame-width frame-height) (menu-size top-level-pane *application-frame*) (multiple-value-bind (res-max-x res-max-y) (max-x-y *application-frame*) From ahefner at common-lisp.net Mon Feb 5 03:02:59 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 22:02:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070205030259.5DE5A47081@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7169 Modified Files: panes.lisp Log Message: For mouse wheel scrolling, search upward through the pane hierarchy for a viewport to scroll. This fixes mouse wheel scrolling in Clouseau. Assorted other minor changes. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2007/01/23 07:51:10 1.178 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2007/02/05 03:02:59 1.179 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.178 2007/01/23 07:51:10 ahefner Exp $ +;;; $Id: panes.lisp,v 1.179 2007/02/05 03:02:59 ahefner Exp $ (in-package :clim-internals) @@ -496,7 +496,7 @@ ((:bottom) (+ y (- height child-height))) ((:expand) y) ))) ;; Actually layout the child - (move-sheet child child-x child-y) + (move-sheet child child-x child-y) (resize-sheet child child-width child-height) (allocate-space child child-width child-height))) @@ -720,8 +720,8 @@ ;; call change-space-requirements on parent pane ;; call note-space-requirements-changed ;; -;; This is splitted into :before, primary and :after method to allow -;; for easy overriding of change-space-requirements without needing to +;; This is split into :before, primary and :after method to allow for +;; easy overriding of change-space-requirements without needing to ;; know the details of the space requirement cache and the ;; note-space-requirements-changed notifications. ;; @@ -1197,10 +1197,10 @@ (wanted (reduce #'+ allot)) (excess (- major wanted (* (1- (length children)) major-spacing)))) - (when *dump-allocate-space* - (format *trace-output* "~&;; ~S ~S~%" - 'box-layout-mixin/xically-allocate-space-aux* box) - (format *trace-output* "~&;; major = ~D, wanted = ~D, excess = ~D, allot = ~D.~%" + (when *dump-allocate-space* + (format *trace-output* "~&;; ~S ~S~%" + 'box-layout-mixin/xically-allocate-space-aux* box) + (format *trace-output* "~&;; major = ~D, wanted = ~D, excess = ~D, allot = ~D.~%" major wanted excess allot)) (let ((qvector @@ -1731,11 +1731,12 @@ (defmethod allocate-space ((pane spacing-pane) width height) (with-slots (border-width) pane - (let ((child (first (sheet-children pane)))) + (let ((child (first (sheet-children pane))) + (new-width (- width border-width border-width)) + (new-height (- height border-width border-width))) (layout-child child (pane-align-x pane) (pane-align-y pane) border-width border-width - (- width border-width border-width) - (- height border-width border-width))))) + new-width new-height)))) ;;; OUTLINED PANE @@ -2167,17 +2168,15 @@ ;;;; Accounting for changed space requirements (defmethod change-space-requirements ((pane clim-extensions:viewport-pane) &rest ignore) - (declare (ignore ignore)) - (let ((client (first (sheet-children pane)))) - (resize-sheet client (max (bounding-rectangle-width pane) - (space-requirement-width (compose-space client))) - (max (bounding-rectangle-height pane) - (space-requirement-height (compose-space client)))) - (allocate-space client - (max (bounding-rectangle-width pane) - (space-requirement-width (compose-space client))) - (max (bounding-rectangle-height pane) - (space-requirement-height (compose-space client)))) + (declare (ignore ignore)) + (let* ((client (first (sheet-children pane))) + (sr (compose-space client)) + (width (max (bounding-rectangle-width pane) + (space-requirement-width sr))) + (height (max (bounding-rectangle-height pane) + (space-requirement-height sr)))) + (resize-sheet client width height) + (allocate-space client width height) (scroller-pane/update-scroll-bars (sheet-parent pane)))) ;;;; @@ -2381,25 +2380,37 @@ (:documentation "Returns the number of pixels respresenting a 'line', used to computed distance to scroll in response to mouse wheel events.")) -(defmethod scroll-quantum (pane) 10) +(defmethod scroll-quantum (pane) 10) ; TODO: Connect this with the scroller-pane motion + +(defun find-viewport-for-scroll (pane) + "Find a viewport in the chain of parents which contains 'pane', + returning this viewport and the sheet immediately contained within." + (cond ((not (typep pane 'basic-pane)) + (values nil nil)) + ((pane-viewport pane) (values (pane-viewport pane) pane)) + (t (find-viewport-for-scroll (sheet-parent pane))))) (defun scroll-sheet (sheet vertical horizontal) - (with-bounding-rectangle* (vx0 vy0 vx1 vy1) (pane-viewport-region sheet) - (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region sheet) - (let ((viewport-height (- vy1 vy0)) - (viewport-width (- vx1 vx0)) - (delta (* *mouse-scroll-distance* - (scroll-quantum sheet)))) - ;; The coordinates (x,y) of the new upper-left corner of the viewport - ;; must be "sx0 < x < sx1 - viewport-width" and - ;; "sy0 < y < sy1 - viewport-height" - (scroll-extent sheet - (max sx0 (min (- sx1 viewport-width) (+ vx0 (* delta horizontal)))) - (max sy0 (min (- sy1 viewport-height) (+ vy0 (* delta vertical))))))))) + (multiple-value-bind (viewport sheet) + (find-viewport-for-scroll sheet) + (declare (ignore viewport)) + (with-bounding-rectangle* (vx0 vy0 vx1 vy1) (pane-viewport-region sheet) + (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region sheet) + (let ((viewport-height (- vy1 vy0)) + (viewport-width (- vx1 vx0)) + (delta (* *mouse-scroll-distance* + (scroll-quantum sheet)))) + ;; The coordinates (x,y) of the new upper-left corner of the viewport + ;; must be "sx0 < x < sx1 - viewport-width" and + ;; "sy0 < y < sy1 - viewport-height" + (scroll-extent sheet + (max sx0 (min (- sx1 viewport-width) (+ vx0 (* delta horizontal)))) + (max sy0 (min (- sy1 viewport-height) (+ vy0 (* delta vertical)))))))))) +;; Note that handling this from dispatch-event is evil, and we shouldn't. (defmethod dispatch-event :around ((sheet mouse-wheel-scroll-mixin) (event pointer-button-press-event)) - (if (pane-viewport sheet) + (if (find-viewport-for-scroll sheet) (let ((button (pointer-event-button event))) (cond ((eq button +pointer-wheel-up+) (scroll-sheet sheet -1 0)) @@ -2862,5 +2873,6 @@ ; timer-event convenience (defmethod schedule-timer-event ((pane pane) token delay) + (warn "Are you sure you want to use schedule-timer-event? It probably doesn't work.") (schedule-event pane (make-instance 'timer-event :token token :sheet pane) delay)) From ahefner at common-lisp.net Mon Feb 5 03:06:14 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 22:06:14 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070205030614.CA39B5200A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7304 Modified Files: recording.lisp presentation-defs.lisp Log Message: Introduce a new function, highlight-output-record-tree, so that records can control how highlighting recurses into their children. Revise definition of null output records to include any record whose upper-left and lower-right coordinates are equal. This is necessary when an empty record is transformed (such as by with-room-for-graphics). --- /project/mcclim/cvsroot/mcclim/recording.lisp 2006/11/22 06:26:48 1.129 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2007/02/05 03:06:14 1.130 @@ -504,13 +504,26 @@ (multiple-value-bind (x1 y1 x2 y2) (output-record-hit-detection-rectangle* record) (ecase state - (:highlight + (:highlight (draw-rectangle* (sheet-medium stream) x1 y1 (1- x2) (1- y2) :filled nil :ink +foreground-ink+)) ; XXX +FLIPPING-INK+? (:unhighlight ;; FIXME: repaint the hit detection rectangle. It could be bigger than - ;;; the bounding rectangle. - (repaint-sheet stream record)))))) + ;; the bounding rectangle. + (repaint-sheet stream record) + + ;; Using queue-repaint should be faster in apps (such as clouseau) that + ;; highlight/unhighlight many bounding rectangles at once. The event + ;; code should merge these into a single larger repaint. Unfortunately, + ;; since an enqueued repaint does not occur immediately, and highlight + ;; rectangles are not recorded, newer highlighting gets wiped out + ;; shortly after being drawn. So, we aren't ready for this yet. + #+NIL + (queue-repaint stream (make-instance 'window-repaint-event + :sheet stream + :region (transform-region + (sheet-native-transformation stream) + record)))))))) ;;; XXX Should this only be defined on recording streams? (defmethod highlight-output-record ((record output-record) stream state) @@ -676,8 +689,8 @@ ;;; not affect bounding rectangles. -- Hefner (defun null-bounding-rectangle-p (bbox) (with-bounding-rectangle* (x1 y1 x2 y2) bbox - (and (zerop x1) (zerop y1) - (zerop x2) (zerop y2)))) + (and (= x1 x2) + (= y1 y2)))) ;;; 16.2.3. Output Record Change Notification Protocol (defmethod recompute-extent-for-new-child @@ -770,7 +783,7 @@ ;; If record is currently empty, use the child's bbox directly. Else.. ;; Does the new rectangle of the child contain the original rectangle? ;; If so, we can use min/max to grow record's current rectangle. - ;; If not, the child has shrunk, and we need to fully recompute. + ;; If not, the child has shrunk, and we need to fully recompute. (multiple-value-bind (nx1 ny1 nx2 ny2) (cond ;; The child has been deleted; who knows what the --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/01/14 19:59:07 1.69 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/02/05 03:06:14 1.70 @@ -1206,21 +1206,28 @@ stream state))) +(defgeneric highlight-output-record-tree (record stream state)) + +(defmethod highlight-output-record-tree (record stream state) + (declare (ignore record stream state)) + (values)) + +(defmethod highlight-output-record-tree ((record compound-output-record) stream state) + (map-over-output-records + (lambda (record) + (highlight-output-record-tree record stream state)) + record)) + +(defmethod highlight-output-record-tree ((record displayed-output-record) stream state) + (highlight-output-record record stream state)) + (define-default-presentation-method highlight-presentation (type record stream state) (declare (ignore type)) (if (or (eq (presentation-single-box record) t) (eq (presentation-single-box record) :highlighting)) - (highlight-output-record-rectangle record stream state) - (labels ((highlighter (record) - (typecase record - (displayed-output-record - (highlight-output-record record stream state)) - (compound-output-record - (map-over-output-records #'highlighter record)) - (t nil)))) - (highlighter record)))) - + (highlight-output-record record stream state) + (highlight-output-record-tree record stream state))) (define-default-presentation-method present (object type stream (view textual-view) &key acceptably for-context-type) From ahefner at common-lisp.net Mon Feb 5 03:07:22 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 22:07:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070205030722.936685600E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7529 Modified Files: regions.lisp Log Message: Added internal helper, with-grown-rectangle*. --- /project/mcclim/cvsroot/mcclim/regions.lisp 2006/05/05 10:24:02 1.33 +++ /project/mcclim/cvsroot/mcclim/regions.lisp 2007/02/05 03:07:22 1.34 @@ -4,7 +4,7 @@ ;;; Created: 1998-12-02 19:26 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). -;;; $Id: regions.lisp,v 1.33 2006/05/05 10:24:02 crhodes Exp $ +;;; $Id: regions.lisp,v 1.34 2007/02/05 03:07:22 ahefner Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2001 by Gilbert Baumann ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet at emi.u-bordeaux.fr) @@ -2378,3 +2378,23 @@ ;; (and (<= u1 x2) (<= x1 u2) ;; (<= v1 y2) (<= y1 v2)))) ) + +;;; Internal helpers + +(defmacro with-grown-rectangle* (((out-x1 out-y1 out-x2 out-y2) + (in-x1 in-y1 in-x2 in-y2) + &key + radius + (radius-x radius) + (radius-y radius) + (radius-left radius-x) + (radius-right radius-x) + (radius-top radius-y) + (radius-bottom radius-y)) + &body body) + `(multiple-value-bind (,out-x1 ,out-y1 ,out-x2 ,out-y2) + (values (- ,in-x1 ,radius-left) + (- ,in-y1 ,radius-top) + (+ ,in-x2 ,radius-right) + (+ ,in-y2 ,radius-bottom)) + , at body)) From ahefner at common-lisp.net Mon Feb 5 03:16:55 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 22:16:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070205031655.2F7615F01E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7623 Modified Files: bordered-output.lisp package.lisp Log Message: Mostly rewrote bordered output. Introduced new border types :rounded and :ellipse, and introduced various new keywords (:filled, :background, :outline-ink, :shadow, :shadow-offset, :line-*, :padding-*, etc, to be documented). Introduced generic functions make-bordered-output-record, draw-output-border-under, draw-output-border-over to provide a CLOS-style underpinning for the define-border-type macro. This also means you can implement anonymous border styles via any object having applicable methods for these functions. Filled borders should respond to presentation highlighting if a :highlight keyword provides an alternate background ink to use while highlighted. Export aforementioned new border functions, draw-rounded-rectangle*, the bordered-output-record class, and the highlight-output-record-tree function via clim-externals. --- /project/mcclim/cvsroot/mcclim/bordered-output.lisp 2006/03/29 10:43:36 1.14 +++ /project/mcclim/cvsroot/mcclim/bordered-output.lisp 2007/02/05 03:16:55 1.15 @@ -1,6 +1,7 @@ -;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- +;;; -*- Mode: lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2002 by Alexey Dejneka (adejneka at comail.ru) +;;; (c) copyright 2007 by Andy Hefner (ahefner at gmail.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either @@ -17,16 +18,76 @@ ;;; Boston, MA 02111-1307 USA. ;;; TODO: -;;; - Use DRAWING-OPTIONS, MOVE-CURSOR in I-S-O-W-B -;;; - Gap computation +;;; - Define a protocol which the graph formatter can utilize to determine +;;; where graph edges should be connected to shaped output borders. + +;;; - ** Double check default value and intent of move-cursor argument. +;;; If I understand things right, move-cursor t for underlining is usually +;;; the wrong thing. + +;;; FIXME: +;;; - Various functions which try to accomodate line-thickness do not +;;; attempt to consider possibility of a line-style argument. +;;; - In a perfect world we could make the default shadow ink a tranlucent +;;; ink, but the CLX backend isn't there yet. A stopgap measure could +;;; simply blend against the pane-background. +;;; - Using padding to control the rounded rectangles might be the wrong thing. + +;;; ??? +;;; - Would it make more sense to draw borders as part of replay (with recording +;;; off, like a displayed record), and letting them effortlessly accomodate +;;; changes in the bounding rectangle of the contents? This would only benefit +;;; people doing unusual things with output records. How would be determine +;;; bounds of the border? (in-package :clim-internals) -(defvar *border-types* (make-hash-table)) +(defclass bordered-output-record (standard-sequence-output-record) + (under record over)) + +(defgeneric make-bordered-output-record (stream shape record &key + &allow-other-keys) + (:documentation "Instantiates an output record of a class appropriate for the + specified shape containing the given output record, and renders any decorations + associated with the shape.")) + +(defgeneric draw-output-border-under + (shape stream record &rest drawing-options &key &allow-other-keys) + (:documentation + "Draws the portion of border shape which is visible underneath the surrounded + output")) + +(defgeneric draw-output-border-over + (shape stream record &rest drawing-options &key &allow-other-keys) + (:documentation + "Draws the portion of border shape which is visible above the surrounded + output")) + +;; Keep this around just for fun, so we can list the defined border types. +(defvar *border-types* nil) + +(defparameter *border-default-padding* 4) +(defparameter *border-default-radius* 7) +(defparameter *drop-shadow-default-offset* 6) + +;; Defining the border edges directly by the edges of the surrounded output +;; record is wrong in the 'null bounding rectangle' case, occuring when the +;; record has no chidren, or no children with non-null bounding rectangles. +;; Intuitively, the empty border should remain centered on the cursor. +(defmacro with-border-edges ((stream record) &body body) + `(if (null-bounding-rectangle-p ,record) + (multiple-value-bind (left top) (stream-cursor-position ,stream) + (let ((right (1+ left)) + (bottom (1+ top))) + , at body)) + (with-bounding-rectangle* (left top right bottom) ,record + , at body))) (defmacro surrounding-output-with-border ((&optional stream - &rest drawing-options - &key (shape :rectangle) (move-cursor t)) + &rest drawing-options &key + (shape :rectangle) + (move-cursor t) + &allow-other-keys) &body body) (declare (ignore shape move-cursor)) (setf stream (stream-designator-symbol stream '*standard-output*)) @@ -35,102 +96,622 @@ drawing-options body)) +(defun %prepare-bordered-output-record + (stream shape border inner-record drawing-options) + (with-sheet-medium (medium stream) + (macrolet ((capture (&body body) + `(multiple-value-bind (cx cy) (stream-cursor-position stream) + (with-output-to-output-record (stream) + (setf (stream-cursor-position stream) (values cx cy)) + , at body)))) + (let* ((border-under + (with-identity-transformation (medium) + (capture + (apply #'draw-output-border-under + shape stream inner-record drawing-options)))) + (border-over + (with-identity-transformation (medium) + (capture + (apply #'draw-output-border-over + shape stream inner-record drawing-options))))) + (with-slots (under record over) border + (setf under border-under + record inner-record + over border-over) + (add-output-record under border) + (add-output-record record border) + (add-output-record over border)) + border)))) + +(defmethod make-bordered-output-record (stream shape inner-record + &rest drawing-options) + (%prepare-bordered-output-record stream shape + (make-instance 'bordered-output-record) + inner-record drawing-options)) + +;; This should have been exported by the CLIM package, otherwise you can't +;; apply a computed list of drawing options. (defun invoke-surrounding-output-with-border (stream cont &rest drawing-options &key (shape :rectangle) - (move-cursor t)) - (with-sheet-medium (medium stream) - (let ((bbox-record - (with-new-output-record (stream) - (let ((record (with-new-output-record (stream) - (funcall cont stream)))) - (with-bounding-rectangle* (left top right bottom) record - (with-identity-transformation (medium) - (with-keywords-removed - (drawing-options (:shape :move-cursor)) - (apply (or (gethash shape *border-types*) - (error "Border shape ~S not defined." shape)) - :stream stream - :record record - :left left :top top - :right right :bottom bottom - :allow-other-keys t - drawing-options)))))))) - (when move-cursor - (with-bounding-rectangle* (left top right bottom) bbox-record - (declare (ignore left top)) - (setf (stream-cursor-position stream) (values right bottom)))) - bbox-record))) - + (move-cursor t) + &allow-other-keys) + (with-keywords-removed (drawing-options (:shape :move-cursor)) + (multiple-value-bind (cx cy) (stream-cursor-position stream) + (let ((border (apply #'make-bordered-output-record + stream + shape + (with-output-to-output-record (stream) + ;; w-o-t-o-r moved the cursor to the origin. + (setf (stream-cursor-position stream) + (values cx cy)) + (funcall cont stream) + (setf (values cx cy) + (stream-cursor-position stream))) + drawing-options))) + + (stream-add-output-record stream border) + + (when (stream-drawing-p stream) + (with-output-recording-options (stream :record nil) + (replay border stream))) + + (if move-cursor + ;; move-cursor is true, move cursor to lower-right corner of output. + (with-bounding-rectangle* (left top right bottom) border + (declare (ignore left top)) + (setf (stream-cursor-position stream) (values right bottom))) + ;; move-cursor is false, preserve the cursor position from after + ;; the output (I think this is right, it's useful for :underline) + (setf (stream-cursor-position stream) (values cx cy))) + border)))) + +(defmethod draw-output-border-under + (shape stream record &rest drawing-options &key &allow-other-keys) + (declare (ignore drawing-options)) + (values)) + +(defmacro %%line-style-for-method () + `(or line-style + (merge-line-styles + (make-line-style + :unit line-unit + :thickness line-thickness + :cap-shape line-cap-shape + :dashes line-dashes) + (medium-line-style stream)))) + +(defmacro %%adjusting-for-padding (&body body) + `(let ((left (- left padding-left)) + (right (+ right padding-right)) + (top (- top padding-top)) + (bottom (+ bottom padding-bottom))) + , at body)) + +(defmacro %%adjusting-padding-for-line-style (&body body) + `(let ((padding-left (+ padding-left (/ (or line-thickness 0) 2))) + (padding-right (+ padding-right (/ (or line-thickness 0) 2))) + (padding-top (+ padding-top (/ (or line-thickness 0) 2))) + (padding-bottom (+ padding-bottom (/ (or line-thickness 0) 2)))) + , at body)) + + (defmacro define-border-type (shape arglist &body body) (check-type arglist list) - (loop for arg in arglist - do (check-type arg symbol)) ;; The Franz User guide implies that &key isn't needed. (pushnew '&key arglist) - `(setf (gethash ,shape *border-types*) - (lambda ,arglist , at body))) - + `(progn + (pushnew ,shape *border-types*) + (defmethod draw-output-border-over ((shape (eql ',shape)) stream record + &rest drawing-options) + (with-border-edges (stream record) + (apply (lambda (, at arglist &allow-other-keys) + , at body) + :stream stream + :record record + :left left + :right right + :top top + :bottom bottom + drawing-options))))) + ;;;; Standard border types -(define-border-type :rectangle (stream left top right bottom) - (let ((gap 3)) ; FIXME - (draw-rectangle* stream - (- left gap) (- top gap) - (+ right gap) (+ bottom gap) - :filled nil))) - -(define-border-type :oval (stream left top right bottom) - (let ((gap 3)) ; FIXME - (draw-oval* stream - (/ (+ left right) 2) (/ (+ top bottom) 2) - (+ (/ (- right left) 2) gap) (+ (/ (- bottom top) 2) gap) - :filled nil))) - -(define-border-type :drop-shadow (stream left top right bottom) - (let* ((gap 3) ; FIXME? - (offset 3) - (left-edge (- left gap)) - (bottom-edge (+ bottom gap)) - (top-edge (- top gap)) - (right-edge (+ right gap))) - (draw-rectangle* stream - left-edge top-edge - right-edge bottom-edge - :filled nil) - (draw-rectangle* stream - right-edge (+ top-edge offset) - (+ right-edge offset) bottom-edge :filled t) - (draw-rectangle* stream - (+ left-edge offset) bottom-edge - (+ right-edge offset) (+ bottom-edge offset) - :filled t))) - -(define-border-type :underline (stream record) - (labels ((fn (record) - (loop for child across (output-record-children record) do - (typecase child - (text-displayed-output-record - (with-bounding-rectangle* (left top right bottom) child - (declare (ignore top)) - (draw-line* stream left bottom right bottom))) - (updating-output-record nil) - (compound-output-record (fn child)))))) - (fn record))) - -(define-border-type :inset (stream left top right bottom) - (let* ((gap 3) - (left-edge (- left gap)) - (bottom-edge (+ bottom gap)) - (top-edge (- top gap)) - (right-edge (+ right gap)) - (dark *3d-dark-color*) - (light *3d-light-color*)) - (flet ((draw (left-edge right-edge bottom-edge top-edge light dark) - (draw-line* stream left-edge bottom-edge left-edge top-edge :ink dark) - (draw-line* stream left-edge top-edge right-edge top-edge :ink dark) - (draw-line* stream right-edge bottom-edge right-edge top-edge :ink light) - (draw-line* stream left-edge bottom-edge right-edge bottom-edge :ink light))) - (draw left-edge right-edge bottom-edge top-edge light dark) - (draw (1+ left-edge) (1- right-edge) (1- bottom-edge) (1+ top-edge) light dark)))) +(define-border-type :rectangle (stream left top right bottom + ink outline-ink filled + (padding *border-default-padding*) + (padding-x padding) + (padding-y padding) + (padding-left padding-x) + (padding-right padding-x) + (padding-top padding-y) + (padding-bottom padding-y) + line-style + line-unit + line-thickness + line-cap-shape + line-dashes) + (%%adjusting-padding-for-line-style + (%%adjusting-for-padding + (let ((ink (or outline-ink + (and (not filled) + (or ink (medium-ink stream)))))) + (when ink + (draw-rectangle* stream + left top right bottom + :line-style (%%line-style-for-method) + :ink ink + :filled nil)))))) + +(defmethod draw-output-border-under + ((shape (eql :rectangle)) stream record + &key background ink filled + (padding *border-default-padding*) + (padding-x padding) + (padding-y padding) + (padding-left padding-x) + (padding-right padding-x) + (padding-top padding-y) + (padding-bottom padding-y) + shadow + (shadow-offset *drop-shadow-default-offset*) + line-thickness + &allow-other-keys) + + (when (or background filled) + (with-border-edges (stream record) + (%%adjusting-padding-for-line-style + (%%adjusting-for-padding + (when (and shadow shadow-offset) + (draw-rectangle* stream + (+ shadow-offset left) + (+ shadow-offset top) + (+ shadow-offset right) + (+ shadow-offset bottom) + :ink shadow + :filled t)) + (draw-rectangle* stream + left top + right bottom + :ink (or background ink +background-ink+) + :filled t)))))) + +(define-border-type :oval (stream left top right bottom + (ink (medium-ink stream)) + outline-ink + + (padding *border-default-padding*) + (padding-x padding) + (padding-y padding) + (padding-left padding-x) + (padding-right padding-x) + (padding-top padding-y) + (padding-bottom padding-y) + + line-style + line-unit + line-thickness + line-cap-shape + line-dashes) + (%%adjusting-padding-for-line-style + (%%adjusting-for-padding + (when ink + (draw-oval* stream + (/ (+ left right) 2) (/ (+ top bottom) 2) + (/ (- right left) 2) (/ (- bottom top) 2) + :line-style (%%line-style-for-method) + :ink (or outline-ink ink) + :filled nil))))) + +(defmethod draw-output-border-under + ((shape (eql :oval)) stream record &key + background ink filled line-thickness + (shadow-offset *drop-shadow-default-offset*) + shadow + (padding *border-default-padding*) [405 lines skipped] --- /project/mcclim/cvsroot/mcclim/package.lisp 2007/02/04 12:55:43 1.60 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2007/02/05 03:16:55 1.61 @@ -1923,6 +1923,16 @@ #:pointer-motion-hint-event #:frame-display-pointer-documentation-string #:list-pane-items + + #:draw-output-border-over + #:draw-output-border-under + #:make-bordered-output-record + #:bordered-output-record + + #:draw-rounded-rectangle* + + #:highlight-output-record-tree + ;; Font listing extension: #:font-family #:font-face From ahefner at common-lisp.net Mon Feb 5 03:25:09 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 22:25:09 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20070205032509.CBC2467096@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv9839 Added Files: bordered-output-examples.lisp Log Message: Examples/tests of bordered output. --- /project/mcclim/cvsroot/mcclim/Examples/bordered-output-examples.lisp 2007/02/05 03:25:09 NONE +++ /project/mcclim/cvsroot/mcclim/Examples/bordered-output-examples.lisp 2007/02/05 03:25:09 1.1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-DEMO; -*- ;;; Test surrounding-output-with-border with various shapes and keywords. ;;; (c) Copyright 2007 by Andy Hefner (ahefner at gmail.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (define-presentation-type border-style ()) (define-application-frame bordered-output () ((shapes :initform (append (reverse climi::*border-types*) (list (list :rectangle :ink +gray80+ :padding 0 :padding-left 24 :line-thickness 4) (list :rectangle :ink +gray50+ :line-dashes t) (list :oval :ink +white+ :highlight-background +white+ :line-thickness 3) (list :oval :line-dashes t) (list :oval :ink nil :background +white+) (list :underline :ink +red+ :line-thickness 2) (list :underline :ink +red+ :line-dashes t) (list :rectangle :ink +gray50+ :background +white+ :filled t) (list :oval :ink +gray60+ :background +gray85+ :filled t) (list :oval :ink (make-ihs-color 0.8 1.0 0.5) :line-thickness 3 :background (make-ihs-color 1.0 0.0 0.5) ;; FIXME, breaks on ovals. =( ;:highlight-background (make-ihs-color 1.5 0.0 0.5) :shadow-offset 8 :shadow +gray80+ :filled t) (list :drop-shadow :ink +black+ :padding 10 :padding-left 20 :background +gray70+ :shadow +gray80+ :shadow-offset 8 :filled t) (list :rectangle :shadow +grey80+ :background +white+) (list :rounded :padding-x 27 :padding-top 17 :padding-bottom 27) (list :rounded :line-dashes t) (list :rounded :padding 13 :line-thickness 2 :ink +gray70+) (list :rounded :padding 13 :line-thickness 2 :shadow +gray80+ :background +white+ :ink +red+) (list :ellipse :line-dashes t :circle t) (list :ellipse :line-thickness 2 :outline-ink +red+ :background +white+) (list :ellipse :shadow +gray80+ :outline-ink +gray60+ :background +white+) ;; These are just my tests that the literal corner cases of draw-rounded-rectangle* ;; work correctly. (list :rounded :highlight-background +yellow+ :radius 27 :radius-top 0 :outline-ink +red+ :background +white+ :shadow +gray80+) (list :rounded :highlight-background +yellow+ :radius 27 :radius-left 0 :outline-ink +red+ :background +white+ :shadow +gray80+) (list :rounded :highlight-background +yellow+ :radius 27 :radius-right 0 :outline-ink +red+ :background +white+ :shadow +gray80+) (list :rounded :highlight-background +yellow+ :radius 27 :radius-bottom 0 :outline-ink +red+ :background +white+ :shadow +gray80+) (list :rounded :highlight-background +yellow+ :radius 27 :radius-y 0 :outline-ink +red+ :background +white+ :shadow +gray80+) (list :rounded :highlight-background +yellow+ :radius 27 :radius-x 0 :outline-ink +red+ :background +white+ :shadow +gray80+) (list :rounded :highlight-background +yellow+ :radius 27 :radius-right 0 :radius-top 0 :outline-ink +red+ :background +white+ :shadow +gray80+) (list :rounded :highlight-background +yellow+ :radius 27 :radius-bottom 0 :radius-left 0 :outline-ink +red+ :background +white+ :shadow +gray80+))) :reader shapes-of)) (:pane (scrolling (:width 600 :height 700) (make-pane :application-pane :end-of-line-action :allow :end-of-page-action :allow ; Why isn't this working? :background +gray90+ :name :border-examples :display-function (lambda (frame stream) (format-items (shapes-of frame) :stream stream :presentation-type 'border-style :cell-align-x :center :cell-align-y :center :y-spacing 16 :x-spacing 16 :printer (lambda (shape stream) (let ((shape-name-style (make-text-style :sans-serif :bold :normal)) (keywords-style (make-text-style :sans-serif :roman :small))) (flet ((show (stream) (with-text-style (stream shape-name-style) (if (listp shape) (progn (format stream "~A" (first shape)) (with-text-style (stream keywords-style) (format stream "~{~% ~W ~W~}" (rest shape)))) (princ shape stream))))) (if (listp shape) (apply #'climi::invoke-surrounding-output-with-border stream #'show (cons :shape shape)) (surrounding-output-with-border (stream :shape shape) (show stream))))))) (terpri stream)))))) ;;; Define a dummy command, just to get highlighting of the border styles. (define-bordered-output-command (com-do-nothing) ((style 'border-style :gesture :select)) (declare (ignore style)) #+NIL (clouseau:inspector (stream-output-history *standard-output*))) From ahefner at common-lisp.net Mon Feb 5 03:26:10 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 22:26:10 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20070205032610.86A5B68003@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv9975 Added Files: misc-tests.lisp Log Message: Miscellaneous graphical tests. Note that the test "Empty Records 3" is currently broken. =) --- /project/mcclim/cvsroot/mcclim/Examples/misc-tests.lisp 2007/02/05 03:26:10 NONE +++ /project/mcclim/cvsroot/mcclim/Examples/misc-tests.lisp 2007/02/05 03:26:10 1.1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-DEMO; -*- ;;; Random McCLIM tests. ;;; Have some subtle stream/graphics/recording behavior which you'd ;;; like to ensure continues to work? Add a test for it here! ;;; (C) Copyright 2006 by Andy Hefner (ahefner at gmail.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (defstruct misc-test-item name drawer description) (define-application-frame misc-tests () () (:panes (output :application-pane) (description :application-pane) (selector :list-pane :mode :exclusive :name-key #'misc-test-item-name :items (list (make-misc-test-item :name "Empty Records 1" :drawer 'misc-empty-records-1 :description "Tests the effect of empty output records on their parent's bounding rectangle. If successful, you will see a circle enclosed in a square. The square should tightly fit the circle. If the rectangle extends all the way to the top/left edges of the pane, McCLIM is not handling this correctly. This specifically exercises addition of empty children in recompute-extent-for-new-child.") (make-misc-test-item :name "Empty Records 2" :drawer 'misc-empty-records-2 :description "Tests the effect of empty output records on their parent's bounding rectangle. If successful, you will see a circle enclosed in a square. The square should tightly fit the circle. If the rectangle extends all the way to the top/left edges of the pane, McCLIM is not handling this correctly. This specifically tests addition and deletion of an empty child, and failure may point to recompute-extent-for-new-child or recompute-extent-for-changed-child.") (make-misc-test-item :name "Empty Records 3" :drawer 'misc-empty-records-3 :description "Tests the effect of empty output records on their parent's bounding rectangle. If successful, you will see a circle enclosed in a square. The square should tightly fit the circle. If the rectangle extends all the way to the top/left edges of the pane, McCLIM is not handling this correctly. This test creates a new output record, fills it with content, then clears the record contents.") (make-misc-test-item :name "Empty Borders" :drawer 'misc-empty-bordering :description "Tests handling of empty output records by surrounding-output-with-border. If successful, you will see twelve small circles arranged themselves in a larger circle. A likely failure mode will exhibit the circles piled on each other in the upper-left corner of the pane.") (make-misc-test-item :name "Underlining" :drawer 'misc-underlining-test :description "Tests the underlining border style. You should see five lines of text, equally spaced, with the second and third lines having the phrase 'all live' underlined, first by a thick black line then by a thin dashed red line. If the lines are broken or the spacing is irregular, the :move-cursor nil key of surrounding-output-with-border may not have behaved as expected. ")) :value-changed-callback (lambda (pane item) (declare (ignore pane)) (let ((output (get-frame-pane *application-frame* 'output)) (description (get-frame-pane *application-frame* 'description))) (window-clear output) (window-clear description) (with-text-style (description (make-text-style :sans-serif :roman :normal)) (write-string (misc-test-item-description item) description)) (funcall (misc-test-item-drawer item) output))))) (:layouts (default (spacing (:thickness 3) (horizontally () (spacing (:thickness 3) (clim-extensions:lowering () selector)) (vertically () (spacing (:thickness 3) (clim-extensions:lowering () (scrolling (:width 600 :height 600) output))) (spacing (:thickness 3) (clim-extensions:lowering () (scrolling (:scroll-bar :vertical :height 200) description))))))))) (defun misc-empty-records-1 (stream) (surrounding-output-with-border (stream :shape :rectangle) (draw-circle* stream 200 200 40) (with-new-output-record (stream)))) (defun misc-empty-records-2 (stream) (surrounding-output-with-border (stream :shape :rectangle) (draw-circle* stream 200 200 40) (let ((record (with-new-output-record (stream)))) (delete-output-record record (output-record-parent record))))) (defun misc-empty-records-3 (stream) (surrounding-output-with-border (stream :shape :rectangle) (draw-circle* stream 200 200 40) (let ((record (with-new-output-record (stream) (draw-circle* stream 50 50 10)))) (clear-output-record record)))) (defun misc-empty-bordering (stream) (with-room-for-graphics (stream :first-quadrant nil) (with-text-style (stream (make-text-style :sans-serif :roman :small)) (loop with outer-radius = 180 with inner-radius = 27 with n = 12 for i from 0 below n do (setf (stream-cursor-position stream) (values (* outer-radius (sin (* i 2 pi (/ n)))) (* outer-radius (cos (* i 2 pi (/ n)))))) (surrounding-output-with-border (stream :shape :ellipse :circle t :min-radius inner-radius :shadow +gray88+ :shadow-offset 7 :filled t :line-thickness 1 :background +gray50+ :outline-ink +gray40+) ;(multiple-value-call #'draw-point* stream (stream-cursor-position stream)) #+NIL (print i stream)))))) (defun misc-underlining-test (stream) (with-text-family (stream :sans-serif) (format stream "~&We all live in a yellow subroutine.~%") (format stream "~&We ") (surrounding-output-with-border (stream :shape :underline :line-thickness 2 :move-cursor nil) (format stream "all live")) (format stream " in a yellow subroutine.~%") (format stream "~&We ") (surrounding-output-with-border (stream :shape :underline :ink +red+ :line-dashes t :move-cursor nil) (format stream "all live")) (format stream " in a yellow subroutine.~%") (format stream "~&We all live in a yellow subroutine.~%") (format stream "~&We all live in a yellow subroutine.~%"))) From ahefner at common-lisp.net Mon Feb 5 03:26:28 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 22:26:28 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20070205032628.46A6119007@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv10052 Modified Files: demodemo.lisp Log Message: Add tests to demodemo. --- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2007/02/04 12:55:44 1.18 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2007/02/05 03:26:28 1.19 @@ -64,8 +64,7 @@ (make-demo-button "Logic Cube" 'logic-cube) (make-demo-button "Gadget Test" 'gadget-test) (make-demo-button "Drag and Drop" 'dragndrop) - (make-demo-button "Colorslider" 'colorslider) - (make-demo-button "Goatee Test" 'goatee::goatee-test) + ;(make-demo-button "Colorslider" 'colorslider) (make-demo-button "D&D Translator" 'drag-test) (make-demo-button "Draggable Graph" 'draggable-graph-demo) (make-pane 'push-button @@ -84,8 +83,12 @@ (make-demo-button "List Test" 'list-test) (make-demo-button "HBOX Test" 'hbox-test) (make-demo-button "Text Size Test" 'text-size-test) + (make-demo-button "Goatee Test" 'goatee::goatee-test) (make-demo-button "Drawing Benchmark" - 'drawing-benchmark))))))))) + 'drawing-benchmark) + (make-demo-button "Border Styles Test" 'bordered-output) + (make-demo-button "Misc. Tests" + 'misc-tests))))))))) (defun demodemo () #+nil From ahefner at common-lisp.net Mon Feb 5 03:27:14 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 22:27:14 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20070205032714.D9F2519008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv10098 Modified Files: listener.lisp Added Files: wholine.lisp Log Message: Break the wholine off into its own file. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2007/01/14 14:53:54 1.33 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2007/02/05 03:27:14 1.34 @@ -1,4 +1,3 @@ -(in-package :clim-listener) ;;; This is a lisp listener. @@ -19,104 +18,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -(define-presentation-type listener-current-package () :inherit-from 'package) - -;; Wholine Pane - -(defclass wholine-pane (application-pane) () - (:default-initargs :background +gray90+)) - -(defmethod compose-space ((pane wholine-pane) &key width height) - (declare (ignore width height)) - (let ((h (* 1.5 (text-style-height (medium-text-style pane) pane)))) ; magic padding - (make-space-requirement :height h - :min-height h - :max-height h))) - -;; When the pane is grown, we must repaint more than just the newly exposed -;; regions, because the decoration within the previous region must move. -;; Likewise, shrinking the pane requires repainting some of the interior. -(defmethod allocate-space :after ((pane wholine-pane) width height) - (repaint-sheet pane (sheet-region pane))) - -(defun print-package-name (stream) - (let ((foo (package-name *package*))) - (with-drawing-options (stream :ink +royalblue+) - (format stream "~A" (reduce (lambda (&optional (a foo) (b foo)) - (if (< (length a) (length b)) a b)) - (package-nicknames *package*)))))) - -(defun frob-pathname (pathname) - (namestring (truename pathname))) - -;; How to add repaint-time decoration underneath the contents of a -;; stream pane: Write your own handle-repaint that draws the -;; decoration then replays the recorded output, and define a -;; window-clear method which calls the next window-clear method, -;; then calls handle-repaint to redraw the decoration. - -(defmethod handle-repaint ((pane wholine-pane) region) - (declare (ignore region)) - (with-output-recording-options (pane :draw t :record nil) - (with-bounding-rectangle* (x0 y0 x1 y1) (sheet-region pane) - (climi::draw-bordered-rectangle* (sheet-medium pane) - x0 y0 x1 y1 - :style :mickey-mouse-inset) - #+NIL (draw-rectangle* (sheet-medium pane) x0 y0 x1 y1 :ink +red+)) - (replay-output-record (stream-output-history pane) pane))) - -(defmethod window-clear ((pane wholine-pane)) - (call-next-method) - (handle-repaint pane (sheet-region pane))) - -(defun generate-wholine-contents (frame pane) - (declare (ignore frame)) - (let* ((*standard-output* pane) - (username (or #+cmu (cdr (assoc :user ext:*environment-list*)) - #+scl (cdr (assoc "USER" ext:*environment-list* - :test 'string=)) - #+allegro (sys:getenv "USER") - #-(or allegro cmu scl) (getenv "USER") - "luser")) ; sorry.. - (sitename (machine-instance)) - (memusage #+(or cmu scl) (lisp::dynamic-usage) - #+sbcl (sb-kernel:dynamic-usage) - #+lispworks (getf (system:room-values) :total-allocated) - #+openmcl (+ (ccl::%usedbytes) (ccl::%freebytes)) - #+clisp (values (sys::%room)) - #-(or cmu scl sbcl lispworks openmcl clisp) 0)) - (with-text-family (t :serif) - (formatting-table (t :x-spacing '(3 :character)) - (formatting-row (t) - (macrolet ((cell ((align-x) &body body) - `(formatting-cell (t :align-x ,align-x) , at body))) - (cell (:left) (format t "~A@~A" username sitename)) - (cell (:center) - (format t "Package ") - (with-output-as-presentation (t *package* 'listener-current-package) - (print-package-name t))) - (cell (:center) - ;; CLISP gives us an error when calling - ;; `cl:probe-file' with a directory argument. - (when #+clisp (or (ignore-errors (ext:probe-directory *default-pathname-defaults*)) - (ignore-errors (probe-file *default-pathname-defaults*))) - #-clisp (probe-file *default-pathname-defaults*) - (with-output-as-presentation (t (truename *default-pathname-defaults*) 'pathname) - (format t "~A" (frob-pathname *default-pathname-defaults*)))) - (when *directory-stack* - (with-output-as-presentation (t *directory-stack* 'directory-stack) - (format t " (~D deep)" (length *directory-stack*))))) - ;; Although the CLIM spec says the item formatter should try to fill - ;; the available width, I can't get either the item or table formatters - ;; to really do so such that the memory usage appears right justified. - (cell (:center) - (when (numberp memusage) - (present memusage 'lisp-memory-usage))))))))) - -(defun display-wholine (frame pane) - (invoke-and-center-output pane - (lambda () (generate-wholine-contents frame pane)) - :horizontally nil :hpad 5)) +(in-package :clim-listener) ;;; Listener view ;;; @@ -182,15 +84,15 @@ ((system-command-reader :accessor system-command-reader :initarg :system-command-reader :initform t)) - (:panes (interactor-container - (make-clim-stream-pane - :type 'listener-interactor-pane - :name 'interactor :scroll-bars t - :default-view +listener-view+)) - (doc :pointer-documentation :default-view +listener-pointer-documentation-view+) - (wholine (make-pane 'wholine-pane - :display-function 'display-wholine :scroll-bars nil - :display-time :command-loop :end-of-line-action :allow))) + (:panes (interactor-container + (make-clim-stream-pane + :type 'listener-interactor-pane + :name 'interactor :scroll-bars t + :default-view +listener-view+)) + (doc :pointer-documentation :default-view +listener-pointer-documentation-view+) + (wholine (make-pane 'wholine-pane + :display-function 'display-wholine :scroll-bars nil + :display-time :command-loop :end-of-line-action :allow))) (:top-level (default-frame-top-level :prompt 'print-listener-prompt)) (:command-table (listener :inherit-from (application-commands lisp-commands filesystem-commands show-commands) @@ -253,12 +155,12 @@ (defun run-listener (&key (new-process nil) (width 760) (height 550) - (process-name "Listener")) - (flet ((run () - (let ((frame (make-application-frame - 'listener - :width width :height height))) - (run-frame-top-level frame)))) - (if new-process - (clim-sys:make-process #'run :name process-name) - (run)))) + (process-name "Listener")) + (let ((frame (make-application-frame 'listener + :width width + :height height))) + (flet ((run () (run-frame-top-level frame))) + (if new-process + (values (clim-sys:make-process #'run :name process-name) + frame) + (run))))) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/wholine.lisp 2007/02/05 03:27:14 NONE +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/wholine.lisp 2007/02/05 03:27:14 1.1 ;;; Listener "wholine" ;;; (C) Copyright 2003 by Andy Hefner (hefner1 at umbc.edu) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-listener) (define-presentation-type listener-current-package () :inherit-from 'package) ;; Wholine Pane (defclass wholine-pane (application-pane) () (:default-initargs :background +gray90+)) (defmethod compose-space ((pane wholine-pane) &key width height) (declare (ignore width height)) (let ((h (* 1.5 (text-style-height (medium-text-style pane) pane)))) ; magic padding (make-space-requirement :height h :min-height h :max-height h))) ;; When the pane is grown, we must repaint more than just the newly exposed ;; regions, because the decoration within the previous region must move. ;; Likewise, shrinking the pane requires repainting some of the interior. (defmethod allocate-space :after ((pane wholine-pane) width height) (repaint-sheet pane (sheet-region pane))) (defun print-package-name (stream) (let ((foo (package-name *package*))) (with-drawing-options (stream :ink +royalblue+) (format stream "~A" (reduce (lambda (&optional (a foo) (b foo)) (if (< (length a) (length b)) a b)) (package-nicknames *package*)))))) (defun frob-pathname (pathname) (namestring (truename pathname))) ;; How to add repaint-time decoration underneath the contents of a ;; stream pane: Write your own handle-repaint that draws the ;; decoration then replays the recorded output, and define a ;; window-clear method which calls the next window-clear method, ;; then calls handle-repaint to redraw the decoration. (defmethod handle-repaint ((pane wholine-pane) region) (declare (ignore region)) (with-output-recording-options (pane :draw t :record nil) (with-bounding-rectangle* (x0 y0 x1 y1) (sheet-region pane) (climi::draw-bordered-rectangle* (sheet-medium pane) x0 y0 x1 y1 :style :mickey-mouse-inset) #+NIL (draw-rectangle* (sheet-medium pane) x0 y0 x1 y1 :ink +red+)) (replay-output-record (stream-output-history pane) pane))) (defmethod window-clear ((pane wholine-pane)) (call-next-method) (handle-repaint pane (sheet-region pane))) (defun generate-wholine-contents (frame pane) (declare (ignore frame)) (let* ((*standard-output* pane) (username (or #+cmu (cdr (assoc :user ext:*environment-list*)) #+scl (cdr (assoc "USER" ext:*environment-list* :test 'string=)) #+allegro (sys:getenv "USER") #-(or allegro cmu scl) (getenv "USER") "luser")) ; sorry.. (sitename (machine-instance)) (memusage #+(or cmu scl) (lisp::dynamic-usage) #+sbcl (sb-kernel:dynamic-usage) #+lispworks (getf (system:room-values) :total-allocated) #+openmcl (+ (ccl::%usedbytes) (ccl::%freebytes)) #+clisp (values (sys::%room)) #-(or cmu scl sbcl lispworks openmcl clisp) 0)) (with-text-family (t :serif) (formatting-table (t :x-spacing '(3 :character)) (formatting-row (t) (macrolet ((cell ((align-x) &body body) `(formatting-cell (t :align-x ,align-x) , at body))) (cell (:left) (format t "~A@~A" username sitename)) (cell (:center) (format t "Package ") (with-output-as-presentation (t *package* 'listener-current-package) (print-package-name t))) (cell (:center) ;; CLISP gives us an error when calling ;; `cl:probe-file' with a directory argument. (when #+clisp (or (ignore-errors (ext:probe-directory *default-pathname-defaults*)) (ignore-errors (probe-file *default-pathname-defaults*))) #-clisp (probe-file *default-pathname-defaults*) (with-output-as-presentation (t (truename *default-pathname-defaults*) 'pathname) (format t "~A" (frob-pathname *default-pathname-defaults*)))) (when *directory-stack* (with-output-as-presentation (t *directory-stack* 'directory-stack) (format t " (~D deep)" (length *directory-stack*))))) ;; Although the CLIM spec says the item formatter should try to fill ;; the available width, I can't get either the item or table formatters ;; to really do so such that the memory usage appears right justified. (cell (:center) (when (numberp memusage) (present memusage 'lisp-memory-usage))))))))) (defun display-wholine (frame pane) (invoke-and-center-output pane (lambda () (generate-wholine-contents frame pane)) :horizontally nil :hpad 5)) From ahefner at common-lisp.net Mon Feb 5 03:28:05 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 22:28:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20070205032805.D14D319007@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv10157 Modified Files: util.lisp Log Message: Fix use of underlining to do :move-cursor nil. I think McCLIM previously interpreted this incorrectly. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2006/03/29 10:43:37 1.21 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2007/02/05 03:28:05 1.22 @@ -116,8 +116,6 @@ (merge-pathnames (parse-namestring (concatenate 'string string "/")) parent))))) -;; FIXME: SB-POSIX now has STAT, so USE IT HERE !!! - #+SBCL (defun list-directory (pathname) (directory pathname) @@ -195,11 +193,12 @@ , at body)) (defmacro bordering ((stream shape) &body body) - `(surrounding-output-with-border (,stream :shape ,shape :move-cursor nil) + `(surrounding-output-with-border (,stream :shape ,shape :move-cursor t) , at body)) (defmacro underlining ((stream) &body body) - `(bordering (,stream :underline) , at body)) + `(surrounding-output-with-border (,stream :shape :underline :move-cursor nil) + , at body)) (defun note (string &rest args) (let ((stream *query-io*)) @@ -218,7 +217,7 @@ (defun invoke-as-heading (cont &optional ink) (with-drawing-options (t :ink (or ink +royal-blue+) :text-style (make-text-style :sans-serif :bold nil)) (fresh-line) - (bordering (t :underline) + (underlining (t) (funcall cont)) (fresh-line) (vertical-gap t))) From ahefner at common-lisp.net Mon Feb 5 03:29:45 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 22:29:45 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070205032945.36E7F19007@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv10243 Modified Files: clim-listener.asd Log Message: Update listener defsystem. --- /project/mcclim/cvsroot/mcclim/clim-listener.asd 2007/01/18 15:01:11 1.1 +++ /project/mcclim/cvsroot/mcclim/clim-listener.asd 2007/02/05 03:29:45 1.2 @@ -19,5 +19,7 @@ (:file "icons" :depends-on ("package" "util")) (:file "file-types" :depends-on ("package" "icons" "util")) (:file "dev-commands" :depends-on ("package" "icons" "file-types" "util")) - (:file "listener" :depends-on ("package" "file-types" "icons" "dev-commands" "util")) + (:file "wholine" :depends-on ("package" "dev-commands" "util")) + (:file "listener" :depends-on ("package" "wholine" "file-types" "icons" "dev-commands" "util")) + #+CMU (:file "cmu-hacks" :depends-on ("package")))))) \ No newline at end of file From ahefner at common-lisp.net Mon Feb 5 03:31:59 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 22:31:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Looks Message-ID: <20070205033159.768881E007@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Looks In directory clnet:/tmp/cvs-serv10420 Modified Files: pixie.lisp Log Message: Disable use of schedule-timer-event, which caused recursive lock errors. Tweaked the highlight/shadow on scroll bar buttons. --- /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2006/12/23 11:52:27 1.18 +++ /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2007/02/05 03:31:59 1.19 @@ -118,10 +118,10 @@ (draw-line* pane x1 y2 x1 y1 :ink +white+) (draw-line* pane x2 y1 x1 y1 :ink +white+) ;; now for the gray inline - (let ((x1 (+ x1 2)) - (y1 (+ y1 2)) - (x2 (- x2 1)) - (y2 (- y2 1))) + (let ((x1 (+ x1 1)) ; I'd prefer this be zero, so that there isn't + (y1 (+ y1 1)) ; the little sparkling white pixel in both corners + (x2 (- x2 1)) ; (bothersome in the corner of a scroller-pane), + (y2 (- y2 1))) ; but we may be transformed, so too much work. Bah. (draw-line* pane x1 y2 x2 y2 :ink +gray54+) (draw-line* pane x2 y1 x2 y2 :ink +gray54+)) ;; now for the black outline @@ -284,11 +284,13 @@ (case token ((up-notch) (when (< (gadget-value pane) (gadget-max-value pane)) + #+NIL (clim-internals::schedule-timer-event pane token 0.1) (incf (gadget-value pane)) (dispatch-repaint pane (sheet-region pane)))) ((down-notch) (when (> (gadget-value pane) (gadget-min-value pane)) + #+NIL (clim-internals::schedule-timer-event pane token 0.1) (decf (gadget-value pane)) (dispatch-repaint pane (sheet-region pane))))))))) @@ -313,12 +315,14 @@ ; move up or down one notch (cond ((< y (bounding-rectangle-min-y thumb)) + #+NIL (clim-internals::schedule-timer-event pane 'down-notch 0.1) ; move toward the min (when (> (gadget-value pane) (gadget-min-value pane)) (decf (gadget-value pane)) (dispatch-repaint pane (sheet-region pane)))) ((> y (bounding-rectangle-max-y thumb)) + #+NIL (clim-internals::schedule-timer-event pane 'up-notch 0.1) ; move toward the max (when (< (gadget-value pane) (gadget-max-value pane)) @@ -564,6 +568,7 @@ (let ((token (clim-internals::event-token event))) (with-slots (was-repeating repeating) pane (unless (eql was-repeating repeating) + #+NIL (clim-internals::schedule-timer-event pane token 0.1) (case token ((up-line) @@ -590,12 +595,14 @@ armed t drag-delta (- y (bounding-rectangle-min-y thumb)))) ((region-contains-position-p (gadget-up-region pane) x y) + #+NIL (clim-internals::schedule-timer-event pane 'up-line 0.1) ; Up Arrow (scroll-up-line-callback pane (gadget-client pane) (gadget-id pane)) (setf (slot-value pane 'armed) :up) (dispatch-repaint pane +everywhere+)) ((region-contains-position-p (gadget-down-region pane) x y) + #+NIL (clim-internals::schedule-timer-event pane 'down-line 0.1) ; Down Arrow (scroll-down-line-callback pane (gadget-client pane) (gadget-id pane)) @@ -605,9 +612,11 @@ ; Bed (cond ((< y (bounding-rectangle-min-y thumb)) + #+NIL (clim-internals::schedule-timer-event pane 'up-page 0.1) (scroll-up-page-callback pane (gadget-client pane) (gadget-id pane))) (t + #+NIL (clim-internals::schedule-timer-event pane 'down-page 0.1) (scroll-down-page-callback pane (gadget-client pane) (gadget-id pane))))) (t From ahefner at common-lisp.net Mon Feb 5 03:41:37 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 22:41:37 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20070205034137.1DEFD1E010@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv12508 Modified Files: file-types.lisp Log Message: Fix for some bogus mailcap entry noted on IRC. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/file-types.lisp 2006/03/29 10:43:37 1.10 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/file-types.lisp 2007/02/05 03:41:37 1.11 @@ -419,17 +419,20 @@ (let ((table (make-hash-table :size 8)) (foo nil)) ; <- position after reading required fields (when ;; First read the required fields. - (multiple-value-bind (text pos) - (read-mailcap-field line) - (multiple-value-bind (media-type type subtype) - (read-mime-type text) - (multiple-value-bind (view-command pos) - (read-mailcap-field line pos) - (setf foo pos) - (setf (gethash :type table) type) - (setf (gethash :subtype table) subtype) - (setf (gethash :media-type table) media-type) - #| --> |# (setf (gethash :view-command table) view-command)))) + (with-simple-restart (skip "Skip mailcap entry \"~A\"" (string-trim #(#\Space #\Tab) line)) + (multiple-value-bind (text pos) + (read-mailcap-field line) + (and pos + (multiple-value-bind (media-type type subtype) + (read-mime-type text) + (multiple-value-bind (view-command pos) + (read-mailcap-field line pos) + (setf foo pos) + (setf (gethash :type table) type) + (setf (gethash :subtype table) subtype) + (setf (gethash :media-type table) media-type) + ;; Note the return value: + (setf (gethash :view-command table) view-command)))))) ;; If the required fields were read successfully, read ;; the options into the hash table. (loop From ahefner at common-lisp.net Mon Feb 5 03:47:40 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Feb 2007 22:47:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070205034740.831A51F021@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv12787 Modified Files: clim-examples.asd Log Message: Add border and misc tests to examples system. --- /project/mcclim/cvsroot/mcclim/clim-examples.asd 2007/02/04 12:55:43 1.2 +++ /project/mcclim/cvsroot/mcclim/clim-examples.asd 2007/02/05 03:47:40 1.3 @@ -35,7 +35,9 @@ (:file "logic-cube") (:file "views") (:file "font-selector") - (:file "tabdemo"))) + (:file "tabdemo") + (:file "bordered-output-examples") + (:file "misc-tests"))) (:module "Goatee" :components ((:file "goatee-test"))))) From afuchs at common-lisp.net Mon Feb 5 09:49:44 2007 From: afuchs at common-lisp.net (afuchs) Date: Mon, 5 Feb 2007 04:49:44 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Inspector Message-ID: <20070205094944.2A48B9@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv7806/Apps/Inspector Removed Files: clouseau.asd Log Message: Remove the left-over clouseau.asd file. From thenriksen at common-lisp.net Tue Feb 6 09:10:51 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 6 Feb 2007 04:10:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070206091051.DC63A5411F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv14457 Modified Files: fundamental-syntax.lisp Log Message: Changed the updating-output cache value for cursors to something a bit more correct. --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2006/11/11 00:08:30 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2007/02/06 09:10:51 1.4 @@ -210,7 +210,7 @@ (multiple-value-bind (cursor-x cursor-y line-height) (offset-to-screen-position stream drei (offset mark)) (updating-output (stream :unique-id (list stream :cursor) - :cache-value (offset mark)) + :cache-value (list* cursor-x cursor-y line-height)) (draw-rectangle* stream (1- cursor-x) cursor-y (+ cursor-x 2) (+ cursor-y line-height) From thenriksen at common-lisp.net Tue Feb 6 09:25:08 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 6 Feb 2007 04:25:08 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070206092508.DC6AA61026@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv17253 Modified Files: lisp-syntax.lisp lisp-syntax-swine.lisp lisp-syntax-commands.lisp Log Message: Fixed some bugs in Lisp syntax and swapped the order of some arguments for better consistency. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/01/31 14:31:59 1.20 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/02/06 09:25:08 1.21 @@ -1612,7 +1612,7 @@ ;;; ;;; Useful functions for selecting forms based on the mark. -(defun expression-at-mark (mark-or-offset syntax) +(defun expression-at-mark (syntax mark-or-offset) "Return the form at `mark-or-offset'. If `mark-or-offset' is just after, or inside, a top-level-form, or if there are no forms after `mark-or-offset', the form preceding `mark-or-offset' is @@ -1623,7 +1623,7 @@ (form-after syntax offset) (form-before syntax offset)))) -(defun definition-at-mark (mark-or-offset syntax) +(defun definition-at-mark (syntax mark-or-offset) "Return the top-level form at `mark-or-offset'. If `mark-or-offset' is just after, or inside, a top-level-form, or if there are no forms after `mark-or-offset', the top-level-form preceding `mark-or-offset' @@ -1631,16 +1631,20 @@ `mark-or-offset' is returned." (form-toplevel (expression-at-mark mark-or-offset syntax) syntax)) -(defun symbol-at-mark (mark-or-offset syntax) +(defun symbol-at-mark (syntax mark-or-offset + &optional (form-fetcher 'expression-at-mark)) "Return a symbol token at `mark-or-offset'. This function will - \"unwrap\" quote-forms in order to return the symbol token. If - no symbol token can be found, NIL will be returned." - (labels ((unwrap-form (form) - (cond ((form-quoted-p form) - (unwrap-form (first-form (children form)))) - ((form-token-p form) - form)))) - (unwrap-form (expression-at-mark mark-or-offset syntax)))) +\"unwrap\" quote-forms in order to return the symbol token. If no +symbol token can be found, NIL will be returned. `Form-fetcher' +must be a function with the same signature as `expression-at-mark', and +will be used to retrieve the initial form at `mark'." + (as-offsets (mark-or-offset) + (labels ((unwrap-form (form) + (cond ((form-quoted-p form) + (unwrap-form (first-form (children form)))) + ((form-token-p form) + form)))) + (unwrap-form (funcall form-fetcher syntax mark-or-offset))))) (defun fully-quoted-form (token) "Return the top token object for `token', return `token' or the @@ -1660,34 +1664,34 @@ (t form)))) (descend token))) -(defun this-form (mark-or-offset syntax) +(defun this-form (syntax mark-or-offset) "Return a form at `mark-or-offset'. This function defines which forms the COM-FOO-this commands affect." (as-offsets ((offset mark-or-offset)) (or (form-around syntax offset) (form-before syntax offset)))) -(defun preceding-form (mark-or-offset syntax) +(defun preceding-form (syntax mark-or-offset) "Return a form at `mark-or-offset'." (as-offsets ((offset mark-or-offset)) (or (form-before syntax offset) (form-around syntax offset)))) -(defun text-of-definition-at-mark (mark syntax) +(defun text-of-definition-at-mark (syntax mark) "Return the text of the definition at mark." (let ((definition (definition-at-mark mark syntax))) (buffer-substring (buffer mark) (start-offset definition) (end-offset definition)))) -(defun text-of-expression-at-mark (mark-or-offset syntax) +(defun text-of-expression-at-mark (syntax mark-or-offset) "Return the text of the expression at `mark-or-offset'." (let ((expression (expression-at-mark mark-or-offset syntax))) (form-string syntax expression))) -(defun symbol-name-at-mark (mark-or-offset syntax) +(defun symbol-name-at-mark (syntax mark-or-offset) "Return the text of the symbol at `mark-or-offset'." - (let ((token (symbol-at-mark mark-or-offset syntax))) + (let ((token (symbol-at-mark syntax mark-or-offset))) (when token (form-string syntax token)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1731,14 +1735,23 @@ ;;; ;;; Useful functions for modifying forms based on the mark. -(defun replace-symbol-at-mark (mark syntax string) - "Replace the symbol at `mark' with `string' and move `mark' to -after `string'." - (let ((token (symbol-at-mark mark syntax))) - (setf (offset mark) (start-offset token)) - (forward-delete-expression mark syntax) +(defgeneric replace-symbol-at-mark (syntax mark string) + (:documentation "Replace the symbol around `mark' with `string' +and move `mark' to after `string'. If there is no symbol at +`mark', insert `string' and move `mark' anyway.")) + +(defmethod replace-symbol-at-mark ((syntax lisp-syntax) (mark mark) + (string string)) + (let ((token (symbol-at-mark syntax mark #'form-around))) + (when (and token (form-token-p token)) + (setf (offset mark) (start-offset token)) + (forward-delete-expression mark syntax)) (insert-sequence mark string))) +(defmethod replace-symbol-at-mark :after ((syntax lisp-syntax) + (mark left-sticky-mark) (string string)) + (forward-object mark (length string))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; display --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2006/12/10 19:28:49 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2007/02/06 09:25:08 1.5 @@ -539,12 +539,16 @@ (>= (+ index difference) key-position) - (evenp (- index (- key-position - (1- difference))))) + (let ((offset (- index (- key-position (1- difference))))) + (or (evenp offset) (zerop key-position)))) (mapcar #'unlisted (subseq cleaned-arglist - (+ (- key-position - difference) - (if rest-position 2 1)))))))) + (+ (max (- key-position + difference) + (- (if rest-position 2 1))) + (if rest-position 2 1)) + (if rest-position + (1- (length cleaned-arglist)) + (length cleaned-arglist)))))))) (defgeneric possible-completions (syntax operator string package operands indices) (:documentation "Get the applicable completions for completing @@ -554,7 +558,8 @@ object), and which has the operands `operands'. `Indices' should be the argument indices from the operator to `token' (see `find-argument-indices-for-operands').") - (:method (syntax operator string package operands indices) + (:method ((syntax lisp-syntax) operator (string string) + (package package) (operands list) (indices list)) (let ((completions (first (simple-completions (get-usable-image syntax) string package)))) ;; Welcome to the ugly mess! Part of the uglyness is that we @@ -778,7 +783,7 @@ `(let* ((,form-sym ;; Find a form with a valid (fboundp) operator. (let ((immediate-form - (preceding-form ,mark-or-offset ,syntax))) + (preceding-form ,syntax ,mark-or-offset))) (unless (null immediate-form) (or (find-applicable-form ,syntax immediate-form) ;; If nothing else can be found, and `arg-form' @@ -1000,13 +1005,13 @@ (defun complete-symbol-at-mark-with-fn (syntax mark &key (completion-finder #'find-completions) (complete-blank t)) "Attempt to find and complete the symbol at `mark' using the - function `completion-finder' to get the list of completions. If the completion - is ambiguous, a list of possible completions will be - displayed. If no symbol can be found at `mark', return NIL. If - there is no symbol at `mark' and `complete-blank' is true (the - default), all symbols available in the current package will be - shown. If `complete-blank' is true, nothing will be shown and - the function will return NIL." +function `completion-finder' to get the list of completions. If +the completion is ambiguous, a list of possible completions will +be displayed. If no symbol can be found at `mark', return NIL. If +there is no symbol at `mark' and `complete-blank' is true (the +default), all symbols available in the current package will be +shown. If `complete-blank' is true, nothing will be shown and the +function will return NIL." (let* ((token (form-around syntax (offset mark))) (useful-token (and (not (null token)) (form-token-p token) @@ -1015,36 +1020,34 @@ (when (or useful-token complete-blank) (multiple-value-bind (longest completions) (funcall completion-finder syntax - (if useful-token - (start-offset (fully-quoted-form token)) - (if (and (form-quoted-p token) - (form-incomplete-p token)) - (start-offset token) - (offset mark))) + (cond (useful-token + (start-offset (fully-quoted-form token))) + ((and (form-quoted-p token) + (form-incomplete-p token)) + (start-offset token)) + (t (offset mark))) (if useful-token (form-string syntax token) "")) - (if completions - (if (= (length completions) 1) - (replace-symbol-at-mark mark syntax longest) - (progn - (esa:display-message (format nil "Longest is ~a|" longest)) - (let ((selection (menu-choose (mapcar - ;; FIXME: this can - ;; get ugly. - #'(lambda (completion) - (if (listp completion) - (cons completion - (first completion)) - completion)) - completions) - :label "Possible completions" - :scroll-bars :vertical))) - (if useful-token - (replace-symbol-at-mark mark syntax (or selection longest)) - (insert-sequence mark (or selection longest))) - t))) - (esa:display-message "No completions found")))))) + (cond ((null completions) + (esa:display-message "No completions found") + nil) + ((endp (rest completions)) + (replace-symbol-at-mark syntax mark longest) + t) + (t (replace-symbol-at-mark + syntax mark + (or (menu-choose (mapcar + #'(lambda (completion) + (if (listp completion) + (cons completion + (first completion)) + completion)) + completions) + :label "Possible completions" + :scroll-bars :vertical) + longest)) + t)))))) (defun complete-symbol-at-mark (syntax mark &optional (complete-blank t)) "Attempt to find and complete the symbol at `mark'. If the --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2007/01/10 20:54:13 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2007/02/06 09:25:08 1.6 @@ -96,7 +96,7 @@ (buffer (buffer pane)) (syntax (syntax buffer)) (mark (point pane)) - (token (this-form mark syntax))) + (token (this-form syntax mark))) (if (and token (form-token-p token)) (com-lookup-arglist (form-to-object syntax token)) (display-message "Could not find symbol at point.")))) @@ -134,7 +134,7 @@ completions will be displayed. If there is no symbol at mark, all relevant symbols accessible in the current package will be displayed." - (complete-symbol-at-mark *current-syntax* *current-mark*)) + (complete-symbol-at-mark *current-syntax* *current-point*)) (define-command (com-fuzzily-complete-symbol :name t :command-table lisp-table) () @@ -144,7 +144,7 @@ the abbreviation is ambiguous, a list of possible completions will be displayed. If there is no symbol at mark, all relevant symbols accessible in the current package will be displayed." - (fuzzily-complete-symbol-at-mark *current-syntax* *current-mark*)) + (fuzzily-complete-symbol-at-mark *current-syntax* *current-point*)) (define-command (com-indent-line-and-complete-symbol :name t :command-table lisp-table) () "Indents the current line and performs symbol completion. From thenriksen at common-lisp.net Tue Feb 6 09:25:44 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 6 Feb 2007 04:25:44 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070206092544.0DDB3650D3@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv17378 Modified Files: base.lisp Log Message: Added terminating newline to make CVS shut up. --- /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2007/01/14 17:57:01 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2007/02/06 09:25:43 1.5 @@ -886,4 +886,4 @@ (change-class mark 'standard-left-sticky-mark)) (defmethod unnarrow-mark ((mark narrowed-right-sticky-mark)) - (change-class mark 'standard-right-sticky-mark)) \ No newline at end of file + (change-class mark 'standard-right-sticky-mark)) From thenriksen at common-lisp.net Tue Feb 6 09:38:30 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 6 Feb 2007 04:38:30 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070206093830.32A2736009@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv18159 Modified Files: lisp-syntax.lisp Log Message: Added type requirement to the base slot of Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/02/06 09:25:08 1.21 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/02/06 09:38:29 1.22 @@ -63,7 +63,9 @@ last (descending offset).") (base :initform nil :documentation "The base which numbers in the buffer are -expected to be in.") +expected to be in. If the provided value is NIL, the value of +`*read-base*' will be used." + :type (or null (integer 2 36))) (option-specified-package :accessor option-specified-package :initform nil :documentation "The package From thenriksen at common-lisp.net Tue Feb 6 10:03:16 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 6 Feb 2007 05:03:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070206100316.008DA50021@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv22805 Modified Files: lisp-syntax.lisp Log Message: Made some more forms be complete. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/02/06 09:38:29 1.22 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/02/06 10:03:16 1.23 @@ -1142,7 +1142,7 @@ ;;;;;;;;;;;;;;;; uninterned symbol ;;; parse trees -(defclass uninterned-symbol-form (form) ()) +(defclass uninterned-symbol-form (form complete-form-mixin) ()) (define-parser-state |#: | (form-may-follow) ()) (define-parser-state |#: form | (lexer-toplevel-state parser-state) ()) @@ -1157,7 +1157,7 @@ ;;;;;;;;;;;;;;;; readtime evaluation ;;; parse trees -(defclass readtime-evaluation-form (form) ()) +(defclass readtime-evaluation-form (form complete-form-mixin) ()) (define-parser-state |#. | (form-may-follow) ()) (define-parser-state |#. form | (lexer-toplevel-state parser-state) ()) @@ -1173,7 +1173,7 @@ ;;;;;;;;;;;;;;;; sharpsign equals ;;; parse trees -(defclass sharpsign-equals-form (form) ()) +(defclass sharpsign-equals-form (form complete-form-mixin) ()) (define-parser-state |#= | (form-may-follow) ()) (define-parser-state |#= form | (lexer-toplevel-state parser-state) ()) @@ -1189,7 +1189,7 @@ ;;;;;;;;;;;;;;;; array ;;; parse trees -(defclass array-form (form) ()) +(defclass array-form (form complete-form-mixin) ()) (define-parser-state |#A | (form-may-follow) ()) (define-parser-state |#A form | (lexer-toplevel-state parser-state) ()) @@ -1251,7 +1251,7 @@ ;;;;;;;;;;;;;;;; undefined reader macro ;;; parse trees -(defclass undefined-reader-macro-form (form) ()) +(defclass undefined-reader-macro-form (form complete-form-mixin) ()) (define-parser-state |# | (form-may-follow) ()) (define-parser-state |# form | (lexer-toplevel-state parser-state) ()) From thenriksen at common-lisp.net Tue Feb 6 12:50:35 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 6 Feb 2007 07:50:35 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/cl-automaton Message-ID: <20070206125035.33AB77D002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/cl-automaton In directory clnet:/tmp/cvs-serv15700 Removed Files: regexp-test.lisp automaton-test.asd Log Message: Removed unneeded files. From thenriksen at common-lisp.net Tue Feb 6 12:53:09 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 6 Feb 2007 07:53:09 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/cl-automaton Message-ID: <20070206125309.94CDD7D002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/cl-automaton In directory clnet:/tmp/cvs-serv15900 Modified Files: automaton-package.lisp automaton.lisp eqv-hash.lisp regexp.lisp state-and-transition.lisp Log Message: Updated the copyright headers as per request from the Debian packager of McCLIM. --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-package.lisp 2006/11/08 01:15:32 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-package.lisp 2007/02/06 12:53:09 1.2 @@ -1,7 +1,22 @@ -;;; -*- mode: lisp -*- -;;; -;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic at yahoo.com) -;;; +;;; -*- Mode: Lisp; Package: AUTOMATON -*- +;;; +;;; (c) copyright 2005-2007 by +;;; Aleksandar Bakic (a_bakic at yahoo.com) +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library General Public +;;; License along with this library; if not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307 USA. (defpackage #:eqv-hash (:use :cl) --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.lisp 2007/01/14 17:33:51 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.lisp 2007/02/06 12:53:09 1.3 @@ -1,8 +1,23 @@ -;;; -*- mode: lisp -*- -;;; -;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic at yahoo.com) -;;; - +;;; -*- Mode: Lisp; Package: AUTOMATON -*- +;;; +;;; (c) copyright 2005-2007 by +;;; Aleksandar Bakic (a_bakic at yahoo.com) +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library General Public +;;; License along with this library; if not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307 USA. +;;; ;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders M??ller ;;; - Functionality not used by the regular expression engine and not tested ;;; has been omitted from this initial release. --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.lisp 2007/01/14 17:33:51 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.lisp 2007/02/06 12:53:09 1.3 @@ -1,7 +1,22 @@ -;;; -*- mode: lisp -*- -;;; -;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic at yahoo.com) -;;; +;;; -*- Mode: Lisp; Package: AUTOMATON -*- +;;; +;;; (c) copyright 2005-2007 by +;;; Aleksandar Bakic (a_bakic at yahoo.com) +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library General Public +;;; License along with this library; if not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307 USA. ;;; A naive attempt at implementing the protocol proposed by Robert ;;; Strandh (see eqv-hash.txt). --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp.lisp 2006/11/08 01:15:32 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp.lisp 2007/02/06 12:53:09 1.2 @@ -1,7 +1,22 @@ -;;; -*- mode: lisp -*- -;;; -;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic at yahoo.com) -;;; +;;; -*- Mode: Lisp; Package: AUTOMATON -*- +;;; +;;; (c) copyright 2005-2007 by +;;; Aleksandar Bakic (a_bakic at yahoo.com) +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library General Public +;;; License along with this library; if not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307 USA. ;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders M??ller ;;; - Some comments have been copied verbatim from the original code. --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition.lisp 2007/01/14 17:33:51 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition.lisp 2007/02/06 12:53:09 1.3 @@ -1,7 +1,22 @@ -;;; -*- mode: lisp -*- -;;; -;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic at yahoo.com) -;;; +;;; -*- Mode: Lisp; Package: AUTOMATON -*- +;;; +;;; (c) copyright 2005-2007 by +;;; Aleksandar Bakic (a_bakic at yahoo.com) +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library General Public +;;; License along with this library; if not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307 USA. ;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders M??ller From dlichteblau at common-lisp.net Tue Feb 6 12:54:10 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 6 Feb 2007 07:54:10 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070206125410.8532E7D164@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv15980 Modified Files: gadgets.lisp Log Message: Fixed the method browser. * gadgets.lisp (value-changed-callback): Move method from meta-list-pane down to generic-list-pane where it belongs. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2007/02/05 02:57:18 1.104 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2007/02/06 12:54:10 1.105 @@ -1971,7 +1971,7 @@ (defmethod value-changed-callback :before - ((gadget meta-list-pane) client gadget-id value) + ((gadget generic-list-pane) client gadget-id value) (declare (ignore client gadget-id)) (let* ((i (position value (generic-list-pane-item-values gadget))) (item (elt (list-pane-items gadget) i)) From crhodes at common-lisp.net Wed Feb 7 12:44:18 2007 From: crhodes at common-lisp.net (crhodes) Date: Wed, 7 Feb 2007 07:44:18 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070207124418.7B3DC4717F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv16608 Modified Files: NEWS decls.lisp frames.lisp package.lisp panes.lisp ports.lisp stream-input.lisp text-editor-gadget.lisp Log Message: New click-to-focus policy for text-editor gadgets and panes, implemented for the CLX, Null and gtkairo backends (but gtk_window_get_focus() hand-inserted into gtkairo/ffi.lisp). PORT-KEYBOARD-INPUT-FOCUS is now a trampoline to PORT-FRAME-KEYBOARD-INPUT-FOCUS, a per-port function to set the keyboard focus for a particular frame. Not implemented for Beagle or OpenGL backends. Now Drei / Goatee gadgets don't have to do their own keyboard focus handling on arm/disarm any more. Various kludges sprinkled all over the place to make this so. --- /project/mcclim/cvsroot/mcclim/NEWS 2007/01/18 15:01:11 1.20 +++ /project/mcclim/cvsroot/mcclim/NEWS 2007/02/07 12:44:16 1.21 @@ -2,6 +2,9 @@ ** Installation: the systems clim-listener, scigraph, clim-examples, and clouseau can now be loaded without loading the system mcclim first. +** improvement: the CLX backend should no longer cause focus stealing + when an application has text-editor panes. This change comes with + a rudimentary click-to-focus-keyboard widget policy. * Changes in mcclim-0.9.4 relative to 0.9.3: ** cleanup: removed the obsolete system.lisp file. --- /project/mcclim/cvsroot/mcclim/decls.lisp 2006/12/14 19:43:51 1.45 +++ /project/mcclim/cvsroot/mcclim/decls.lisp 2007/02/07 12:44:16 1.46 @@ -221,6 +221,9 @@ ;;;; 8.1 (defgeneric process-next-event (port &key wait-function timeout)) +(defgeneric port-keyboard-input-focus (port)) +(defgeneric (setf port-keyboard-input-focus) (focus port)) + ;;; 8.2 Standard Device Events (defgeneric event-timestamp (event)) --- /project/mcclim/cvsroot/mcclim/frames.lisp 2007/02/05 02:55:29 1.124 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2007/02/07 12:44:16 1.125 @@ -129,8 +129,6 @@ (manager :initform nil :reader frame-manager :accessor %frame-manager) - (keyboard-input-focus :initform nil - :accessor keyboard-input-focus) (properties :accessor %frame-properties :initarg :properties :initform nil) @@ -1329,13 +1327,9 @@ `(let ((,frame *application-frame*)) , at body)) - (defmethod note-input-focus-changed (pane state) (declare (ignore pane state))) -(defmethod (setf keyboard-input-focus) :after (focus frame) - (%set-port-keyboard-focus (port frame) focus)) - (defmethod (setf client-setting) (value frame setting) (setf (getf (client-settings frame) setting) value)) --- /project/mcclim/cvsroot/mcclim/package.lisp 2007/02/05 03:16:55 1.61 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2007/02/07 12:44:17 1.62 @@ -1967,6 +1967,7 @@ #:port-disable-sheet #:port-enable-sheet #:port-force-output + #:port-frame-keyboard-input-focus #:port-grab-pointer #:port-mirror-height #:port-mirror-width @@ -1977,7 +1978,6 @@ #:port-set-sheet-transformation #:port-ungrab-pointer #:queue-callback - #:%set-port-keyboard-focus #:set-sheet-pointer-cursor #:synthesize-pointer-motion-event #:text-style-character-width --- /project/mcclim/cvsroot/mcclim/panes.lisp 2007/02/05 03:02:59 1.179 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2007/02/07 12:44:17 1.180 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.179 2007/02/05 03:02:59 ahefner Exp $ +;;; $Id: panes.lisp,v 1.180 2007/02/07 12:44:17 crhodes Exp $ (in-package :clim-internals) @@ -2599,10 +2599,16 @@ (defmethod stream-set-input-focus ((stream clim-stream-pane)) (with-slots (port) stream - (prog1 - (port-keyboard-input-focus port) + (prog1 (port-keyboard-input-focus port) (setf (port-keyboard-input-focus port) stream)))) +#+nil +(defmethod stream-set-input-focus ((stream null)) + (let ((frame *application-frame*)) + (prog1 + (frame-keyboard-input-focus frame) + (setf (frame-keyboard-input-focus frame) nil)))) + ;;; output any buffered stuff before input (defmethod stream-read-gesture :before ((stream clim-stream-pane) @@ -2649,6 +2655,20 @@ #+ignore (let ((cursor (stream-text-cursor pane))) (setf (cursor-visibility cursor) t))) +;;; KLUDGE: this is a hack to get keyboard focus (click-to-focus) +;;; roughly working for interactor panes. It's a hack somewhat +;;; analogous to the mouse-wheel / select-and-paste handling in +;;; DISPATCH-EVENT, just in a slightly different place. +(defmethod frame-input-context-button-press-handler :before + ((frame standard-application-frame) + (stream interactor-pane) + button-press-event) + (let ((previous (stream-set-input-focus stream))) + (when (and previous (typep previous 'gadget)) + (let ((client (gadget-client previous)) + (id (gadget-id previous))) + (disarmed-callback previous client id))))) + ;;; APPLICATION PANES (defclass application-pane (clim-stream-pane) --- /project/mcclim/cvsroot/mcclim/ports.lisp 2006/12/24 14:27:43 1.54 +++ /project/mcclim/cvsroot/mcclim/ports.lisp 2007/02/07 12:44:17 1.55 @@ -49,9 +49,6 @@ (mirror->sheet :initform (make-hash-table :test #'eq)) (pixmap->mirror :initform (make-hash-table :test #'eq)) (mirror->pixmap :initform (make-hash-table :test #'eq)) - #+ignore (keyboard-input-focus :initform nil ;; nuked this, see below - :initarg :keyboard-input-focus - :accessor port-keyboard-input-focus) (event-process :initform nil :initarg :event-process @@ -66,51 +63,23 @@ (text-style-mappings :initform (make-hash-table :test #'eq) :reader port-text-style-mappings) (pointer-sheet :initform nil :accessor port-pointer-sheet - :documentation "The sheet the pointer is over, if any") - )) - -;; Keyboard focus is now managed per-frame rather than per-port, -;; which makes a lot of sense (less sense in the presense of -;; multiple top-level windows, but no one does that yet). The CLIM -;; spec suggests this in a "Minor Issue". So, redirect -;; PORT-KEYBOARD-INPUT-FOCUS to the current application frame -;; for compatibility. - -;; Note: This would prevent you from using the function the -;; function to query who currently has the focus. I don't -;; know if this is an intended use or not. - -;; The big picture: -;; PORT-KEYBOARD-INPUT-FOCUS is defined by CLIM 2.0 -;; Our default method on this delegates to KEYBOARD-INPUT-FOCUS -;; on the current application frame. -;; %SET-PORT-KEYBOARD-FOCUS is the function which -;; should be implemented in a McCLIM backend and -;; does the work of changing the focus. -;; A method on (SETF KEYBOARD-INPUT-FOCUS) brings them together, -;; calling %SET-PORT-KEYBOARD-FOCUS. - -(defgeneric port-keyboard-input-focus (port)) -(defgeneric (setf port-keyboard-input-focus) (focus port)) + :documentation "The sheet the pointer is over, if any"))) (defmethod port-keyboard-input-focus (port) - (declare (ignore port)) - (when *application-frame* - (keyboard-input-focus *application-frame*))) - + (when (null *application-frame*) + (error "~S called with null ~S" + 'port-keyboard-input-focus '*application-frame*)) + (port-frame-keyboard-input-focus port *application-frame*)) (defmethod (setf port-keyboard-input-focus) (focus port) - (when focus - (if (pane-frame focus) - (setf (keyboard-input-focus (pane-frame focus)) focus) - (%set-port-keyboard-focus port focus)))) - -;; This is not in the CLIM spec, but since (setf port-keyboard-input-focus) -;; now calls (setf keyboard-input-focus), we need something concrete the -;; backend can implement to set the focus. -(defmethod %set-port-keyboard-focus (port focus &key timestamp) - (declare (ignore focus timestamp)) - (warn "%SET-PORT-KEYBOARD-FOCUS is not implemented on ~W" port)) - + (when (null *application-frame*) + (error "~S called with null ~S" + '(setf port-keyboard-input-focus) '*application-frame*)) + (unless (eq *application-frame* (pane-frame focus)) + (error "frame mismatch in ~S" '(setf port-keyboard-input-focus))) + (setf (port-frame-keyboard-input-focus port *application-frame*) focus)) + +(defgeneric port-frame-keyboard-input-focus (port frame)) +(defgeneric (setf port-frame-keyboard-input-focus) (focus port frame)) (defun find-port (&key (server-path *default-server-path*)) (if (null server-path) @@ -195,8 +164,7 @@ (defmethod distribute-event ((port basic-port) event) (cond ((typep event 'keyboard-event) - (dispatch-event (or #+ignore(port-keyboard-input-focus port) (event-sheet event)) - event)) + (dispatch-event (event-sheet event) event)) ((typep event 'window-event) ; (dispatch-event (window-event-mirrored-sheet event) event) (dispatch-event (event-sheet event) event)) --- /project/mcclim/cvsroot/mcclim/stream-input.lisp 2006/12/10 23:26:39 1.50 +++ /project/mcclim/cvsroot/mcclim/stream-input.lisp 2007/02/07 12:44:17 1.51 @@ -141,12 +141,9 @@ (setq stream '*standard-input*)) (let ((old-stream (gensym "OLD-STREAM"))) `(let ((,old-stream (stream-set-input-focus ,stream))) - (unwind-protect (locally - , at body) - (if ,old-stream - (stream-set-input-focus ,old-stream) - (setf (port-keyboard-input-focus (port ,stream)) nil)))))) - + (unwind-protect (locally , at body) + (when ,old-stream + (stream-set-input-focus ,old-stream)))))) (defun read-gesture (&key (stream *standard-input*) @@ -265,9 +262,9 @@ ;; the problem. -- moore (cond ((null gesture) (go wait-for-char)) - ((and pointer-button-press-handler - (typep gesture 'pointer-button-press-event)) - (funcall pointer-button-press-handler stream gesture)) + ((and pointer-button-press-handler + (typep gesture 'pointer-button-press-event)) + (funcall pointer-button-press-handler stream gesture)) ((loop for gesture-name in *abort-gestures* thereis (event-matches-gesture-name-p gesture gesture-name)) --- /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2006/12/20 22:58:20 1.7 +++ /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2007/02/07 12:44:17 1.8 @@ -126,10 +126,9 @@ (make-text-style :fixed :roman :normal)) (defclass goatee-text-field-pane (text-field - standard-extended-output-stream - standard-output-recording-stream - enter/exit-arms/disarms-mixin - basic-pane) + standard-extended-output-stream + standard-output-recording-stream + basic-pane) ((area :accessor area :initform nil :documentation "The Goatee area used for text editing.") (previous-focus :accessor previous-focus :initform nil @@ -169,15 +168,17 @@ 'value)))) (stream-add-output-record pane (area pane)))) -;;; Unilaterally declare a "focus follows mouse" policy. I don't like this -;;; much; the whole issue of keyboard focus needs a lot more thought, -;;; especially when multiple application frames per port become possible. +;;; This implements click-to-focus-keyboard-and-pass-click-through +;;; behaviour. +(defmethod handle-event :before + ((gadget goatee-text-field-pane) (event pointer-button-press-event)) + (let ((previous (stream-set-input-focus gadget))) + (when (and previous (typep previous 'gadget)) + (disarmed-callback previous (gadget-client previous) (gadget-id previous))) + (armed-callback gadget (gadget-client gadget) (gadget-id gadget)))) (defmethod armed-callback :after ((gadget goatee-text-field-pane) client id) (declare (ignore client id)) - (let ((port (port gadget))) - (setf (previous-focus gadget) (port-keyboard-input-focus port)) - (setf (port-keyboard-input-focus port) gadget)) (handle-repaint gadget +everywhere+) ;FIXME: trigger initialization (let ((cursor (cursor (area gadget)))) (letf (((cursor-state cursor) nil)) @@ -185,16 +186,13 @@ (defmethod disarmed-callback :after ((gadget goatee-text-field-pane) client id) (declare (ignore client id)) - (let ((port (port gadget))) - (setf (port-keyboard-input-focus port) (previous-focus gadget)) - (setf (previous-focus gadget) nil)) (handle-repaint gadget +everywhere+) ;FIXME: trigger initialization (let ((cursor (cursor (area gadget)))) (letf (((cursor-state cursor) nil)) (setf (cursor-appearance cursor) :hollow)))) - -(defmethod handle-event ((gadget goatee-text-field-pane) (event key-press-event)) +(defmethod handle-event + ((gadget goatee-text-field-pane) (event key-press-event)) (let ((gesture (convert-to-gesture event)) (*activation-gestures* (activation-gestures gadget))) (when (activation-gesture-p gesture) From crhodes at common-lisp.net Wed Feb 7 12:44:18 2007 From: crhodes at common-lisp.net (crhodes) Date: Wed, 7 Feb 2007 07:44:18 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20070207124418.F019D47260@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv16608/Backends/CLX Modified Files: package.lisp port.lisp Log Message: New click-to-focus policy for text-editor gadgets and panes, implemented for the CLX, Null and gtkairo backends (but gtk_window_get_focus() hand-inserted into gtkairo/ffi.lisp). PORT-KEYBOARD-INPUT-FOCUS is now a trampoline to PORT-FRAME-KEYBOARD-INPUT-FOCUS, a per-port function to set the keyboard focus for a particular frame. Not implemented for Beagle or OpenGL backends. Now Drei / Goatee gadgets don't have to do their own keyboard focus handling on arm/disarm any more. Various kludges sprinkled all over the place to make this so. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/package.lisp 2004/02/09 22:30:55 1.19 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/package.lisp 2007/02/07 12:44:18 1.20 @@ -53,7 +53,6 @@ #:width ;dito #:coordinate= #:get-transformation - #:keyboard-input-focus ;; #:invoke-with-special-choices #:medium-miter-limit --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2006/12/24 14:27:44 1.126 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2007/02/07 12:44:18 1.127 @@ -432,7 +432,7 @@ (setf (xlib:wm-hints window) (xlib:make-wm-hints :input :on)) (setf (xlib:wm-name window) (frame-pretty-name frame)) (setf (xlib:wm-icon-name window) (frame-pretty-name frame)) - (setf (xlib:wm-protocols window) `(:wm_delete_window :wm_take_focus))))) + (setf (xlib:wm-protocols window) `(:wm_delete_window))))) (defmethod realize-mirror ((port clx-port) (sheet unmanaged-top-level-sheet-pane)) (realize-mirror-aux port sheet @@ -663,10 +663,10 @@ type width height x y root-x root-y data override-redirect-p send-event-p hint-p target property requestor selection + request first-keycode count &allow-other-keys) (declare (special *clx-port*)) - (let ((sheet (and window - (port-lookup-sheet *clx-port* window)))) + (let ((sheet (and window (port-lookup-sheet *clx-port* window)))) (when sheet (case event-key ((:key-press :key-release) @@ -681,7 +681,8 @@ :x x :y y :graft-x root-x :graft-y root-y - :sheet sheet :modifier-state modifier-state :timestamp time))) + :sheet (or (frame-properties (pane-frame sheet) 'focus) sheet) + :modifier-state modifier-state :timestamp time))) ((:button-press :button-release) (let ((modifier-state (clim-xcommon:x-event-state-modifiers *clx-port* state))) @@ -842,22 +843,7 @@ (defmethod port-wm-protocols-message (sheet time (message (eql :wm_delete_window)) data) (declare (ignore data)) - (make-instance 'window-manager-delete-event - :sheet sheet - :timestamp time)) - -(defmethod port-wm-protocols-message (sheet time (message (eql :wm_take_focus)) data) - (when time - (format *trace-output* "~&;; In :WM_TAKE_FOCUS, TIME is not NIL: ~S" time)) - (let* ((frame (pane-frame sheet)) - (focus (climi::keyboard-input-focus frame)) - ;; FIXME: Do I really have to use ELT here? The CLX manual - ;; says (sequence integer), so I suppose I do. - (timestamp (elt data 1))) - (when (and focus (sheet-mirror focus)) - (xlib:set-input-focus (clx-port-display *clx-port*) - (sheet-mirror focus) :parent timestamp) - nil))) + (make-instance 'window-manager-delete-event :sheet sheet :timestamp time)) (defmethod port-wm-protocols-message (sheet time (message t) data) (warn "Unprocessed WM Protocols message: ~:_message = ~S;~:_ data = ~S;~_ sheet = ~S." @@ -1155,13 +1141,10 @@ ;; reasonable timestamp. :timestamp 0)))))))) - -;;; Set the keyboard input focus for the port. - -(defmethod %set-port-keyboard-focus ((port clx-port) focus &key timestamp) - (let ((mirror (sheet-mirror focus))) - (when mirror - (xlib:set-input-focus (clx-port-display port) mirror :parent timestamp)))) +(defmethod port-frame-keyboard-input-focus ((port clx-port) frame) + (frame-properties frame 'focus)) +(defmethod (setf port-frame-keyboard-input-focus) (focus (port clx-port) frame) + (setf (frame-properties frame 'focus) focus)) (defmethod port-force-output ((port clx-port)) (xlib:display-force-output (clx-port-display port))) From crhodes at common-lisp.net Wed Feb 7 12:44:19 2007 From: crhodes at common-lisp.net (crhodes) Date: Wed, 7 Feb 2007 07:44:19 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/Null Message-ID: <20070207124419.7B018481C1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/Null In directory clnet:/tmp/cvs-serv16608/Backends/Null Modified Files: port.lisp Log Message: New click-to-focus policy for text-editor gadgets and panes, implemented for the CLX, Null and gtkairo backends (but gtk_window_get_focus() hand-inserted into gtkairo/ffi.lisp). PORT-KEYBOARD-INPUT-FOCUS is now a trampoline to PORT-FRAME-KEYBOARD-INPUT-FOCUS, a per-port function to set the keyboard focus for a particular frame. Not implemented for Beagle or OpenGL backends. Now Drei / Goatee gadgets don't have to do their own keyboard focus handling on arm/disarm any more. Various kludges sprinkled all over the place to make this so. --- /project/mcclim/cvsroot/mcclim/Backends/Null/port.lisp 2006/10/29 00:21:35 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/Null/port.lisp 2007/02/07 12:44:19 1.3 @@ -155,9 +155,16 @@ (defmethod synthesize-pointer-motion-event ((pointer null-pointer)) ()) -;;; Set the keyboard input focus for the port. +(defmethod port-frame-keyboard-input-focus ((port null-port) frame) + (frame-properties frame 'focus)) +(defmethod (setf port-frame-keyboard-input-focus) + (focus (port null-port) frame) + (setf (frame-properties frame 'focus) focus)) -(defmethod %set-port-keyboard-focus (focus (port null-port) &key timestamp) +(defmethod (setf port-keyboard-input-focus) (focus (port null-port)) + focus) + +(defmethod port-keyboard-input-focus ((port null-port)) ()) (defmethod port-force-output ((port null-port)) From crhodes at common-lisp.net Wed Feb 7 12:44:20 2007 From: crhodes at common-lisp.net (crhodes) Date: Wed, 7 Feb 2007 07:44:20 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20070207124420.1342A49022@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv16608/Backends/gtkairo Modified Files: ffi.lisp port.lisp Log Message: New click-to-focus policy for text-editor gadgets and panes, implemented for the CLX, Null and gtkairo backends (but gtk_window_get_focus() hand-inserted into gtkairo/ffi.lisp). PORT-KEYBOARD-INPUT-FOCUS is now a trampoline to PORT-FRAME-KEYBOARD-INPUT-FOCUS, a per-port function to set the keyboard focus for a particular frame. Not implemented for Beagle or OpenGL backends. Now Drei / Goatee gadgets don't have to do their own keyboard focus handling on arm/disarm any more. Various kludges sprinkled all over the place to make this so. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2007/02/04 12:55:44 1.16 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2007/02/07 12:44:19 1.17 @@ -1625,6 +1625,10 @@ (requisition :pointer) ;GtkRequisition * ) +(defcfun "gtk_window_get_focus" + :pointer + (window :pointer)) + (defcfun "gtk_window_move" :void (window :pointer) ;GtkWindow * --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2007/02/04 12:55:44 1.16 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2007/02/07 12:44:19 1.17 @@ -742,10 +742,22 @@ ;; reasonable timestamp. :timestamp 0))))))))) -(defmethod %set-port-keyboard-focus ((port gtkairo-port) focus &key timestamp) - (declare (ignore timestamp)) +(defmethod port-frame-keyboard-input-focus ((port gtkairo-port) frame) (with-gtk () - (gtk_widget_grab_focus (mirror-widget (sheet-mirror focus))))) + (let* ((sheet (frame-top-level-sheet frame)) + (mirror (climi::port-lookup-mirror port sheet)) + (widget (gtk_window_get_focus (mirror-window mirror)))) + (if (cffi:null-pointer-p widget) + nil + (widget->sheet widget port))))) + +(defmethod (setf port-frame-keyboard-input-focus) + (focus (port gtkairo-port) frame) + (with-gtk () + ;; could use gtk_window_set_focus here for symmetry, but we don't + ;; have to. + (gtk_widget_grab_focus (mirror-widget (sheet-mirror focus)))) + focus) (defmethod port-force-output ((port gtkairo-port)) (with-gtk () From crhodes at common-lisp.net Wed Feb 7 12:44:21 2007 From: crhodes at common-lisp.net (crhodes) Date: Wed, 7 Feb 2007 07:44:21 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070207124421.8877D4B054@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv16608/Drei Modified Files: drei-clim.lisp Log Message: New click-to-focus policy for text-editor gadgets and panes, implemented for the CLX, Null and gtkairo backends (but gtk_window_get_focus() hand-inserted into gtkairo/ffi.lisp). PORT-KEYBOARD-INPUT-FOCUS is now a trampoline to PORT-FRAME-KEYBOARD-INPUT-FOCUS, a per-port function to set the keyboard focus for a particular frame. Not implemented for Beagle or OpenGL backends. Now Drei / Goatee gadgets don't have to do their own keyboard focus handling on arm/disarm any more. Various kludges sprinkled all over the place to make this so. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/01/17 11:43:51 1.16 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/02/07 12:44:20 1.17 @@ -206,8 +206,6 @@ ;;; updating is done after a command has been executed, and only then ;;; (or by commands at their own discretion). (defclass drei-gadget-pane (drei-pane value-gadget action-gadget - #+(or mcclim building-mcclim) ; No idea how it works in classic CLIM. - climi::enter/exit-arms/disarms-mixin asynchronous-command-processor) ((%currently-processing :initform nil :accessor currently-processing-p) @@ -251,21 +249,13 @@ (gadget-id gadget) new-value))) -;; It's really silly that we have to manage keyboard input focus -;; ourself. (defmethod armed-callback :after ((gadget drei-gadget-pane) client id) (declare (ignore client id)) - (let ((port (port gadget))) - (setf (previous-focus gadget) (port-keyboard-input-focus port)) - (setf (port-keyboard-input-focus port) gadget)) (setf (active gadget) t) (display-drei gadget)) (defmethod disarmed-callback :after ((gadget drei-gadget-pane) client id) (declare (ignore client id)) - (let ((port (port gadget))) - (setf (port-keyboard-input-focus port) (previous-focus gadget)) - (setf (previous-focus gadget) nil)) (setf (active gadget) nil) (display-drei gadget)) @@ -320,6 +310,13 @@ (let ((*standard-input* (or *minibuffer* *standard-input*))) (handle-gesture gadget gesture)))))))) +(defmethod handle-event :before + ((gadget drei-gadget-pane) (event pointer-button-press-event)) + (let ((previous (stream-set-input-focus gadget))) + (when (and previous (typep previous 'gadget)) + (disarmed-callback previous (gadget-client previous) (gadget-id previous))) + (armed-callback gadget (gadget-client gadget) (gadget-id gadget)))) + (defmethod invoke-accepting-from-user ((drei drei-gadget-pane) (continuation function)) ;; When an `accept' is called during the execution of a command for ;; the Drei gadget, we must deactivate the gadget in order to not From crhodes at common-lisp.net Wed Feb 7 12:44:22 2007 From: crhodes at common-lisp.net (crhodes) Date: Wed, 7 Feb 2007 07:44:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20070207124422.183F14C012@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv16608/ESA Modified Files: esa.lisp Log Message: New click-to-focus policy for text-editor gadgets and panes, implemented for the CLX, Null and gtkairo backends (but gtk_window_get_focus() hand-inserted into gtkairo/ffi.lisp). PORT-KEYBOARD-INPUT-FOCUS is now a trampoline to PORT-FRAME-KEYBOARD-INPUT-FOCUS, a per-port function to set the keyboard focus for a particular frame. Not implemented for Beagle or OpenGL backends. Now Drei / Goatee gadgets don't have to do their own keyboard focus handling on arm/disarm any more. Various kludges sprinkled all over the place to make this so. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2006/12/10 00:08:30 1.4 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/02/07 12:44:21 1.5 @@ -119,10 +119,10 @@ ;; error: there's no feedback, unlike emacs' quite nice "[no ;; match]". (loop - (handler-case - (return (call-next-method)) - (parse-error () - nil)))) + (handler-case + (with-input-focus (pane) + (return (call-next-method))) + (parse-error () nil)))) (defmethod stream-accept ((pane minibuffer-pane) type &rest args &key (view (stream-default-view pane)) From crhodes at common-lisp.net Wed Feb 7 12:44:22 2007 From: crhodes at common-lisp.net (crhodes) Date: Wed, 7 Feb 2007 07:44:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Looks Message-ID: <20070207124422.A08375002B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Looks In directory clnet:/tmp/cvs-serv16608/Looks Modified Files: pixie.lisp Log Message: New click-to-focus policy for text-editor gadgets and panes, implemented for the CLX, Null and gtkairo backends (but gtk_window_get_focus() hand-inserted into gtkairo/ffi.lisp). PORT-KEYBOARD-INPUT-FOCUS is now a trampoline to PORT-FRAME-KEYBOARD-INPUT-FOCUS, a per-port function to set the keyboard focus for a particular frame. Not implemented for Beagle or OpenGL backends. Now Drei / Goatee gadgets don't have to do their own keyboard focus handling on arm/disarm any more. Various kludges sprinkled all over the place to make this so. --- /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2007/02/05 03:31:59 1.19 +++ /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2007/02/07 12:44:22 1.20 @@ -1098,18 +1098,6 @@ (display-gadget-background pane (gadget-current-color pane) 0 0 (- x2 x1) (- y2 y1)) (goatee::redisplay-all (area pane)))))) -(defmethod armed-callback :after ((gadget pixie-text-field-pane) client id) - (declare (ignore client id)) - (let ((port (port gadget))) - (setf (previous-focus gadget) (port-keyboard-input-focus port)) - (setf (port-keyboard-input-focus port) gadget))) - -(defmethod disarmed-callback :after ((gadget pixie-text-field-pane) client id) - (declare (ignore client id)) - (let ((port (port gadget))) - (setf (port-keyboard-input-focus port) (previous-focus gadget)) - (setf (previous-focus gadget) nil))) - (defmethod handle-event ((gadget pixie-text-field-pane) (event key-press-event)) (let ((gesture (convert-to-gesture event)) (*activation-gestures* *standard-activation-gestures*)) From pscott at common-lisp.net Thu Feb 8 05:12:34 2007 From: pscott at common-lisp.net (pscott) Date: Thu, 8 Feb 2007 00:12:34 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Inspector Message-ID: <20070208051234.5400E5B062@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv21361/Apps/Inspector Modified Files: inspector.lisp Log Message: Added much snazzy eye candy for people dealing with hash tables. Hash tables are now displayed in a pretty graphical format which shows how much of the array is used and how far it is to the rehash threshold. --- /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2005/09/13 11:07:40 1.33 +++ /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2007/02/08 05:12:33 1.34 @@ -90,7 +90,7 @@ (defmethod inspect-object :around (object pane) (cond ((member object *inspected-objects*) (with-output-as-presentation - (pane object (presentation-type-of object)) + (pane object (presentation-type-of object)) (princ "===" pane))) ; Prevent infinite loops ((not (gethash object (dico *application-frame*))) (inspect-object-briefly object pane)) @@ -113,7 +113,7 @@ (defmethod inspect-object (object pane) (with-output-as-presentation - (pane object (presentation-type-of object)) + (pane object (presentation-type-of object)) (prin1 object pane))) @@ -124,7 +124,7 @@ (define-presentation-type long-list-tail () :inherit-from t) -(define-presentation-method present (object (type settable-slot) +(define-presentation-method present (object (type settable-slot) stream (view textual-view) &key acceptably for-context-type) @@ -417,21 +417,45 @@ (inspect-cons-as-cells object pane) (inspect-cons-as-list object pane))) +(defun show-hash-table-status (hash pane &key (message "Usage Graph")) + "Show a hash table's status graphically on a given +pane. Display a given message, which defaults to 'Usage Graph'." + (with-room-for-graphics (pane :height 20) + (let* ((my-beige (make-rgb-color 0.9372549 0.8862745 0.8862745)) + (used-color (make-rgb-color 0.43529412 0.7921569 0.87058824)) + (text-color (make-rgb-color 0.7176471 0.29803923 0.2)) + (pattern (make-rectangular-tile + (make-pattern #2A((0 1 0 0 0) + (1 0 0 0 0) + (0 0 0 0 1) + (0 0 0 1 0) + (0 0 1 0 0)) + (list my-beige +black+)) 5 5))) + (draw-rectangle* pane 0 0 150 20 :filled t :ink my-beige) + (draw-rectangle* pane 0 0 (* 150 (/ (hash-table-count hash) + (hash-table-size hash))) + 20 :filled t :ink used-color :line-thickness 0) + (draw-rectangle* pane (* 150 (hash-table-rehash-threshold hash)) 0 150 20 + :filled t :ink pattern :line-thickness 0) + (draw-rectangle* pane 0 0 150 20 :filled nil :ink +black+) + (draw-text* pane message 7 10 :align-y :center :align-x :left + :text-size :small :ink text-color :text-face :italic)))) (defmethod inspect-object-briefly ((object hash-table) pane) (with-output-as-presentation (pane object (presentation-type-of object)) - (princ 'hash-table pane))) + (show-hash-table-status object pane :message "Hash table"))) (defmethod inspect-object ((object hash-table) pane) (inspector-table (object pane) - (format pane "~A (test: ~A)" 'hash-table (hash-table-test object)) + (progn (format pane "~A (test: ~A)" 'hash-table (hash-table-test object)) + (show-hash-table-status object pane)) (loop for key being the hash-keys of object - do (formatting-row (pane) - (formatting-cell (pane :align-x :right) - (inspect-object key pane)) - (formatting-cell (pane) (princ "=" pane)) - (formatting-cell (pane) - (inspect-object (gethash key object) pane)))))) + do (formatting-row (pane) + (formatting-cell (pane :align-x :right) + (inspect-object key pane)) + (formatting-cell (pane) (princ "=" pane)) + (formatting-cell (pane) + (inspect-object (gethash key object) pane)))))) (defmethod inspect-object ((object generic-function) pane) (inspector-table (object pane) From pscott at common-lisp.net Thu Feb 8 05:47:46 2007 From: pscott at common-lisp.net (pscott) Date: Thu, 8 Feb 2007 00:47:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Inspector Message-ID: <20070208054746.7306F650E0@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv25884 Modified Files: inspector.lisp Log Message: * Cosmetic improvement to hash table display * Added horrible hack to fix bug with display of generic functions. I have no idea why this is even necessary, and I find myself QUITE UNNERVED that I'm even writing it. It shouldn't break anything, though! Probably! --- /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2007/02/08 05:12:33 1.34 +++ /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2007/02/08 05:47:46 1.35 @@ -447,7 +447,7 @@ (show-hash-table-status object pane :message "Hash table"))) (defmethod inspect-object ((object hash-table) pane) (inspector-table (object pane) - (progn (format pane "~A (test: ~A)" 'hash-table (hash-table-test object)) + (progn (format pane "~A (test: ~A) " 'hash-table (hash-table-test object)) (show-hash-table-status object pane)) (loop for key being the hash-keys of object do (formatting-row (pane) @@ -879,4 +879,10 @@ (fboundp object) (tracedp object)))) (object) - (list object)) \ No newline at end of file + (list object)) + +;; FIXME: This is a horrible hack to gloss over issues that I don't +;; properly understand. See +;; +(defmethod clim:presentation-type-of ((object standard-generic-function)) + 'clim:expression) \ No newline at end of file From pscott at common-lisp.net Thu Feb 8 05:50:02 2007 From: pscott at common-lisp.net (pscott) Date: Thu, 8 Feb 2007 00:50:02 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Inspector Message-ID: <20070208055002.E9FFE6A004@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv26056 Modified Files: test.lisp Log Message: Added political correctness. This file was originally for my own use only, and it got committed to the CVS repository by accident. Now that it's here, I've decided to clean it up a little bit. To that end, I also added a comment explaining what the file is for. --- /project/mcclim/cvsroot/mcclim/Apps/Inspector/test.lisp 2005/03/11 21:25:29 1.1 +++ /project/mcclim/cvsroot/mcclim/Apps/Inspector/test.lisp 2007/02/08 05:50:02 1.2 @@ -1,3 +1,7 @@ +;; This is a test file which doesn't properly test anything. It just +;; has a bunch of code which may occasionally be useful for testing +;; Clouseau, if you squint at it. All data dictated by wild whims. + (in-package :clouseau) (defclass oddity () @@ -17,8 +21,8 @@ (defstruct historical-event (severity 5 :type (integer 0 10)) - (tragedy "" :type string) - (farce "" :type string)) + (attribute "" :type string) + (pirate "" :type string)) (defclass packrat (queer-oddity salad-mixin) ((name :initform "Willy the Packrat" @@ -30,9 +34,9 @@ (an-array :initform #2A((1 0 0) (0 1 0) (0 0 1)) :documentation "An identity matrix") (global-fun :initform #'inspector) - (creationism :initform (make-historical-event :severity 7 - :tragedy "Scopes monkey trial" - :farce "ID Creationism")) + (reunion :initform (make-historical-event :severity 7 + :attribute "Sephiroth!" + :pirate "Sephiroth?")) (l :initform #'(lambda (x) (declare (number x)) (1+ x))) From thenriksen at common-lisp.net Sat Feb 10 21:32:22 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 10 Feb 2007 16:32:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20070210213222.13F247C017@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv15654/Doc Modified Files: ex3.lisp Log Message: Made the `string' present method respect the :accept keyword argument, updated an example program to exploit this. --- /project/mcclim/cvsroot/mcclim/Doc/ex3.lisp 2004/07/22 12:05:24 1.1 +++ /project/mcclim/cvsroot/mcclim/Doc/ex3.lisp 2007/02/10 21:32:21 1.2 @@ -21,9 +21,11 @@ (define-superapp-command (com-quit :name t) () (frame-exit *application-frame*)) -(define-presentation-type name-of-month ()) +(define-presentation-type name-of-month () + :inherit-from 'string) -(define-presentation-type day-of-month ()) +(define-presentation-type day-of-month () + :inherit-from 'integer) (define-superapp-command (com-out :name t) () (with-output-as-presentation (t "The third month" 'name-of-month) From thenriksen at common-lisp.net Sat Feb 10 21:32:22 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 10 Feb 2007 16:32:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070210213222.4F69047081@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv15654 Modified Files: presentation-defs.lisp Log Message: Made the `string' present method respect the :accept keyword argument, updated an example program to exploit this. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/02/05 03:06:14 1.70 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/02/10 21:32:22 1.71 @@ -1618,8 +1618,10 @@ (define-presentation-method present (object (type string) stream (view textual-view) &key acceptably for-context-type) - (declare (ignore acceptably for-context-type)) - (princ object stream)) + (declare (ignore for-context-type)) + (if acceptably + (prin1 object stream) + (princ object stream))) (define-presentation-method accept ((type string) stream (view textual-view) &key (default nil defaultp) From thenriksen at common-lisp.net Mon Feb 12 19:32:57 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 12 Feb 2007 14:32:57 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20070212193257.08CC9581BB@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv27220/Tests Modified Files: core-tests.lisp Log Message: Improved `delete-indentation', now does the intuitive thing. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2007/02/12 19:32:57 1.2 @@ -363,6 +363,28 @@ (buffer-is #. (format nil "~A~A~A~A~A I am to be indented" #\Tab #\Tab #\Tab #\Tab #\Tab))))) +(test delete-indentation + (with-drei-environment (:initial-contents "") + (delete-indentation *current-syntax* *current-point*) + (buffer-is "")) + (with-drei-environment (:initial-contents "Foo") + (delete-indentation *current-syntax* *current-point*) + (buffer-is "Foo")) + (with-drei-environment (:initial-contents " Foo") + (delete-indentation *current-syntax* *current-point*) + (buffer-is "Foo")) + (with-drei-environment (:initial-contents " Foo ") + (delete-indentation *current-syntax* *current-point*) + (buffer-is "Foo ")) + (with-drei-environment (:initial-contents " Foo + Bar + Baz") + (forward-line *current-point* *current-syntax*) + (delete-indentation *current-syntax* *current-point*) + (buffer-is " Foo +Bar + Baz"))) + (test set-syntax (dolist (syntax-designator `("Lisp" drei-lisp-syntax::lisp-syntax ,(find-class 'drei-lisp-syntax::lisp-syntax))) From thenriksen at common-lisp.net Mon Feb 12 19:32:58 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 12 Feb 2007 14:32:58 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070212193258.888A25B071@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27220 Modified Files: core.lisp core-commands.lisp Log Message: Improved `delete-indentation', now does the intuitive thing. --- /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/01/14 17:57:01 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/02/12 19:32:58 1.4 @@ -285,19 +285,19 @@ (defmethod indent-line ((mark right-sticky-mark) indentation tab-width) (indent-line* mark indentation tab-width nil)) -(defun delete-indentation (mark) - (beginning-of-line mark) - (unless (beginning-of-buffer-p mark) - (delete-range mark -1) - (loop until (end-of-buffer-p mark) - while (buffer-whitespacep (object-after mark)) - do (delete-range mark 1)) - (loop until (beginning-of-buffer-p mark) - while (buffer-whitespacep (object-before mark)) - do (delete-range mark -1)) - (when (and (not (beginning-of-buffer-p mark)) - (constituentp (object-before mark))) - (insert-object mark #\Space)))) +(defgeneric delete-indentation (syntax mark) + (:documentation "Delete all indentation in the line of `mark' +with the whitespace rules of `syntax'. The default method just +removes leading whitespace characters.")) + +(defmethod delete-indentation ((syntax syntax) (mark mark)) + (let ((working-mark (clone-mark mark))) + (beginning-of-line working-mark) + (let ((end-offset (loop for offset from (offset working-mark) below (size *current-buffer*) + unless (whitespacep syntax (buffer-object *current-buffer* offset)) + return offset))) + (when end-offset + (delete-region working-mark end-offset))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2006/11/14 10:31:37 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2007/02/12 19:32:58 1.4 @@ -257,7 +257,7 @@ the current line, and point after that space. If there is no previous non-blank line, deletes all whitespace at the beginning of the buffer at leaves point there." - (delete-indentation *current-point*)) + (delete-indentation *current-syntax* *current-point*)) (set-key 'com-delete-indentation 'indent-table From thenriksen at common-lisp.net Tue Feb 13 12:14:12 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 13 Feb 2007 07:14:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20070213121412.0BCEA4D04C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv26101/Tests Modified Files: core-tests.lisp base-tests.lisp Log Message: Fixed `delete-indentation', added `join-line' and exported some more symbols from DREI-LISP-SYNTAX. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2007/02/12 19:32:57 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2007/02/13 12:14:11 1.3 @@ -383,7 +383,54 @@ (delete-indentation *current-syntax* *current-point*) (buffer-is " Foo Bar - Baz"))) + Baz")) + (with-drei-environment (:initial-contents " +foo bar") + (let ((start (clone-mark (point *current-window*))) + (end (clone-mark (point *current-window*))) + (orig-contents (buffer-contents))) + (beginning-of-buffer start) + (end-of-buffer end) + (do-buffer-region-lines (line start end) + (delete-indentation *current-syntax* line)) + (buffer-is orig-contents)))) + +(test join-line + (with-drei-environment (:initial-contents " + climacs ") + (let ((m (clone-mark *current-point* :left))) + (setf (offset m) 3) + (join-line *current-syntax* m) + (is (= (offset m) 0)) + (buffer-is "climacs "))) + (with-drei-environment (:initial-contents " + climacs ") + (let ((m (clone-mark *current-point* :right))) + (setf (offset m) 7) + (join-line *current-syntax* m) + (is (= (offset m) 0)) + (buffer-is "climacs "))) + (with-drei-environment (:initial-contents " climacs ") + (let ((m (clone-mark *current-point* :left))) + (setf (offset m) 7) + (join-line *current-syntax* m) + (is (= (offset m) 0)) + (buffer-is " climacs "))) + (with-drei-environment (:initial-contents "climacs + climacs ") + (let ((m (clone-mark *current-point* :right))) + (setf (offset m) 12) + (join-line *current-syntax* m) + (is (= (offset m) 8)) + (buffer-is "climacs climacs "))) + (with-drei-environment (:initial-contents " + + climacs ") + (let ((m (clone-mark *current-point* :right))) + (setf (offset m) 12) + (join-line *current-syntax* m) + (is (= (offset m) 0)) + (buffer-is "climacs ")))) (test set-syntax (dolist (syntax-designator `("Lisp" drei-lisp-syntax::lisp-syntax --- /project/mcclim/cvsroot/mcclim/Drei/Tests/base-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/base-tests.lisp 2007/02/13 12:14:11 1.2 @@ -607,53 +607,6 @@ (is (string= (buffer-contents buffer) #.(format nil "~A climacs " #\Tab)))))) -(buffer-test delete-indentation - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 " - climacs ") - (let ((m (clone-mark (low-mark buffer) :left))) - (setf (offset m) 3) - (delete-indentation m) - (is (= (offset m) 0)) - (is (string= (buffer-contents buffer) - "climacs "))) - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 " - climacs ") - (let ((m (clone-mark (low-mark buffer) :right))) - (setf (offset m) 7) - (delete-indentation m) - (is (= (offset m) 0)) - (is (string= (buffer-contents buffer) - "climacs ")))) - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 " climacs ") - (let ((m (clone-mark (low-mark buffer) :left))) - (setf (offset m) 7) - (delete-indentation m) - (is (= (offset m) 0)) - (is (string= (buffer-contents buffer) - " climacs ")))) - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 "climacs - climacs ") - (let ((m (clone-mark (low-mark buffer) :right))) - (setf (offset m) 12) - (delete-indentation m) - (is (= (offset m) 8)) - (is (string= (buffer-contents buffer) - "climacs climacs ")))) - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 " - - climacs ") - (let ((m (clone-mark (low-mark buffer) :right))) - (setf (offset m) 12) - (delete-indentation m) - (is (= (offset m) 0)) - (is (string= (buffer-contents buffer) - "climacs ")))))) - (buffer-test buffer-looking-at (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs ") From thenriksen at common-lisp.net Tue Feb 13 12:14:12 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 13 Feb 2007 07:14:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070213121412.705FE4E008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv26101 Modified Files: packages.lisp core.lisp Log Message: Fixed `delete-indentation', added `join-line' and exported some more symbols from DREI-LISP-SYNTAX. --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/01/15 11:35:54 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/02/13 12:14:12 1.13 @@ -410,6 +410,7 @@ #:indent-region #:fill-line #:fill-region #:indent-line #:delete-indentation + #:join-line #:set-syntax #:*killed-rectangle* @@ -445,7 +446,8 @@ #:edit-definition #:form #:form-to-object - #:form-conversion-error) + #:form-conversion-error + #:forward-one-list #:backward-one-list #:forward-list #:backward-list) (:shadow clim:form) (:documentation "Implementation of the syntax module used for editing Common Lisp code.")) --- /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/02/12 19:32:58 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/02/13 12:14:12 1.5 @@ -294,11 +294,33 @@ (let ((working-mark (clone-mark mark))) (beginning-of-line working-mark) (let ((end-offset (loop for offset from (offset working-mark) below (size *current-buffer*) - unless (whitespacep syntax (buffer-object *current-buffer* offset)) + for buffer-object = (buffer-object *current-buffer* offset) + until (char= buffer-object #\Newline) + unless (whitespacep syntax buffer-object) return offset))) (when end-offset (delete-region working-mark end-offset))))) +(defgeneric join-line (syntax mark) + (:documentation "Join the line that `mark' is in to the +previous line, and remove whitespace objects at the join +point. `Syntax' is used for judging what a whitespace character +is.")) + +(defmethod join-line ((syntax syntax) (mark mark)) + (beginning-of-line mark) + (unless (beginning-of-buffer-p mark) + (delete-range mark -1) + (loop until (end-of-buffer-p mark) + while (whitespacep syntax (object-after mark)) + do (delete-range mark 1)) + (loop until (beginning-of-buffer-p mark) + while (whitespacep syntax (object-before mark)) + do (delete-range mark -1)) + (when (and (not (beginning-of-buffer-p mark)) + (constituentp (object-before mark))) + (insert-object mark #\Space)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Syntax handling From thenriksen at common-lisp.net Sat Feb 17 17:54:06 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 17 Feb 2007 12:54:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20070217175406.A1DDC50021@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv13162/Tests Modified Files: testing.lisp motion-tests.lisp lisp-syntax-tests.lisp Log Message: Tightened the nuts and bolts of Lisp syntax and added a bunch of tests to make relatively sure there are no regressions. No tests for Swine yet, but "it seems to work". Also fixes very major performance issue with redisplay of literal objects in Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2007/01/15 11:35:53 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2007/02/17 17:54:06 1.4 @@ -76,8 +76,7 @@ (begin-offset 0) (end-offset (size buffer))) "Check (using FiveAM) whether `buffer' contains `string' in the subsequence delimited by `begin-offset' and `end-offset'." - (is (string= (buffer-substring buffer begin-offset end-offset) - string))) + (is (string= string (buffer-substring buffer begin-offset end-offset)))) (defclass test-drei (drei) () --- /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2007/02/17 17:54:06 1.2 @@ -1,8 +1,7 @@ ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- -;;; (c) copyright 2005 by +;;; (c) copyright 2005-2007 by ;;; Aleksandar Bakic (a_bakic at yahoo.com) -;;; (c) copyright 2006 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or @@ -94,18 +93,18 @@ backward-end-offset (offset goal-forward-offset goal-backward-offset) initial-contents - &key (syntax ''drei-fundamental-syntax:fundamental-syntax))) - (check-type forward-begin-offset integer) - (check-type backward-end-offset integer) + &key (syntax 'drei-fundamental-syntax:fundamental-syntax))) + (check-type forward-begin-offset (or integer null)) + (check-type backward-end-offset (or integer null)) (check-type offset integer) (check-type goal-forward-offset integer) (check-type goal-backward-offset integer) (let ((forward (intern (format nil "FORWARD-ONE-~S" unit))) (backward (intern (format nil "BACKWARD-ONE-~S" unit)))) `(progn - (test ,forward + (test ,(intern (format nil "~A-~A" syntax forward)) (with-buffer (buffer :initial-contents ,initial-contents - :syntax ,syntax) + :syntax ',syntax) (let ((syntax (syntax buffer)) (m0l (clone-mark (low-mark buffer) :left)) (m0r (clone-mark (low-mark buffer) :right)) @@ -119,21 +118,25 @@ (offset m1r) ,offset (offset m2l) (size buffer) (offset m2r) (size buffer)) - (is-true (,forward m0l syntax)) - (is (= (offset m0l) ,forward-begin-offset)) - (is-true (,forward m0r syntax)) - (is (= (offset m0r) ,forward-begin-offset)) + ,(when forward-begin-offset + `(progn + (is-true (,forward m0l syntax)) + (is (= ,forward-begin-offset (offset m0l))))) + ,(when backward-end-offset + `(progn + (is-true (,forward m0r syntax)) + (is (= ,forward-begin-offset (offset m0r))))) (is-true (,forward m1l syntax)) - (is (= (offset m1l) ,goal-forward-offset)) + (is (= ,goal-forward-offset (offset m1l))) (is-true (,forward m1r syntax)) - (is (= (offset m1r) ,goal-forward-offset)) + (is (= ,goal-forward-offset (offset m1r))) (is-false (,forward m2l syntax)) - (is (= (offset m2l) (size buffer))) + (is (= (size buffer) (offset m2l))) (is-false (,forward m2r syntax)) - (is (= (offset m2r) (size buffer)))))) - (test ,backward + (is (= (size buffer) (offset m2r)))))) + (test ,(intern (format nil "~A-~A" syntax backward)) (with-buffer (buffer :initial-contents ,initial-contents - :syntax ,syntax) + :syntax ',syntax) (let ((syntax (syntax buffer)) (m0l (clone-mark (low-mark buffer) :left)) (m0r (clone-mark (low-mark buffer) :right)) @@ -148,17 +151,21 @@ (offset m2l) (size buffer) (offset m2r) (size buffer)) (is-false (,backward m0l syntax)) - (is (= (offset m0l) 0)) + (is (= 0 (offset m0l))) (is-false (,backward m0r syntax)) - (is (= (offset m0r) 0)) + (is (= 0 (offset m0r))) (is-true (,backward m1l syntax)) - (is (= (offset m1l) ,goal-backward-offset)) + (is (= ,goal-backward-offset (offset m1l))) (is-true (,backward m1r syntax)) - (is (= (offset m1r) ,goal-backward-offset)) - (is-true (,backward m2l syntax)) - (is (= (offset m2l) ,backward-end-offset)) - (is-true (,backward m2r syntax)) - (is (= (offset m2r) ,backward-end-offset)))))))) + (is (= ,goal-backward-offset (offset m1r))) + ,(when backward-end-offset + `(progn + (is-true (,backward m2l syntax)) + (is (= ,backward-end-offset (offset m2l))))) + ,(when backward-end-offset + `(progn + (is-true (,backward m2r syntax)) + (is (= ,backward-end-offset (offset m2r))))))))))) (motion-fun-one-test word (9 10 (5 9 2) " climacs --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/01/31 14:31:59 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/02/17 17:54:06 1.4 @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- -;;; (c) copyright 2006 by +;;; (c) copyright 2006-2007 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or @@ -21,7 +21,11 @@ (cl:in-package :drei-tests) (def-suite lisp-syntax-tests :description "The test suite for -tests related to the Lisp syntax module.") +tests related to the Lisp syntax module. The parser is not +explicitly tested. Instead, it is hoped that any defects will be +caught by other test cases, all of which depend on correct +parsing. Also, redisplay is not tested, because no-one has any +idea how to do it.") (in-suite lisp-syntax-tests) @@ -32,16 +36,22 @@ parser result and re-run the test suite (except for this self-compilation test, of course).") -(defmacro testing-lisp-syntax ((buffer-contents) &body body) - `(with-buffer (buffer :initial-contents ,buffer-contents - :syntax 'lisp-syntax) - (flet ((get-object (&rest args) - (apply #'form-to-object (syntax buffer) - (first (drei-lisp-syntax::children - (slot-value (syntax buffer) - 'drei-lisp-syntax::stack-top))) - args))) - , at body))) +(defmacro testing-lisp-syntax ((buffer-contents &rest options) &body body) + (assert (evenp (length options))) + (with-gensyms (buffer drei) + `(with-buffer (,buffer :initial-contents ,buffer-contents :syntax 'lisp-syntax) + ,@(loop for (option value) on options by #'cddr + collecting `(eval-option (syntax ,buffer) ,option ,value)) + (let ((,drei (make-instance 'test-drei :buffer ,buffer))) + (with-bound-drei-special-variables (,drei :minibuffer nil) + (labels ((get-form () + (first (drei-lisp-syntax::children + (slot-value *current-syntax* + 'drei-lisp-syntax::stack-top)))) + (get-object (&rest args) + (apply #'form-to-object *current-syntax* + (get-form) args))) + , at body)))))) (defmacro testing-symbol ((sym-sym &rest args) &body body) `(let ((,sym-sym (get-object , at args))) @@ -55,171 +65,285 @@ (defmacro testing-lisp-syntax-symbol ((buffer-contents sym-sym &rest args) &body body) - `(with-buffer (buffer :initial-contents ,buffer-contents - :syntax 'lisp-syntax) + `(testing-lisp-syntax (,buffer-contents) (flet ((get-object (&rest args) - (apply #'form-to-object (syntax buffer) + (apply #'form-to-object *current-syntax* (first (drei-lisp-syntax::children - (slot-value (syntax buffer) + (slot-value *current-syntax* 'drei-lisp-syntax::stack-top))) args))) (testing-symbol (,sym-sym , at args) , at body)))) +(test lisp-syntax-test-base + "Test the Base syntax attribute for Lisp syntax." + (testing-lisp-syntax ("") + (is (= *read-base* (drei-lisp-syntax::base *current-syntax*)))) + (testing-lisp-syntax ("" :base "2") + (is (= 2 (drei-lisp-syntax::base *current-syntax*)))) + (testing-lisp-syntax ("" :base "36") + (is (= 36 (drei-lisp-syntax::base *current-syntax*)))) + (testing-lisp-syntax ("" :base "1") ; Should be ignored. + (is (= *read-base* (drei-lisp-syntax::base *current-syntax*)))) + (testing-lisp-syntax ("" :base "37") ; Should be ignored. + (is (= *read-base* (drei-lisp-syntax::base *current-syntax*))))) + +(test lisp-syntax-test-package + "Test the Package syntax attribute for Lisp syntax." + (testing-lisp-syntax ("") + (is (eq nil (drei-lisp-syntax::option-specified-package *current-syntax*)))) + (testing-lisp-syntax ("" :package "COMMON-LISP") + (is (eq (find-package :cl) + (drei-lisp-syntax::option-specified-package *current-syntax*)))) + (testing-lisp-syntax ("" :package "CL") + (is (eq (find-package :cl) + (drei-lisp-syntax::option-specified-package *current-syntax*)))) + (testing-lisp-syntax ("" :package "common-lisp") + (is (string= "common-lisp" + (drei-lisp-syntax::option-specified-package *current-syntax*))))) + +(test lisp-syntax-test-attributes + "Test that the syntax attributes of Lisp syntax are returned +properly." + (testing-lisp-syntax ("") + (is-true (assoc :package (current-attributes-for-syntax *current-syntax*))) + (is-true (assoc :base (current-attributes-for-syntax *current-syntax*))))) + +(test lisp-syntax-package-at-mark + "Test that Lisp syntax' handling of (in-package) forms is +correct." + (testing-lisp-syntax ("(in-package :cl-user) ") + (is (eq *package* + (drei-lisp-syntax::package-at-mark *current-syntax* 10)))) + (testing-lisp-syntax ("(in-package :cl-user) " :package "DREI-LISP-SYNTAX") + (is (eq (find-package :drei-lisp-syntax) + (drei-lisp-syntax::package-at-mark *current-syntax* 10)))) + (testing-lisp-syntax ("(in-package :cl-user) ") + (is (eq (find-package :cl-user) + (drei-lisp-syntax::package-at-mark *current-syntax* 23)))) + (testing-lisp-syntax ("(in-package \"CL-USER\") ") + (is (eq (find-package :cl-user) + (drei-lisp-syntax::package-at-mark *current-syntax* 23)))) + (testing-lisp-syntax ("(in-package \"cl-user\") ") + (is (eq *package* + (drei-lisp-syntax::package-at-mark *current-syntax* 23)))) + (testing-lisp-syntax ("(in-package :cl-user)(in-package :clim) ") + (is (eq (find-package :clim) + (drei-lisp-syntax::package-at-mark *current-syntax* 43)))) + (testing-lisp-syntax ("(in-package :cl-user)(in-package :iDoNotExist) ") + (is (eq (find-package :cl-user) + (drei-lisp-syntax::package-at-mark *current-syntax* 43))))) + +(test lisp-syntax-provided-package-name-at-mark + "Test that Lisp syntax' handling of (in-package) forms is +correct, even counting packages that cannot be found." + (testing-lisp-syntax ("(in-package :cl-user) ") + (is (string= "CLIM-USER" + (drei-lisp-syntax::provided-package-name-at-mark *current-syntax* 10)))) + (testing-lisp-syntax ("(in-package :cl-user) " :package "DREI-LISP-SYNTAX") + (is (string= "DREI-LISP-SYNTAX" + (drei-lisp-syntax::provided-package-name-at-mark *current-syntax* 10)))) + (testing-lisp-syntax ("(in-package :cl-user) ") + (is (string= "CL-USER" + (drei-lisp-syntax::provided-package-name-at-mark *current-syntax* 23)))) + (testing-lisp-syntax ("(in-package \"CL-USER\") ") + (is (string= "CL-USER" + (drei-lisp-syntax::provided-package-name-at-mark *current-syntax* 23)))) + (testing-lisp-syntax ("(in-package \"cl-user\") ") + (is (string= "cl-user" + (drei-lisp-syntax::provided-package-name-at-mark *current-syntax* 23)))) + (testing-lisp-syntax ("(in-package :cl-user)(in-package :clim) ") + (is (string= "CLIM" + (drei-lisp-syntax::provided-package-name-at-mark *current-syntax* 43)))) + (testing-lisp-syntax ("(in-package :cl-user)(in-package :iDoNotExist) ") + (is (string= "IDONOTEXIST" + (drei-lisp-syntax::provided-package-name-at-mark *current-syntax* 48))))) + +(test lisp-syntax-need-to-update-package-list-p + "Test that Lisp syntax can properly handle it when (in-package) + forms change." + (testing-lisp-syntax ("(in-package :cl-user) ") + (is (eq (find-package :cl-user) + (drei-lisp-syntax::package-at-mark *current-syntax* 23))) + (delete-buffer-range *current-buffer* 0 (size *current-buffer*)) + (insert-buffer-sequence *current-buffer* 0 "(in-package :cl-userr) ") + (update-syntax *current-buffer* *current-syntax*) + (is (eq *package* + (drei-lisp-syntax::package-at-mark *current-syntax* 24))) + (insert-buffer-sequence *current-buffer* 24 "(in-package :drei-lisp-syntax) ") + (update-syntax *current-buffer* *current-syntax*) + (is (eq (find-package :drei-lisp-syntax) + (drei-lisp-syntax::package-at-mark *current-syntax* 54))) + (delete-buffer-range *current-buffer* 0 23) + (insert-buffer-sequence *current-buffer* 0 "(in-package :clim-user)") + (update-syntax *current-buffer* *current-syntax*) + (is (eq (find-package :clim-user) + (drei-lisp-syntax::package-at-mark *current-syntax* 26))))) + (test form-to-object-1 + "Test that we can parse and recognize T in Lisp syntax." (testing-lisp-syntax ("T") - (is (eq (get-object) t))) + (is (eq t (get-object)))) (testing-lisp-syntax ("t") - (is (eq (get-object) t)))) + (is (eq t (get-object))))) (test form-to-object-2 + "Test that casing is properly done for NIL." (testing-lisp-syntax ("nil") - (is (eq (get-object) nil))) + (is (eq nil (get-object)))) (testing-lisp-syntax ("NIL") - (is (eq (get-object) nil))) + (is (eq nil (get-object)))) (testing-lisp-syntax ("NIl") - (is (eq (get-object) nil))) + (is (eq nil (get-object)))) (testing-lisp-syntax ("NIl") - (is-false (eq (get-object :case :preserve) nil)))) + (is-false (eq nil (get-object :case :preserve))))) (test form-to-object-3 + "Test case-conversion for tokens." (testing-lisp-syntax ("iDoNotExist") (testing-symbol (sym :case :upcase) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "IDONOTEXIST"))) + (is (string= "IDONOTEXIST" + (symbol-name sym)))) (testing-symbol (sym :case :preserve) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "iDoNotExist"))) + (is (string= "iDoNotExist" + (symbol-name sym)))) (testing-symbol (sym :case :downcase) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "idonotexist"))) + (is (string= "idonotexist" + (symbol-name sym)))) (testing-symbol (sym :read t :case :upcase) (is-true (symbol-package sym)) - (is (string= (symbol-name sym) - "IDONOTEXIST"))) + (is (string= "IDONOTEXIST" + (symbol-name sym)))) (testing-symbol (sym :read t :case :preserve) (is-true (symbol-package sym)) - (is (string= (symbol-name sym) - "iDoNotExist"))) + (is (string= "iDoNotExist" + (symbol-name sym)))) (testing-symbol (sym :read t :case :downcase) (is-true (symbol-package sym)) - (is (string= (symbol-name sym) - "idonotexist"))) + (is (string= "idonotexist" + (symbol-name sym)))) (testing-symbol (sym :case :invert) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "iDoNotExist")))) + (is (string= "iDoNotExist" + (symbol-name sym))))) (testing-lisp-syntax-symbol ("IDONOTEXIST" sym :case :invert) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "idonotexist"))) + (is (string= "idonotexist" + (symbol-name sym)))) (testing-lisp-syntax-symbol ("idonotexist" sym :case :invert) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "IDONOTEXIST")))) + (is (string= "IDONOTEXIST" + (symbol-name sym))))) (test form-to-object-4 + "Test case-conversion for uninterned tokens." (testing-lisp-syntax ("#:iDoNotExist") (testing-symbol (sym :case :upcase) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "IDONOTEXIST"))) + (is (string= "IDONOTEXIST" + (symbol-name sym)))) (testing-symbol (sym :case :preserve) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "iDoNotExist"))) + (is (string= "iDoNotExist" + (symbol-name sym)))) (testing-symbol (sym :case :downcase) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "idonotexist"))) + (is (string= "idonotexist" + (symbol-name sym)))) (testing-symbol (sym :case :invert) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "iDoNotExist")))) + (is (string= "iDoNotExist" + (symbol-name sym))))) (testing-lisp-syntax ("#:IDONOTEXIST") (let ((sym (get-object :case :invert))) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "idonotexist")))) + (is (string= "idonotexist" + (symbol-name sym))))) (testing-lisp-syntax ("#:idonotexist") (let ((sym (get-object :case :invert))) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "IDONOTEXIST"))))) + (is (string= "IDONOTEXIST" + (symbol-name sym)))))) (test form-to-object-5 + "Test handling of escaped symbols." (testing-lisp-syntax-symbol ("|123|" sym :read t) - (is (string= (symbol-name sym) "123"))) + (is (string= "123" (symbol-name sym)))) (testing-lisp-syntax-symbol ("|LIST|" sym :read t :case :downcase) - (is (string= (symbol-name sym) "LIST"))) + (is (string= "LIST" (symbol-name sym)))) (testing-lisp-syntax-symbol ("| |" sym :read t) - (is (string= (symbol-name sym) " "))) + (is (string= " " (symbol-name sym)))) (testing-lisp-syntax-symbol ("|foo|bar|abbabz|" sym :read t) - (is (string= (symbol-name sym) - "fooBARabbabz"))) + (is (string= "fooBARabbabz" (symbol-name sym)))) (testing-lisp-syntax-symbol ("||" sym :read t) - (is (string= (symbol-name sym) ""))) + (is (string= "" (symbol-name sym)))) (testing-lisp-syntax-symbol ("||||" sym :read t) - (is (string= (symbol-name sym) "")))) + (is (string= "" (symbol-name sym))))) (test form-to-object-6 + "Test keyword symbols." (testing-lisp-syntax-symbol (":foo" sym :read t) - (is (string= (symbol-name sym) "FOO")) - (is (eq (symbol-package sym) - (find-package :keyword))))) + (is (string= "FOO" (symbol-name sym))) + (is (eq (find-package :keyword) + (symbol-package sym))))) (test form-to-object-7 + "Test that numbers are recognized and handled properly by the +Lisp syntax." (testing-lisp-syntax ("123") - (is (= (get-object) 123))) + (is (= 123 (get-object)))) (testing-lisp-syntax ("-123") - (is (= (get-object) -123))) + (is (= -123 (get-object)))) (testing-lisp-syntax (".123") - (is (= (get-object) .123))) + (is (= .123 (get-object)))) (testing-lisp-syntax ("-.123") - (is (= (get-object) -.123))) + (is (= -.123 (get-object)))) (testing-lisp-syntax ("1.234") - (is (= (get-object) 1.234))) + (is (= 1.234 (get-object)))) (testing-lisp-syntax ("-1.234") - (is (= (get-object) -1.234))) + (is (= -1.234 (get-object)))) (testing-lisp-syntax ("1e7") - (is (= (get-object) 1e7))) + (is (= 1e7 (get-object)))) (testing-lisp-syntax ("1E7") - (is (= (get-object) 1e7))) + (is (= 1e7 (get-object)))) (testing-lisp-syntax ("1.123E7") - (is (= (get-object) 1.123e7))) + (is (= 1.123e7 (get-object)))) (testing-lisp-syntax ("-1.123E7") - (is (= (get-object) -1.123e7))) + (is (= -1.123e7 (get-object)))) (testing-lisp-syntax (".123E7") - (is (= (get-object) .123e7))) + (is (= .123e7 (get-object)))) (testing-lisp-syntax ("-.123E7") - (is (= (get-object) -.123e7))) + (is (= -.123e7 (get-object)))) (testing-lisp-syntax ("1.34e-7") - (is (= (get-object) 1.34e-7)))) + (is (= 1.34e-7 (get-object))))) (test form-to-object-8 + "Test that the standard reader macros for numbers are +recognized and handled." (testing-lisp-syntax ("#b0000") - (is (= (get-object) 0))) + (is (= 0 (get-object)))) (testing-lisp-syntax ("#b10") - (is (= (get-object) 2))) + (is (= 2 (get-object)))) (testing-lisp-syntax ("#b-10") - (is (= (get-object) -2))) + (is (= -2 (get-object)))) (testing-lisp-syntax ("#x00") - (is (= (get-object) 0))) + (is (= 0 (get-object)))) (testing-lisp-syntax ("#xFE") - (is (= (get-object) 254))) + (is (= 254 (get-object)))) (testing-lisp-syntax ("#x-FE") - (is (= (get-object) -254))) + (is (= -254 (get-object)))) (testing-lisp-syntax ("#o00") [804 lines skipped] From thenriksen at common-lisp.net Sat Feb 17 17:54:07 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 17 Feb 2007 12:54:07 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070217175407.0C13D50021@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13162 Modified Files: lisp-syntax.lisp lisp-syntax-swine.lisp lisp-syntax-swank.lisp Log Message: Tightened the nuts and bolts of Lisp syntax and added a bunch of tests to make relatively sure there are no regressions. No tests for Swine yet, but "it seems to work". Also fixes very major performance issue with redisplay of literal objects in Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/02/06 10:03:16 1.23 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/02/17 17:54:06 1.24 @@ -387,7 +387,7 @@ (defclass pathname-start-lexeme (lisp-lexeme) ()) (defclass undefined-reader-macro-lexeme (lisp-lexeme) ()) (defclass bit-vector-form (form-lexeme complete-form-mixin) ()) -(defclass number-lexeme (form-lexeme complete-form-mixin) ()) +(defclass number-lexeme (complete-token-lexeme) ()) (defclass token-mixin () ()) (defclass literal-object-form (form-lexeme complete-form-mixin) ()) (defclass complete-token-lexeme (token-mixin form-lexeme complete-form-mixin) ()) @@ -1011,15 +1011,19 @@ (define-parser-state |' | (form-may-follow) ()) (define-parser-state |' form | (lexer-toplevel-state parser-state) ()) +(define-parser-state |' incomplete-form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow quote-lexeme) |' |) (define-new-lisp-state (|' | complete-form-mixin) |' form |) +(define-new-lisp-state (|' | incomplete-form-mixin) |' incomplete-form |) (define-new-lisp-state (|' | comment) |' |) (define-new-lisp-state (|' | unmatched-right-parenthesis-lexeme) |( form* ) |) ;;; reduce according to the rule form -> ' form (define-lisp-action (|' form | t) (reduce-until-type complete-quote-form quote-lexeme)) +(define-lisp-action (|' incomplete-form | t) + (reduce-until-type incomplete-quote-form quote-lexeme)) (define-lisp-action (|' | right-parenthesis-lexeme) (reduce-until-type incomplete-quote-form quote-lexeme)) @@ -1090,8 +1094,8 @@ ;;; parse trees (defclass function-form (form) ()) -(defclass complete-function-form (form complete-form-mixin) ()) -(defclass incomplete-function-form (form incomplete-form-mixin) ()) +(defclass complete-function-form (function-form complete-form-mixin) ()) +(defclass incomplete-function-form (function-form incomplete-form-mixin) ()) (define-parser-state |#' | (form-may-follow) ()) (define-parser-state |#' form | (lexer-toplevel-state parser-state) ()) @@ -1142,7 +1146,7 @@ ;;;;;;;;;;;;;;;; uninterned symbol ;;; parse trees -(defclass uninterned-symbol-form (form complete-form-mixin) ()) +(defclass uninterned-symbol-form (complete-token-form) ()) (define-parser-state |#: | (form-may-follow) ()) (define-parser-state |#: form | (lexer-toplevel-state parser-state) ()) @@ -1237,14 +1241,18 @@ (define-parser-state |#P | (form-may-follow) ()) (define-parser-state |#P form | (lexer-toplevel-state parser-state) ()) +(define-parser-state |#P incomplete-form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow pathname-start-lexeme) |#P |) (define-new-lisp-state (|#P | complete-form-mixin) |#P form |) +(define-new-lisp-state (|#P | incomplete-form-mixin) |#P incomplete-form |) (define-new-lisp-state (|#P | comment) |#P |) ;;; reduce according to the rule form -> #P form (define-lisp-action (|#P form | t) (reduce-until-type complete-pathname-form pathname-start-lexeme)) +(define-lisp-action (|#P incomplete-form | t) + (reduce-until-type incomplete-pathname-form pathname-start-lexeme)) (define-lisp-action (|#P | (eql nil)) (reduce-until-type incomplete-pathname-form pathname-start-lexeme)) @@ -1593,21 +1601,21 @@ (defmethod form-operands (syntax (form list-form)) (remove-if-not #'formp (rest-forms (children form)))) -(defun form-toplevel (form syntax) +(defun form-toplevel (syntax form) "Return the top-level form of `form'." (if (null (parent (parent form))) form - (form-toplevel (parent form) syntax))) + (form-toplevel syntax (parent form)))) -(defgeneric form-operator-p (token syntax) - (:documentation "Return true if `token' is the operator of its form. Otherwise, - return nil.") - (:method (token syntax) +(defgeneric form-operator-p (syntax token) + (:documentation "Return true if `token' is the operator of its + form. Otherwise, return nil.") + (:method ((syntax lisp-syntax) (token lisp-lexeme)) (with-accessors ((pre-token preceding-parse-tree)) token (cond ((typep pre-token 'left-parenthesis-lexeme) t) ((comment-p pre-token) - (form-operator-p pre-token syntax)) + (form-operator-p syntax pre-token)) (t nil))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1615,15 +1623,20 @@ ;;; Useful functions for selecting forms based on the mark. (defun expression-at-mark (syntax mark-or-offset) - "Return the form at `mark-or-offset'. If `mark-or-offset' is just after, -or inside, a top-level-form, or if there are no forms after -`mark-or-offset', the form preceding `mark-or-offset' is -returned. Otherwise, the form following `mark-or-offset' is -returned." + "Return the form closest to `mark-or-offset'." (as-offsets ((offset mark-or-offset)) - (or (form-around syntax offset) - (form-after syntax offset) - (form-before syntax offset)))) + (flet ((distance (form) + (max (abs (- (start-offset form) mark-or-offset)) + (abs (- (end-offset form) mark-or-offset))))) + (reduce #'(lambda (form1 form2) + (cond ((null form1) form2) + ((null form2) form1) + ((> (distance form1) (distance form2)) + form2) + (t form1))) + (list (form-around syntax offset) + (form-after syntax offset) + (form-before syntax offset)))))) (defun definition-at-mark (syntax mark-or-offset) "Return the top-level form at `mark-or-offset'. If `mark-or-offset' is just after, @@ -1631,7 +1644,7 @@ `mark-or-offset', the top-level-form preceding `mark-or-offset' is returned. Otherwise, the top-level-form following `mark-or-offset' is returned." - (form-toplevel (expression-at-mark mark-or-offset syntax) syntax)) + (form-toplevel syntax (expression-at-mark syntax mark-or-offset))) (defun symbol-at-mark (syntax mark-or-offset &optional (form-fetcher 'expression-at-mark)) @@ -1641,12 +1654,10 @@ must be a function with the same signature as `expression-at-mark', and will be used to retrieve the initial form at `mark'." (as-offsets (mark-or-offset) - (labels ((unwrap-form (form) - (cond ((form-quoted-p form) - (unwrap-form (first-form (children form)))) - ((form-token-p form) - form)))) - (unwrap-form (funcall form-fetcher syntax mark-or-offset))))) + (let ((unwrapped-form (fully-unquoted-form + (funcall form-fetcher syntax mark-or-offset)))) + (when (form-token-p unwrapped-form) + unwrapped-form)))) (defun fully-quoted-form (token) "Return the top token object for `token', return `token' or the @@ -1673,29 +1684,6 @@ (or (form-around syntax offset) (form-before syntax offset)))) -(defun preceding-form (syntax mark-or-offset) - "Return a form at `mark-or-offset'." - (as-offsets ((offset mark-or-offset)) - (or (form-before syntax offset) - (form-around syntax offset)))) - -(defun text-of-definition-at-mark (syntax mark) - "Return the text of the definition at mark." - (let ((definition (definition-at-mark mark syntax))) - (buffer-substring (buffer mark) - (start-offset definition) - (end-offset definition)))) - -(defun text-of-expression-at-mark (syntax mark-or-offset) - "Return the text of the expression at `mark-or-offset'." - (let ((expression (expression-at-mark mark-or-offset syntax))) - (form-string syntax expression))) - -(defun symbol-name-at-mark (syntax mark-or-offset) - "Return the text of the symbol at `mark-or-offset'." - (let ((token (symbol-at-mark syntax mark-or-offset))) - (when token (form-string syntax token)))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Querying forms for data @@ -1744,8 +1732,8 @@ (defmethod replace-symbol-at-mark ((syntax lisp-syntax) (mark mark) (string string)) - (let ((token (symbol-at-mark syntax mark #'form-around))) - (when (and token (form-token-p token)) + (let ((token (symbol-at-mark syntax mark))) + (when token (setf (offset mark) (start-offset token)) (forward-delete-expression mark syntax)) (insert-sequence mark string))) @@ -1873,12 +1861,14 @@ ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\&) (with-face (:lambda-list-keyword) (call-next-method))) - ((and (macro-function symbol) - (form-operator-p parse-symbol syntax)) + ((and (symbolp symbol) + (macro-function symbol) + (form-operator-p syntax parse-symbol)) (with-face (:macro) (call-next-method))) - ((and (special-operator-p symbol) - (form-operator-p parse-symbol syntax)) + ((and (symbolp symbol) + (special-operator-p symbol) + (form-operator-p syntax parse-symbol)) (with-face (:special-form) (call-next-method))) (t (call-next-method))))) @@ -2095,6 +2085,10 @@ (t nil)))) (defun form-before (syntax offset) + (assert (>= (size (buffer syntax)) offset) nil + "Offset past buffer end") + (assert (>= offset 0) nil + "Offset before buffer start") (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) (<= offset (start-offset stack-top))) @@ -2120,6 +2114,10 @@ (t nil)))) (defun form-after (syntax offset) + (assert (>= (size (buffer syntax)) offset) nil + "Offset past buffer end") + (assert (>= offset 0) nil + "Offset before buffer start") (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) (>= offset (end-offset stack-top))) @@ -2133,16 +2131,18 @@ (= offset (end-offset child)) (= offset (start-offset child))) (return (if (null (first-form (children child))) - (when (formp child) - child) + child (or (form-around-in-children (children child) offset) - (when (formp child) - child))))) + child)))) ((< offset (start-offset child)) (return nil)) (t nil)))) (defun form-around (syntax offset) + (assert (>= (size (buffer syntax)) offset) nil + "Offset past buffer end") + (assert (>= offset 0) nil + "Offset before buffer start") (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) (> offset (end-offset stack-top)) @@ -2151,16 +2151,14 @@ (form-around-in-children (children stack-top) offset)))) (defun find-list-parent-offset (form fn) - "Find a list parent of `token' and return `fn' -applied to this parent token. `Fn' should be a function -that returns an offset when applied to a -token (eg. `start-offset' or `end-offset'). If a list -parent cannot be found, return `fn' applied to `form'." + "Find a list parent of `form' and return `fn' applied to this +parent token. `Fn' should be a function that returns an offset +when applied to a token (eg. `start-offset' or `end-offset'). If +a list parent cannot be found, return nil" (let ((parent (parent form))) (typecase parent - (form* (funcall fn form)) (list-form (funcall fn form)) - (null (funcall fn form)) + ((or form* null) nil) (t (find-list-parent-offset parent fn))))) (defun find-list-child-offset (form fn &optional (min-offset 0)) @@ -2196,8 +2194,7 @@ (setf (offset mark) (end-offset potential-form))))) (defgeneric forward-one-list (mark syntax) - (:documentation - "Move `mark' forward by one list. + (:documentation "Move `mark' forward by one list. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod forward-one-list (mark (syntax lisp-syntax)) @@ -2214,9 +2211,8 @@ (return t))) (defgeneric backward-one-list (mark syntax) - (:documentation - "Move `mark' backward by one list. Return T if successful, or -NIL if the buffer limit was reached.")) + (:documentation "Move `mark' backward by one list. Return T if +successful, or NIL if the buffer limit was reached.")) (defmethod backward-one-list (mark (syntax lisp-syntax)) (loop for start = (offset mark) @@ -2233,103 +2229,91 @@ (drei-motion:define-motion-fns list) -(defun down-list-by-fn (mark syntax fn) - (let* ((offset (offset mark)) - (potential-form (form-after syntax offset))) - (let ((new-offset (typecase potential-form - (list-form (start-offset potential-form)) - (null nil) - (t (find-list-child-offset - (parent potential-form) - fn - offset))))) +(defun down-list (mark syntax selector next-offset-fn target-offset-fn) + (labels ((find-offset (potential-form) + (typecase potential-form + (list-form (funcall target-offset-fn potential-form)) + (null nil) + (t (find-offset (funcall selector syntax + (funcall next-offset-fn potential-form))))))) + (let ((new-offset (find-offset (funcall selector syntax (offset mark))))) (when new-offset - (progn (setf (offset mark) (1+ new-offset)) t))))) + (setf (offset mark) new-offset) + t)))) -(defmethod forward-one-down (mark (syntax lisp-syntax)) - (down-list-by-fn mark syntax #'start-offset)) +(defmethod forward-one-down ((mark mark) (syntax lisp-syntax)) + (when (down-list mark syntax #'form-after #'end-offset #'start-offset) + (forward-object mark))) + +(defmethod backward-one-down ((mark mark) (syntax lisp-syntax)) + (when (down-list mark syntax #'form-before #'start-offset #'end-offset) + (backward-object mark))) -(defmethod backward-one-down (mark (syntax lisp-syntax)) - (down-list-by-fn mark syntax #'end-offset) - (backward-object mark syntax)) - -(defun up-list-by-fn (mark syntax fn) - (let ((form (or (form-before syntax (offset mark)) - (form-after syntax (offset mark)) - (form-around syntax (offset mark))))) +(defun up-list (mark syntax fn) + (let ((form (form-around syntax (offset mark)))) (when form - (let ((parent (parent form))) - (when (not (null parent)) - (let ((new-offset (find-list-parent-offset parent fn))) - (when new-offset - (setf (offset mark) new-offset)))))))) + (let ((new-offset (find-list-parent-offset form fn))) + (when new-offset + (setf (offset mark) new-offset) + t))))) (defmethod backward-one-up (mark (syntax lisp-syntax)) - (up-list-by-fn mark syntax #'start-offset)) + (up-list mark syntax #'start-offset)) (defmethod forward-one-up (mark (syntax lisp-syntax)) - (up-list-by-fn mark syntax #'end-offset)) + (up-list mark syntax #'end-offset)) -(defmethod eval-defun (mark (syntax lisp-syntax)) +(defmethod backward-one-definition ((mark mark) (syntax lisp-syntax)) (with-slots (stack-top) syntax - (loop for form in (children stack-top) - when (and (mark<= (start-offset form) mark) - (mark<= mark (end-offset form))) - do (return (eval-form-for-drei - (get-usable-image syntax) - (form-to-object syntax form :read t)))))) + ;; FIXME? This conses! I'm over it already. I don't think it + ;; matters much, but if someone is bored, please profile it. + (loop for form in (reverse (children stack-top)) + when (and (formp form) + (mark> mark (start-offset form))) + do (setf (offset mark) (start-offset form)) + and do (return t)))) -(defmethod backward-one-definition (mark (syntax lisp-syntax)) +(defmethod forward-one-definition ((mark mark) (syntax lisp-syntax)) (with-slots (stack-top) syntax (loop for form in (children stack-top) - with last-toplevel-list = nil - when (and (formp form) - (mark< mark (end-offset form))) - do (if (mark< (start-offset form) mark) - (setf (offset mark) (start-offset form)) - (when last-toplevel-list form - (setf (offset mark) (start-offset last-toplevel-list)))) - (return t) - when (formp form) - do (setf last-toplevel-list form) [325 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2007/02/06 09:25:08 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2007/02/17 17:54:06 1.6 @@ -328,7 +328,8 @@ provided-args))) (defun cleanup-arglist (arglist) - "Remove elements of `arglist' that we are not interested in." + "Remove elements of `arglist' that we are not interested in, +including implementation-specific lambda list keywords." (loop for arg in arglist with in-&aux ; If non-NIL, we are in the @@ -349,6 +350,11 @@ else collect arg)) +(defun canonicalize-arglist (arglist) + "Convert `arglist' to the Grand Unified Arglist Format used by +Drei, and signal errors if the arglist is found to be invalid." + arglist) + (defun find-argument-indices-for-operand (syntax operand-form operator-form) "Return a list of argument indices for `argument-form' relative to `operator-form'. These lists take the form of (n m p), which @@ -783,7 +789,7 @@ `(let* ((,form-sym ;; Find a form with a valid (fboundp) operator. (let ((immediate-form - (preceding-form ,syntax ,mark-or-offset))) + (this-form ,syntax ,mark-or-offset))) (unless (null immediate-form) (or (find-applicable-form ,syntax immediate-form) ;; If nothing else can be found, and `arg-form' --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2007/01/07 19:48:16 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2007/02/17 17:54:06 1.3 @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Package: DREI-LISP-SYNTAX; -*- -;;; (c) copyright 2005-2006 by +;;; (c) copyright 2005-2007 by ;;; Robert Strandh (strandh at labri.fr) ;;; David Murray (splittist at yahoo.com) ;;; Troels Henriksen (athas at sigkill.dk) From thenriksen at common-lisp.net Mon Feb 19 00:12:22 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 18 Feb 2007 19:12:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070219001222.D58344E009@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15239 Modified Files: input-editor.lisp fundamental-syntax.lisp Log Message: Made Lisp and Fundamental syntax handle case where the tab width is zero (hello Null backend!) --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2007/01/13 21:09:51 1.16 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2007/02/19 00:12:22 1.17 @@ -164,7 +164,7 @@ ;; position properly (ie. after the prompt). (loop with buffer = (buffer (drei-instance stream)) - until (= (stream-scan-pointer stream) (size buffer)) + until (>= (stream-scan-pointer stream) (size buffer)) while (typep (buffer-object buffer (stream-scan-pointer stream)) 'noise-string) do (incf (stream-scan-pointer stream))) --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2007/02/06 09:10:51 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2007/02/19 00:12:22 1.5 @@ -111,9 +111,10 @@ pane (first (aref cursor-positions 0)) 0)) ((#\Page #\Return #\Space) (stream-increment-cursor-position pane space-width 0)) - (#\Tab (let ((x (stream-cursor-position pane))) - (stream-increment-cursor-position - pane (- tab-width (mod x tab-width)) 0)))) + (#\Tab (when (plusp tab-width) + (let ((x (stream-cursor-position pane))) + (stream-increment-cursor-position + pane (- tab-width (mod x tab-width)) 0))))) (incf start)))))) (defmethod display-line ((stream clim-stream-pane) (drei drei) mark) From thenriksen at common-lisp.net Mon Feb 19 00:13:05 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 18 Feb 2007 19:13:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070219001305.2D5D94E00F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15305 Modified Files: lisp-syntax.lisp Log Message: Made Lisp and Fundamental syntax handle case where the tab width is zero (hello Null backend!) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/02/17 17:54:06 1.24 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/02/19 00:13:05 1.25 @@ -1796,9 +1796,10 @@ pane (first (aref cursor-positions 0)) 0)) ((#\Page #\Return #\Space) (stream-increment-cursor-position pane space-width 0)) - (#\Tab (let ((x (stream-cursor-position pane))) - (stream-increment-cursor-position - pane (- tab-width (mod x tab-width)) 0)))) + (#\Tab (when (plusp tab-width) + (let ((x (stream-cursor-position pane))) + (stream-increment-cursor-position + pane (- tab-width (mod x tab-width)) 0))))) (incf start)))))) (defgeneric display-parse-tree (parse-symbol stream drei syntax) From crhodes at common-lisp.net Wed Feb 21 12:35:36 2007 From: crhodes at common-lisp.net (crhodes) Date: Wed, 21 Feb 2007 07:35:36 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20070221123536.04D713E053@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv24730/ESA Modified Files: esa.lisp Log Message: Fix M-digit handling (now does more than two digits!) --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/02/07 12:44:21 1.5 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/02/21 12:35:36 1.6 @@ -18,7 +18,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; Emacs-Style Appication +;;; Emacs-Style Application (in-package :esa) @@ -621,6 +621,7 @@ do (setf numarg (+ (* 10 numarg) (meta-digit gesture))) (pop gestures) + finally (return (values (if (and (= sign -1) (= numarg 0)) -1 (* sign numarg))