From dlichteblau at common-lisp.net Sat Mar 3 12:09:55 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sat, 3 Mar 2007 07:09:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20070303120955.37B114E019@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv6536 Modified Files: ffi.lisp gadgets.lisp gtk-ffi.lisp Log Message: Use UTF-8 for all foreign strings. * Backends/gtkairo/gtk-ffi.lisp (utf8-string): New foreign type. * Backends/gtkairo/ffi.lisp: s/:string/utf8-string/ * Backends/gtkairo/gadgets.lisp (reset-list-pane-items, (realize-native-widget gtk-option-pane)): Specify :encoding. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2007/02/07 12:44:19 1.17 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2007/03/03 12:09:51 1.18 @@ -372,7 +372,7 @@ (defcfun "cairo_image_surface_create_for_data" :pointer - (arg0 :string) ;unsigned char * + (arg0 utf8-string) ;unsigned char * (arg1 cairo_format_t) (arg2 :int) ;int (arg3 :int) ;int @@ -559,7 +559,7 @@ (defcfun "cairo_select_font_face" :void (arg0 :pointer) ;cairo_t * - (arg1 :string) ;const char * + (arg1 utf8-string) ;const char * (arg2 cairo_font_slant_t) (arg3 cairo_font_weight_t)) @@ -664,7 +664,7 @@ (defcfun "cairo_show_text" :void (arg0 :pointer) ;cairo_t * - (arg1 :string) ;const char * + (arg1 utf8-string) ;const char * ) (defcfun "cairo_status" @@ -722,14 +722,14 @@ (defcfun "cairo_text_extents" :void (arg0 :pointer) ;cairo_t * - (arg1 :string) ;const char * + (arg1 utf8-string) ;const char * (arg2 :pointer) ;cairo_text_extents_t * ) (defcfun "cairo_text_path" :void (arg0 :pointer) ;cairo_t * - (arg1 :string) ;const char * + (arg1 utf8-string) ;const char * ) (defcfun "cairo_translate" @@ -758,7 +758,7 @@ (defcfun "g_signal_connect_data" :unsigned-long (instance :pointer) ;gpointer - (detailed_signal :string) ;const gchar * + (detailed_signal utf8-string) ;const gchar * (c_handler :pointer) ;GCallback (data :pointer) ;gpointer (destroy_data :pointer) ;GClosureNotify @@ -778,7 +778,7 @@ (defcfun "g_value_set_string" :void (value :pointer) ;GValue * - (v_string :string) ;const gchar * + (v_string utf8-string) ;const gchar * ) (defcfun "gdk_cairo_create" @@ -1122,20 +1122,20 @@ (defcfun "gtk_button_new_with_label" :pointer - (label :string) ;const gchar * + (label utf8-string) ;const gchar * ) (defcfun "gtk_cell_renderer_text_new" :pointer) (defcfun "gtk_check_button_new_with_label" :pointer - (label :string) ;const gchar * + (label utf8-string) ;const gchar * ) (defcfun "gtk_combo_box_append_text" :void (combo_box :pointer) ;GtkComboBox * - (text :string) ;const gchar * + (text utf8-string) ;const gchar * ) (defcfun "gtk_combo_box_get_active" @@ -1199,7 +1199,7 @@ (defcfun "gtk_frame_new" :pointer - (label :string) ;const gchar * + (label utf8-string) ;const gchar * ) (defcfun "gtk_get_current_event_time" :uint32) @@ -1224,13 +1224,13 @@ (defcfun "gtk_label_new" :pointer - (str :string) ;const gchar * + (str utf8-string) ;const gchar * ) (defcfun "gtk_label_set_text" :void (label :pointer) ;GtkLabel * - (str :string) ;const gchar * + (str utf8-string) ;const gchar * ) (defcfun "gtk_list_store_append" @@ -1267,7 +1267,7 @@ (defcfun "gtk_menu_item_new_with_label" :pointer - (label :string) ;const gchar * + (label utf8-string) ;const gchar * ) (defcfun "gtk_menu_item_set_submenu" @@ -1350,7 +1350,7 @@ (defcfun "gtk_radio_button_new_with_label" :pointer (group :pointer) ;GSList * - (label :string) ;const gchar * + (label utf8-string) ;const gchar * ) (defcfun "gtk_range_get_adjustment" @@ -1446,7 +1446,7 @@ :void (tree_column :pointer) ;GtkTreeViewColumn * (cell_renderer :pointer) ;GtkCellRenderer * - (attribute :string) ;const gchar * + (attribute utf8-string) ;const gchar * (column :int) ;gint ) @@ -1462,7 +1462,7 @@ (defcfun "gtk_tree_view_column_set_title" :void (tree_column :pointer) ;GtkTreeViewColumn * - (title :string) ;const gchar * + (title utf8-string) ;const gchar * ) (defcfun "gtk_tree_view_get_hadjustment" @@ -1664,7 +1664,7 @@ (defcfun "gtk_window_set_title" :void (window :pointer) ;GtkWindow * - (title :string) ;const gchar * + (title utf8-string) ;const gchar * ) (defcfun "pango_cairo_create_layout" @@ -1715,11 +1715,11 @@ (defcfun "pango_font_description_from_string" :pointer - (str :string) ;const char * + (str utf8-string) ;const char * ) (defcfun "pango_font_description_get_family" - :string + utf8-string (desc :pointer) ;const PangoFontDescription * ) @@ -1734,7 +1734,7 @@ (defcfun "pango_font_description_set_family" :void (desc :pointer) ;PangoFontDescription * - (family :string) ;const char * + (family utf8-string) ;const char * ) (defcfun "pango_font_description_set_size" @@ -1754,12 +1754,12 @@ (weight PangoWeight)) (defcfun "pango_font_description_to_string" - :string + utf8-string (desc :pointer) ;const PangoFontDescription * ) (defcfun "pango_font_face_get_face_name" - :string + utf8-string (face :pointer) ;PangoFontFace * ) @@ -1771,7 +1771,7 @@ ) (defcfun "pango_font_family_get_name" - :string + utf8-string (family :pointer) ;PangoFontFamily * ) @@ -1884,6 +1884,6 @@ (defcfun "pango_layout_set_text" :void (layout :pointer) ;PangoLayout * - (text :string) ;const char * + (text utf8-string) ;const char * (length :int) ;int ) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2007/02/04 12:55:44 1.21 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2007/03/03 12:09:51 1.22 @@ -207,7 +207,7 @@ (cffi:with-foreign-object (&iter 'gtktreeiter) (dolist (i (climi::list-pane-items sheet)) (gtk_list_store_append model &iter) - (cffi:with-foreign-string (n (funcall name-key i)) + (cffi:with-foreign-string (n (funcall name-key i) :encoding :utf-8) (cffi:with-foreign-object (&value 'gvalue) (setf (cffi:foreign-slot-value &value 'gvalue 'type) 0) (g_value_init &value +g-type-string+) @@ -218,7 +218,7 @@ (let* ((widget (gtk_combo_box_new_text)) (name-key (climi::list-pane-name-key sheet))) (dolist (i (climi::list-pane-items sheet)) - (cffi:with-foreign-string (n (funcall name-key i)) + (cffi:with-foreign-string (n (funcall name-key i) :encoding :utf-8) (gtk_combo_box_append_text widget n))) (option-pane-set-active sheet widget) widget)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/26 12:11:04 1.25 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2007/03/03 12:09:51 1.26 @@ -19,6 +19,8 @@ (in-package :clim-gtkairo) +(cffi:defctype utf8-string (:string :encoding :utf-8)) + #-(or win32 mswindows windows darwin) (eval-when (:compile-toplevel :load-toplevel :execute) (cffi:load-foreign-library "libcairo.so") @@ -238,7 +240,7 @@ (state :uint) (keyval :uint) (length :int) - (string :string)) + (string utf8-string)) (cffi:defcstruct gdkeventcrossing (type :int) From thenriksen at common-lisp.net Sun Mar 4 14:59:38 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 4 Mar 2007 09:59:38 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070304145938.2C6D92A071@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19503 Modified Files: frames.lisp Log Message: Patch by Robert Goldman, make menu commands with unsupplied arguments work better. --- /project/mcclim/cvsroot/mcclim/frames.lisp 2007/02/07 12:44:16 1.125 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2007/03/04 14:59:37 1.126 @@ -505,9 +505,9 @@ (menu-item (let ((command (command-menu-item-value object))) (unless (listp command) - (setq command (list command))) + (setq command (partial-command-from-name command))) (if (and (typep stream 'interactor-pane) - (member *unsupplied-argument-marker* command :test #'eq)) + (partial-command-p command)) (command-line-read-remaining-arguments-for-partial-command (frame-command-table frame) stream command 0) command))))) From thenriksen at common-lisp.net Sun Mar 4 15:08:02 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 4 Mar 2007 10:08:02 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070304150802.CAB1E586B1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22171 Modified Files: panes.lisp Log Message: Fixed issue reported by Samium Gromoff where the :scroll-bars parameter would be ignored in `open-window-stream'. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2007/02/07 12:44:17 1.180 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2007/03/04 15:08:00 1.181 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.180 2007/02/07 12:44:17 crhodes Exp $ +;;; $Id: panes.lisp,v 1.181 2007/03/04 15:08:00 thenriksen Exp $ (in-package :clim-internals) @@ -2785,10 +2785,12 @@ standard-extended-input-stream fundamental-character-output-stream standard-application-frame) - ((stream)) + ((stream) + (scroll-bars :initform :vertical + :initarg :scroll-bars)) (:panes (io - (scrolling (:height 400 :width 700) + (scrolling (:height 400 :width 700 :scroll-bar (slot-value *application-frame* 'scroll-bars)) (setf (slot-value *application-frame* 'stream) (make-pane 'window-stream :width 700 @@ -2824,7 +2826,6 @@ initial-cursor-visibility text-margin save-under - scroll-bars borders label)) (setf port (or port (find-port))) @@ -2838,7 +2839,8 @@ :right right :bottom bottom :width width - :height height))) + :height height + :scroll-bars scroll-bars))) ;; Adopt and enable the pane (when (eq (frame-state frame) :disowned) (adopt-frame fm frame)) From ahefner at common-lisp.net Sun Mar 4 22:26:22 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Mar 2007 17:26:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070304222622.354177E0F3@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv20997 Modified Files: graph-formatting.lisp Log Message: Don't replay the rendered graph on the stream if drawing is disabled, or if we are drawing into a record which does not have the stream output history as an ancestor. --- /project/mcclim/cvsroot/mcclim/graph-formatting.lisp 2006/09/17 20:27:09 1.19 +++ /project/mcclim/cvsroot/mcclim/graph-formatting.lisp 2007/03/04 22:26:22 1.20 @@ -3,7 +3,7 @@ ;;; Title: Graph Formatting ;;; Created: 2002-08-13 ;;; License: LGPL (See file COPYING for details). -;;; $Id: graph-formatting.lisp,v 1.19 2006/09/17 20:27:09 thenriksen Exp $ +;;; $Id: graph-formatting.lisp,v 1.20 2007/03/04 22:26:22 ahefner Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -175,8 +175,11 @@ )))) (setf (output-record-position graph-output-record) (values cursor-old-x cursor-old-y)) - (with-output-recording-options (stream :draw t :record nil) - (replay graph-output-record stream)) + (when (and (stream-drawing-p stream) + (output-record-ancestor-p (stream-output-history stream) + graph-output-record)) + (with-output-recording-options (stream :draw t :record nil) + (replay graph-output-record stream))) (when move-cursor (setf (stream-cursor-position stream) (values (bounding-rectangle-max-x graph-output-record) From ahefner at common-lisp.net Sun Mar 4 22:27:31 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Mar 2007 17:27:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070304222731.689B07E0F5@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv21365 Modified Files: gadgets.lisp Log Message: Default value of toggle button to nil. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2007/02/06 12:54:10 1.105 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2007/03/04 22:27:30 1.106 @@ -1115,7 +1115,8 @@ :reader toggle-button-indicator-type :initform :some-of) ) (:default-initargs - :text-style (make-text-style :sans-serif nil nil) + :value nil + :text-style (make-text-style :sans-serif nil nil) :align-x :left :align-y :center :x-spacing 2 From ahefner at common-lisp.net Sun Mar 4 22:27:51 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Mar 2007 17:27:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20070304222751.DD09D7E0F5@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv21533 Modified Files: wholine.lisp Log Message: Less ugly. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/wholine.lisp 2007/02/05 03:27:14 1.1 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/wholine.lisp 2007/03/04 22:27:51 1.2 @@ -85,7 +85,7 @@ #+openmcl (+ (ccl::%usedbytes) (ccl::%freebytes)) #+clisp (values (sys::%room)) #-(or cmu scl sbcl lispworks openmcl clisp) 0)) - (with-text-family (t :serif) + (with-text-style (t (make-text-style :sans-serif :roman :small)) (formatting-table (t :x-spacing '(3 :character)) (formatting-row (t) (macrolet ((cell ((align-x) &body body) From ahefner at common-lisp.net Sun Mar 4 22:30:19 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Mar 2007 17:30:19 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070304223019.6949049087@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv21897 Modified Files: frames.lisp Log Message: Change frame-geometry* so that when subclassing application frames, the geometry specified in a superclass is inherited as you'd expect. --- /project/mcclim/cvsroot/mcclim/frames.lisp 2007/03/04 14:59:37 1.126 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2007/03/04 22:30:19 1.127 @@ -72,26 +72,6 @@ (defgeneric note-input-focus-changed (pane state) (:documentation "Called when a pane receives or loses the keyboard input focus. This is a McCLIM extension.")) - -(defmethod frame-geometry* ((frame application-frame)) - "-> width height &optional top left" - (let ((pane (frame-top-level-sheet frame))) - (destructuring-bind (&key left top right bottom width height) (frame-geometry frame) - ;; Find width and height from looking at the respective options - ;; first, then at left/right and top/bottom and finally at what - ;; compose-space says. - (setf width (or width - (and left right (- right left)) - (space-requirement-width (compose-space pane)))) - (setf height (or height - (and top bottom (- bottom top)) - (space-requirement-height (compose-space pane)))) - ;; See if a position is wanted and return left, top. - (setf left (or left - (and right (- right width)))) - (setf top (or top - (and bottom (- bottom height)))) - (values width height left top)))) (defclass standard-application-frame (application-frame presentation-history-mixin) @@ -139,11 +119,7 @@ :reader frame-top-level-lambda) (hilited-presentation :initform nil :initarg :hilited-presentation - :accessor frame-hilited-presentation) - (user-supplied-geometry :initform nil - :initarg :user-supplied-geometry - :reader frame-geometry - :documentation "plist of defaulted :left, :top, :bottom, :right, :width and :height options.") + :accessor frame-hilited-presentation) (process :accessor frame-process :initform nil) (client-settings :accessor client-settings :initform nil) (event-queue :initarg :frame-event-queue @@ -170,7 +146,49 @@ (documentation-record :accessor documentation-record :initform nil :documentation "updating output record for pointer -documentation produced by presentations."))) +documentation produced by presentations.") + (geometry-left :accessor geometry-left + :initarg :left + :initform nil) + (geometry-right :accessor geometry-right + :initarg :right + :initform nil) + (geometry-top :accessor geometry-top + :initarg :top + :initform nil) + (geometry-bottom :accessor geometry-bottom + :initarg :bottom + :initform nil) + (geometry-width :accessor geometry-width + :initarg :width + :initform nil) + (geometry-height :accessor geometry-height + :initarg :height + :initform nil))) + +(defmethod frame-geometry* ((frame standard-application-frame)) + "-> width height &optional top left" + (let ((pane (frame-top-level-sheet frame))) + ;(destructuring-bind (&key left top right bottom width height) (frame-geometry frame) + (with-slots (geometry-left geometry-top geometry-right + geometry-bottom geometry-width + geometry-height) frame + ;; Find width and height from looking at the respective options + ;; first, then at left/right and top/bottom and finally at what + ;; compose-space says. + (let* ((width (or geometry-width + (and geometry-left geometry-right + (- geometry-right geometry-left)) + (space-requirement-width (compose-space pane)))) + (height (or geometry-height + (and geometry-top geometry-bottom (- geometry-bottom geometry-top)) + (space-requirement-height (compose-space pane)))) + ;; See if a position is wanted and return left, top. + (left (or geometry-left + (and geometry-right (- geometry-right geometry-width)))) + (top (or geometry-top + (and geometry-bottom (- geometry-bottom geometry-height))))) + (values width height left top))))) ;;; Support the :input-buffer initarg for compatibility with "real CLIM" @@ -811,7 +829,7 @@ (:pointer-documentation (setq pointer-documentation (car values))) (:geometry (setq geometry values)) (:default-initargs (setq user-default-initargs values)) - (t (push (cons prop values) others)))) + (t (push (cons prop values) others)))) (when (eq command-definer t) (setf command-definer (intern (concatenate 'string @@ -840,12 +858,9 @@ :top-level-lambda (lambda (,frame-arg) (,(car top-level) ,frame-arg ,@(cdr top-level))) + , at geometry , 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. - ;; --GB 2004-06-01 - (setf (get ',name 'application-frame-geometry) ',geometry) ,(if pane (make-single-pane-generate-panes-form name menu-bar pane) (make-panes-generate-panes-form name menu-bar panes layouts @@ -859,9 +874,6 @@ (command-table ',(first command-table))) `(define-command (,name :command-table ,command-table , at options) ,arguments , at body)))))))) -(defun get-application-frame-class-geometry (name indicator) - (getf (get name 'application-frame-geometry) indicator nil)) - (defun make-application-frame (frame-name &rest options &key (pretty-name @@ -869,25 +881,14 @@ (frame-manager nil frame-manager-p) enable (state nil state-supplied-p) - (left (get-application-frame-class-geometry frame-name :left)) - (top (get-application-frame-class-geometry frame-name :top)) - (right (get-application-frame-class-geometry frame-name :right)) - (bottom (get-application-frame-class-geometry frame-name :bottom)) - (width (get-application-frame-class-geometry frame-name :width)) - (height (get-application-frame-class-geometry frame-name :height)) save-under (frame-class frame-name) &allow-other-keys) (declare (ignore save-under)) (with-keywords-removed (options (:pretty-name :frame-manager :enable :state - :left :top :right :bottom :width :height :save-under :frame-class)) (let ((frame (apply #'make-instance frame-class :name frame-name :pretty-name pretty-name - :user-supplied-geometry - (list :left left :top top - :right right :bottom bottom - :width width :height height) options))) (when frame-manager-p (adopt-frame frame-manager frame)) From ahefner at common-lisp.net Sun Mar 4 22:37:36 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 4 Mar 2007 17:37:36 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070304223736.73E3A4E011@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22852 Modified Files: utils.lisp Log Message: Fix parse-space, the unit name is :inches, not :inch (that's what all the backends use, anyway). --- /project/mcclim/cvsroot/mcclim/utils.lisp 2006/10/29 11:58:58 1.46 +++ /project/mcclim/cvsroot/mcclim/utils.lisp 2007/03/04 22:37:36 1.47 @@ -498,7 +498,7 @@ (gunit (graft-units graft))) ;; mungle specification into what grafts talk about (case unit - ((:point) (setf value (/ value 72) unit :inch)) + ((:point) (setf value (/ value 72) unit :inches)) ((:pixel) (setf unit :device)) ((:mm) (setf unit :millimeters))) ;; From rgoldman at common-lisp.net Fri Mar 9 23:41:47 2007 From: rgoldman at common-lisp.net (rgoldman) Date: Fri, 9 Mar 2007 18:41:47 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/tree-with-cross-edges Message-ID: <20070309234147.80C36140B3@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges In directory clnet:/tmp/cvs-serv23996/tree-with-cross-edges Log Message: Directory /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges added to the repository From rgoldman at common-lisp.net Fri Mar 9 23:42:34 2007 From: rgoldman at common-lisp.net (rgoldman) Date: Fri, 9 Mar 2007 18:42:34 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/tree-with-cross-edges Message-ID: <20070309234234.A083A2A066@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges In directory clnet:/tmp/cvs-serv24198 Added Files: mcclim-tree-with-cross-edges.asd tree-with-cross-edges.lisp Log Message: First draft version of an experimental extension to the graph-formatting protocol. --- /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges/mcclim-tree-with-cross-edges.asd 2007/03/09 23:42:34 NONE +++ /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges/mcclim-tree-with-cross-edges.asd 2007/03/09 23:42:34 1.1 ;;;; -*- Lisp -*- ;;;--------------------------------------------------------------------------- ;;; Copyright (c) 2005-2007 Robert P. Goldman and Smart Information ;;; Flow Technologies, d/b/a SIFT, LLC ;;; ;;; 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. ;;; ;;; All rights reserved. ;;; ;;;--------------------------------------------------------------------------- ;;; File Description: ;;; ;;; A system that adds a new type of graph to the ;;; format-graph-from-roots protocol for McCLIM. ;;; ;;; ;;;--------------------------------------------------------------------------- (defpackage :mcclim-tree-with-cross-edges-system (:use :cl :asdf)) (in-package :mcclim-tree-with-cross-edges-system) (defsystem :mcclim-tree-with-cross-edges :depends-on (:mcclim) :serial t :components ((:file "tree-with-cross-edges"))) --- /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges/tree-with-cross-edges.lisp 2007/03/09 23:42:34 NONE +++ /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges/tree-with-cross-edges.lisp 2007/03/09 23:42:34 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;;--------------------------------------------------------------------------- ;;; Copyright (c) 2005-2007 Robert P. Goldman and Smart Information ;;; Flow Technologies, d/b/a SIFT, LLC ;;; ;;; 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. ;;; ;;; All rights reserved. ;;; ;;;--------------------------------------------------------------------------- ;;; File Description: ;;; ;;; File for definitions of a new graph type that should allow tree ;;; style layouts with edges across in a level. [2005/05/05:rpg] ;;; ;;; History/Bugs/Notes: ;;; ;;; [2005/05/05:rpg] Created. ;;; ;;;--------------------------------------------------------------------------- (in-package "CLIM-INTERNALS") ;;;--------------------------------------------------------------------------- ;;; A graph with cross trees will have an additional type option: a ;;; cross-edge-producer ;;;--------------------------------------------------------------------------- (eval-when (:compile-toplevel :load-toplevel :execute) (define-graph-type :tree-with-cross-edges cross-tree-output-record)) (defun standard-cross-arc-drawer (stream from-node to-node x1 y1 x2 y2 &rest drawing-options &key edge-type &allow-other-keys) "The standard cross-arc-drawer simply ignores the edge-type keyword argument." (declare (ignore edge-type)) (remf drawing-options :edge-type) (apply #'standard-arc-drawer stream from-node to-node x1 y1 x2 y2 drawing-options)) (defclass cross-tree-output-record (tree-graph-output-record) ((cross-arc-drawer :initarg :cross-arc-drawer :reader cross-arc-drawer :documentation "This slot should be bound to a function that takes all the arguments accepted by a normal arc-drawer, but also an edge-type keyword argument, which it is free to ignore." :initform #'standard-cross-arc-drawer ) (cross-arc-producer :initarg :cross-arc-producer ;; by default, this just acts like a tree... :initform nil :reader cross-arc-producer :documentation "This should be bound to a function that takes a graph-node as argument, like inferior-producer, but that returns two values: a list of destination nodes and (optionally) a list of type-designators, that can be passed to the cross-arc-drawer, as the value of the :edge-type keyword argument." ) (cross-arc-drawing-options :reader cross-arc-drawing-options ) ) ) ;;;--------------------------------------------------------------------------- ;;; This is very yucky. It will be expensive on large graphs (perhaps ;;; a mixin for using a hash-table would be better), and needs some ;;; kind of good way of specifying the test in your graph class, which ;;; will be difficult... [2005/05/06:rpg] ;;;--------------------------------------------------------------------------- (defmethod lookup-node (source-node (graph graph-output-record) &key (test #'eql) (default :error)) (let ((hash-table (make-hash-table :test #'eq))) (flet ((visitedp (node) (gethash node hash-table nil)) (mark (node) (setf (gethash node hash-table) t))) (or (loop with openlist = (graph-root-nodes graph) for node = (pop openlist) while node unless (visitedp node) when (funcall test source-node (graph-node-object node)) return node end and do (mark node) (setf openlist (append openlist (graph-node-children node)))) (when (eq default :error) (error "Unable to find graph node for ~S in ~S" source-node graph)) default)))) (defmethod initialize-instance :after ((obj cross-tree-output-record) &key cross-arc-drawing-options arc-drawing-options) "A possibly reasonable default is to draw cross-arcs as if they were normal tree edge arcs." (unless cross-arc-drawing-options (setf (slot-value obj 'cross-arc-drawing-options) arc-drawing-options))) ;;; note that this could later be made into a function argument, so ;;; that programmers could customize [2005/05/06:rpg] (defgeneric cross-arc-routing (from to orientation) (:documentation "Return four values, x1, y1, x2, y2 for the arc-drawing for a cross-arc. More complex than for the tree case.")) (defun middle (dim1 dim2) (/ (+ dim1 dim2) 2)) (defmethod cross-arc-routing (from to (orientation (eql :horizontal))) (with-bounding-rectangle* (x1 y1 x2 y2) from (with-bounding-rectangle* (u1 v1 u2 v2) to (cond ((< x2 u1) ;; node entirely to the left of k (values x2 (middle y1 y2) u1 (middle v1 v2))) ((< u2 x1) ;; node entirely to the right of k ;; draw from the top or bottom to make distinguishable... (if (<= v1 y1) ;; draw from the top to the x middle of TO on the ;; bottom (values x1 y1 (middle u1 u2) v2) ;; draw from the bottom to the x middle of TO on the ;; top... (values x1 y2 (middle u1 u2) v1))) ;; overlapping in X -- as long as this is a tree, means ;; they are siblings. ((< y2 v1) ;; FROM above: middle x of FROM to middle x of TO, bottom to top... (values (middle x1 x2) y2 (middle u1 u2) v1)) ((< v2 y1) ;; TO above: middle x of FROM to middle x of TO, top to bottom... (values (middle x1 x2) y1 (middle u1 u2) v2)) (t (error "Unforeseen node positioning.")))))) ;;; copied from original layout-graph-edges and enhanced to add cross ;;; edges. (defmethod layout-graph-edges :after ((graph cross-tree-output-record) stream arc-drawer arc-drawing-options) "After the main method has drawn the tree, add the cross-edges." (declare (ignore arc-drawer arc-drawing-options)) ;;; (format excl:*initial-terminal-io* "~&Invoking after method to layout cross-edges.~%") ;;; (unless (cross-arc-producer graph) ;;; (format excl:*initial-terminal-io* "~&Uh-oh! No cross-arc-producer!~%")) (with-slots (orientation) graph ;; We tranformed the position of the nodes when we inserted them into ;; output history, so the bounding rectangles queried below will be ;; transformed. Therefore, disable the transformation now, otherwise ;; the transformation is effectively applied twice to the edges. (when (cross-arc-producer graph) (with-identity-transformation (stream) ;; for some damn reason, this graph traversal isn't working.... (traverse-graph-nodes graph (lambda (node children continuation) ;;; (format excl:*initial-terminal-io* ;;; "~&Invoking traverse function on ~S and ~S!~%" node children) (unless (eq node graph) (multiple-value-bind (source-siblings types) (funcall (cross-arc-producer graph) (graph-node-object node)) ;; there's a kind of odd loop here ;; because types might be NIL. Using ;; a built-in stepper would cause the ;; loop to terminate too soon if types ;; was nil [2005/05/06:rpg] (loop for ss in source-siblings for k = (lookup-node ss graph) for typelist = types then (cdr typelist) for type = (when typelist (car typelist)) do (multiple-value-bind (fromx fromy tox toy) (cross-arc-routing node k orientation) (apply (cross-arc-drawer graph) stream node k fromx fromy tox toy :edge-type type (cross-arc-drawing-options graph)))))) (map nil continuation children))))))) From thenriksen at common-lisp.net Mon Mar 12 17:36:52 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 12 Mar 2007 12:36:52 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070312173652.A1EC474307@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv12716 Modified Files: bordered-output.lisp Log Message: Added some valid default values for line styles in borders. --- /project/mcclim/cvsroot/mcclim/bordered-output.lisp 2007/02/05 03:16:55 1.15 +++ /project/mcclim/cvsroot/mcclim/bordered-output.lisp 2007/03/12 17:36:52 1.16 @@ -175,9 +175,9 @@ `(or line-style (merge-line-styles (make-line-style - :unit line-unit - :thickness line-thickness - :cap-shape line-cap-shape + :unit (or line-unit :point) + :thickness (or line-thickness 1) + :cap-shape (or line-cap-shape :butt) :dashes line-dashes) (medium-line-style stream)))) From ahefner at gmail.com Mon Mar 12 18:35:40 2007 From: ahefner at gmail.com (Andy Hefner) Date: Mon, 12 Mar 2007 14:35:40 -0400 Subject: [mcclim-cvs] CVS mcclim In-Reply-To: <20070312173652.A1EC474307@common-lisp.net> References: <20070312173652.A1EC474307@common-lisp.net> Message-ID: <31ffd3c40703121135j64c08589md28b58cfa5a463d0@mail.gmail.com> Doesn't supplying defaults defeat the purpose of merging with the medium line style? On 3/12/07, thenriksen wrote: > Update of /project/mcclim/cvsroot/mcclim > In directory clnet:/tmp/cvs-serv12716 > > Modified Files: > bordered-output.lisp > Log Message: > Added some valid default values for line styles in borders. > From dlichteblau at common-lisp.net Wed Mar 14 23:30:54 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 14 Mar 2007 18:30:54 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/Graphic-Forms Message-ID: <20070314233054.0DD35471AA@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv19587/Graphic-Forms Log Message: Directory /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms added to the repository From dlichteblau at common-lisp.net Wed Mar 14 23:33:24 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 14 Mar 2007 18:33:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070314233324.EAE99471A9@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19686 Modified Files: mcclim.asd ports.lisp Log Message: Added the native windows backend clim-graphic-forms, by Jack D. Unrue --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/02/04 12:55:43 1.54 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/03/14 23:33:24 1.55 @@ -62,7 +62,7 @@ (extensions:without-package-locks (load "gray-streams:gray-streams-library")) (load "gray-streams:gray-streams-library"))) - #-(or clx gtkairo) + #-(or clx gtkairo clim-graphic-forms) (require :clx) #+mp (when (eq mp::*initial-process* mp::*current-process*) (format t "~%~%You need to run (mp::startup-idle-and-top-level-loops) to start up the multiprocessing support.~%~%"))) @@ -409,6 +409,20 @@ (:file "frame-manager") (:file "gadgets"))))) +(defsystem :clim-graphic-forms + :depends-on (:clim :graphic-forms-uitoolkit) + :components + ((:module "Backends/Graphic-Forms" + :pathname #.(make-pathname :directory '(:relative "Backends" "Graphic-Forms")) + :components + ((:file "package") + (:file "utils" :depends-on ("package")) + (:file "graft" :depends-on ("package")) + (:file "port" :depends-on ("utils" "graft")) + (:file "medium" :depends-on ("port")) + (:file "frame-manager" :depends-on ("medium")) + (:file "gadgets" :depends-on ("port")))))) + ;;; TODO/asf: I don't have the required libs to get :clim-opengl to load. tough. (clim-defsystem (:clim-opengl :depends-on (:clim)) "Backends/OpenGL/opengl-x-frame-manager" @@ -425,8 +439,10 @@ :depends-on (:clim :clim-postscript ;; If we're on an implementation that ships CLX, use ;; it. Same if the user has loaded CLX already. - #+(and (or sbcl scl openmcl ecl clx allegro) (not gtkairo)) + #+(and (or sbcl scl openmcl ecl clx allegro) + (not (or gtkairo clim-graphic-forms))) :clim-clx + #+clim-graphic-forms :clim-graphic-forms #+gl :clim-opengl ;; OpenMCL and MCL support the beagle backend (native ;; OS X look&feel on OS X). @@ -440,7 +456,7 @@ ;; null backend :clim-null ) - :components (#-gtkairo + :components (#-(or gtkairo clim-graphic-forms) (:file "Looks/pixie" :pathname #.(make-pathname :directory '(:relative "Looks") :name "pixie" :type "lisp")))) --- /project/mcclim/cvsroot/mcclim/ports.lisp 2007/02/07 12:44:17 1.55 +++ /project/mcclim/cvsroot/mcclim/ports.lisp 2007/03/14 23:33:24 1.56 @@ -25,7 +25,18 @@ (defvar *default-server-path* nil) -(defvar *server-path-search-order* '(:genera :ms-windows :gtkairo :clx :x11 :opengl :beagle :null)) +;; - CLX is the de-facto reference backend. +;; - Prefer Graphic-Forms and Gtkairo over CLX, since they get installed only +;; on explicit user request anyway. +;; - If both are present, use Graphics-Forms in favour of Gtkairo, since +;; it is the native Windows backend. +;; - Beagle should be treated like Graphic-Forms in the long term, but is +;; currently lacking a maintainer, so let's leave it near the end. +;; - OpenGL and Null are in this list mostly to document their existence, +;; and neither is currently a complete backend we would want to make +;; a default. Put them after CLX, so that they won't actually be reached. +(defvar *server-path-search-order* + '(:graphic-forms :gtkairo :clx :opengl :beagle :null)) (defun find-default-server-path () (loop for port in *server-path-search-order* From dlichteblau at common-lisp.net Wed Mar 14 23:33:25 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 14 Mar 2007 18:33:25 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/Graphic-Forms Message-ID: <20070314233325.4B1AC471A9@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv19686/Backends/Graphic-Forms Added Files: frame-manager.lisp gadgets.lisp graft.lisp medium.lisp package.lisp port.lisp utils.lisp Log Message: Added the native windows backend clim-graphic-forms, by Jack D. Unrue --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/frame-manager.lisp 2007/03/14 23:33:25 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/frame-manager.lisp 2007/03/14 23:33:25 1.1 ;;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS -*- ;;; (c) 2006 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes at gold.ac.uk) ;;; 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-graphic-forms) (defclass graphic-forms-frame-manager (frame-manager) ()) (defmethod make-pane-1 ((fmgr graphic-forms-frame-manager) (frame application-frame) type &rest initargs) #+nil (gfs::debug-format "make-pane-1 type: ~a initargs: ~a~%" type initargs) (apply #'make-pane-2 type :manager fmgr :frame frame :port (port frame) initargs)) (defmethod adopt-frame :after ((fmgr graphic-forms-frame-manager) (frame application-frame)) ()) (defmethod note-space-requirements-changed :after ((graft graphic-forms-graft) pane) (gfs::debug-format "space requirements changed: ~a~%" pane)) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/14 23:33:25 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/14 23:33:25 1.1 ;;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS; -*- ;;; (c) 2006-2007 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes at gold.ac.uk) ;;; 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-graphic-forms) ;;; ;;; base widget behaviors ;;; (defmethod activate-gadget ((widget gfw-widget-pane-mixin)) (with-slots (active-p) widget (unless active-p (gfw:enable (sheet-mirror widget) t))) (call-next-method)) (defmethod deactivate-gadget ((widget gfw-widget-pane-mixin)) (with-slots (active-p) widget (unless active-p (gfw:enable (sheet-mirror widget) nil))) (call-next-method)) ;;; ;;; menus ;;; (defun append-menu-items (port menu-pane) (let ((table-name (command-table menu-pane))) (when table-name (let ((table (find-command-table table-name))) (dolist (thing (slot-value table 'climi::menu)) (let* ((sub-table-name (if (eql (command-menu-item-type thing) :menu) (command-table-name thing) nil)) (sub-pane (climi::make-menu-button-from-menu-item thing nil :command-table sub-table-name))) (if (eql (command-menu-item-type thing) :command) (setf (gadget-label sub-pane) (climi::command-menu-item-name thing) (item sub-pane) thing) (setf (label sub-pane) (climi::command-menu-item-name thing))) (setf (sheet-parent sub-pane) menu-pane) (realize-mirror port sub-pane)))))) (dolist (menu-item (contents menu-pane)) (unless (integerp menu-item) (setf (sheet-parent menu-item) menu-pane) (realize-mirror port menu-item)))) (defmethod make-pane-2 ((type (eql 'climi::menu-bar)) &rest initargs) (apply #'make-instance 'gfw-menu-bar-pane initargs)) (defmethod realize-mirror ((port graphic-forms-port) (pane gfw-menu-bar-pane)) (let* ((top-level (sheet-mirror (sheet-parent (sheet-parent pane)))) (mirror (gfw:menu-bar top-level))) (setf (sheet mirror) pane) (climi::port-register-mirror port pane mirror) (append-menu-items port pane) mirror)) (defmethod destroy-mirror ((port graphic-forms-port) (pane gfw-menu-bar-pane)) (let ((mirror (climi::port-lookup-mirror port pane))) (climi::port-unregister-mirror port pane mirror))) (defmethod make-pane-2 ((type (eql 'climi::menu-button-submenu-pane)) &rest initargs) (apply #'make-instance 'gfw-menu-pane initargs)) (defmethod realize-mirror ((port graphic-forms-port) (pane gfw-menu-pane)) (let* ((parent (sheet-mirror (sheet-parent pane))) (mirror (make-instance 'gfw-menu :sheet pane :handle (gfs::create-popup-menu)))) (gfw:append-submenu parent (label pane) mirror nil) (climi::port-register-mirror port pane mirror) (append-menu-items port pane) mirror)) (defmethod destroy-mirror ((port graphic-forms-port) (pane gfw-menu-pane)) (let ((mirror (climi::port-lookup-mirror port pane))) (climi::port-unregister-mirror port pane mirror))) (defmethod make-pane-2 ((type (eql 'climi::menu-button-leaf-pane)) &rest initargs) (apply #'make-instance 'gfw-menu-item-pane initargs)) (defmethod realize-mirror ((port graphic-forms-port) (pane gfw-menu-item-pane)) (let* ((menu (sheet-mirror (sheet-parent pane))) (mirror (gfw:append-item menu (gadget-label pane) *pane-dispatcher* nil nil 'gfw-menu-item))) (setf (sheet mirror) pane) (climi::port-register-mirror port pane mirror) mirror)) (defmethod destroy-mirror ((port graphic-forms-port) (pane gfw-menu-item-pane)) (let ((mirror (climi::port-lookup-mirror port pane))) (climi::port-unregister-mirror port pane mirror))) (defmethod realize-mirror ((port graphic-forms-port) (pane climi::menu-divider-leaf-pane)) (let* ((menu (sheet-mirror (sheet-parent pane))) (mirror (gfw:append-separator menu))) (climi::port-register-mirror port pane mirror) mirror)) (defmethod destroy-mirror ((port graphic-forms-port) (pane climi::menu-divider-leaf-pane)) (let ((mirror (climi::port-lookup-mirror port pane))) (climi::port-unregister-mirror port pane mirror))) ;;; ;;; other gadgets ;;; (defmethod realize-mirror ((port graphic-forms-port) (gadget push-button)) (gfs::debug-format "realizing ~a~%" gadget) (let* ((parent-mirror (sheet-mirror (sheet-parent gadget))) (mirror (make-instance 'gfw-button :parent parent-mirror :style '(:push-button)))) (if (gadget-label gadget) (setf (gfw:text mirror) (gadget-label gadget))) (climi::port-register-mirror port gadget mirror) mirror)) (defmethod realize-mirror ((port graphic-forms-port) (gadget toggle-button)) (gfs::debug-format "realizing ~a~%" gadget) (let* ((parent-mirror (sheet-mirror (sheet-parent gadget))) (mirror (make-instance 'gfw-button :parent parent-mirror :style '(:check-box)))) (if (gadget-label gadget) (setf (gfw:text mirror) (gadget-label gadget))) (climi::port-register-mirror port gadget mirror) mirror)) (defmethod realize-mirror ((port graphic-forms-port) (gadget scroll-bar)) (gfs::debug-format "realizing ~a~%" gadget) (let* ((parent-mirror (sheet-mirror (sheet-parent gadget))) (mirror (make-instance 'gfw-scrollbar :parent parent-mirror :style :vertical))) (climi::port-register-mirror port gadget mirror) mirror)) (defmethod destroy-mirror ((port graphic-forms-port) (gadget value-gadget)) (let ((mirror (climi::port-lookup-mirror port gadget))) (climi::port-unregister-mirror port gadget mirror))) (defmethod destroy-mirror ((port graphic-forms-port) (gadget action-gadget)) (let ((mirror (climi::port-lookup-mirror port gadget))) (climi::port-unregister-mirror port gadget mirror))) ;;; ;;; layout ;;; (defmethod compose-space ((gadget action-gadget) &key width height) (declare (ignore width height)) (let ((mirror (climi::port-lookup-mirror (port gadget) gadget)) (pref-size (gfs:make-size :width 100 :height 100))) (if mirror (setf pref-size (gfw:preferred-size mirror -1 -1)) (progn (gfs::debug-format "compose-space parent: ~a~%" (sheet-mirror (sheet-parent gadget))) (setf mirror (make-instance 'gfw:button :parent (sheet-mirror (sheet-parent gadget)) :text (gadget-label gadget))) (setf pref-size (gfw:preferred-size mirror -1 -1)) (gfs:dispose mirror) (setf mirror nil))) (gfs::debug-format "pref size ~a for ~a mirror ~a~%" pref-size gadget mirror) (make-space-requirement :width (gfs:size-width pref-size) :height (gfs:size-height pref-size)))) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/graft.lisp 2007/03/14 23:33:25 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/graft.lisp 2007/03/14 23:33:25 1.1 ;;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS -*- ;;; (c) 2006-2007 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes at gold.ac.uk) ;;; 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-graphic-forms) (defclass graphic-forms-graft (graft) ()) (defmethod graft-width ((graft graphic-forms-graft) &key (units :device)) (gfw:with-root-window (window) (let ((size (gfs:size window))) (gfw:with-graphics-context (gc window) (ecase units (:device (gfs:size-width size)) (:millimeters (gfs::get-device-caps (gfs:handle gc) gfs::+horzsize+)) (:inches (floor (gfs:size-width size) (gfs::get-device-caps (gfs:handle gc) gfs::+logpixelsx+))) (:screen-sized 1)))))) (defmethod graft-height ((graft graphic-forms-graft) &key (units :device)) (gfw:with-root-window (window) (let ((size (first (gethash (gfs:obtain-system-metrics) :display-sizes)))) (gfw:with-graphics-context (gc window) (ecase units (:device (gfs:size-height size)) (:millimeters (gfs::get-device-caps (gfs:handle gc) gfs::+vertsize+)) (:inches (floor (gfs:size-height size) (gfs::get-device-caps (gfs:handle gc) gfs::+logpixelsy+))) (:screen-sized 1)))))) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/14 23:33:25 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/14 23:33:25 1.1 ;;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS -*- ;;; (c) 2006 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes at gold.ac.uk) ;;; 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-graphic-forms) (defclass graphic-forms-medium (basic-medium) ((font :accessor font-of :initform nil) (image :accessor image-of :initform nil) (port :accessor port-of :initarg :port :initform nil))) (defvar *medium-origin* (gfs:make-point)) (defvar *mediums-to-render* nil) (defun add-medium-to-render (medium) (pushnew medium *mediums-to-render* :test #'eql)) (defun remove-medium-to-render (medium) (setf *mediums-to-render* (remove medium *mediums-to-render*))) (defun render-medium (medium) (let ((mirror (climi::port-lookup-mirror (port-of medium) (medium-sheet medium)))) (gfw:with-graphics-context (gc mirror) (gfg:draw-image gc (image-of medium) *medium-origin*)))) (defun render-pending-mediums () (loop for medium in *mediums-to-render* do (render-medium medium)) (setf *mediums-to-render* nil)) (defun resize-medium-buffer (medium size) (let ((old-image (image-of medium))) (when old-image (if (not (gfs:disposed-p old-image)) (let ((old-size (gfg:size old-image))) (unless (gfs:equal-size-p size old-size) (gfs:dispose old-image) (setf old-image nil))) (setf old-image nil))) (unless old-image (setf (image-of medium) (make-instance 'gfg:image :size size))))) (defun destroy-medium (medium) (remove-medium-to-render medium) (let ((image (image-of medium))) (if (and image (not (gfs:disposed-p image))) (gfs:dispose image))) (let ((font (font-of medium))) (if (and font (not (gfs:disposed-p font))) (gfs:dispose font)) (setf (font-of medium) nil))) (defun normalize-text-data (text) (etypecase text (string text) (character (string text)) (symbol (symbol-name text)))) (defun sync-text-style (medium text-style) (multiple-value-bind (family face size) (text-style-components (merge-text-styles text-style *default-text-style*)) #+nil (gfs::debug-format "family: ~a face: ~a size: ~a~%" family face size) ;; ;; FIXME: what to do about font data char sets? ;; ;; FIXME: externalize these specific choices so that applications can ;; have better control over them ;; (gfw:with-graphics-context (gc (climi::port-lookup-mirror (port-of medium) (medium-sheet medium))) (let ((old-data (if (font-of medium) (gfg:data-object (font-of medium) gc))) (face-name (case family ((:fix :fixed) "Lucida Console") (:serif "Times New Roman") (:sansserif "Arial"))) (pnt-size (case size (:tiny 6) (:very-small 8) (:small 10) (:normal 12) (:large 14) (:very-large 16) (:huge 18) (otherwise 10))) (style nil)) (pushnew (case face ((:bold :bold-italic :bold-oblique :italic-bold :oblique-bold) :bold) (otherwise :normal)) style) (pushnew (case face ((:bold-italic :italic :italic-bold) :italic) (otherwise :normal)) style) (pushnew (case family ((:fix :fixed) :fixed) (otherwise :normal)) style) (when (or (null old-data) (not (eql pnt-size (gfg:font-data-point-size old-data))) (string-not-equal face-name (gfg:font-data-face-name old-data)) (/= (length style) (length (intersection style (gfg:font-data-style old-data))))) (when old-data (gfs:dispose (font-of medium)) (setf (font-of medium) nil)) (let ((new-data (gfg:make-font-data :face-name face-name :point-size pnt-size :style style))) #+nil (gfs::debug-format "new font data: ~a~%" new-data) (setf (font-of medium) (make-instance 'gfg:font :gc gc :data new-data)))))))) (defmethod (setf medium-text-style) :before (text-style (medium graphic-forms-medium)) (sync-text-style medium (merge-text-styles (medium-text-style medium) (medium-default-text-style medium)))) (defmethod (setf medium-line-style) :before (line-style (medium graphic-forms-medium)) [197 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/package.lisp 2007/03/14 23:33:25 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/package.lisp 2007/03/14 23:33:25 1.1 [222 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/14 23:33:25 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/14 23:33:25 1.1 [661 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/utils.lisp 2007/03/14 23:33:25 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/utils.lisp 2007/03/14 23:33:25 1.1 [714 lines skipped] From dlichteblau at common-lisp.net Wed Mar 14 23:42:41 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 14 Mar 2007 18:42:41 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/Graphic-Forms Message-ID: <20070314234241.18A5074307@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv21895 Modified Files: gadgets.lisp graft.lisp medium.lisp port.lisp Log Message: g-f fixes, including keyboard and mouse events. * Backends/Graphic-Forms/gadgets.lisp (REALIZE-MIRROR): Spell gfw-scroll-bar correctly, with a dash. * Backends/Graphic-Forms/graft.lisp (graft-height): Fixed order of arguments to gethash. * Backends/Graphic-Forms/medium.lisp (sync-text-style): It's :sans-serif, not :sansserif. Use ECASE to avoid this going undetected. Allow family names that are strings, not symbols, and pass them through unchanged. * Backends/Graphic-Forms/port.lisp (resolve-abstract-pane-name): Copy&paste from gtkairo. (make-pane-2): Call make-instance with a real class name, not the pane type spec. ((realize-mirror mirrored-sheet-mixin)): Removed the :border style. (port-frame-keyboard-input-focus, and its setf method): New methods. (translate-button-name, char-to-sym): New functions. (gfw:event-mouse-move, gfw:event-mouse-up, gfw:event-mouse-down, gfw:event-key-up, gfw:event-key-down): New methods. --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/14 23:33:25 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/14 23:42:40 1.2 @@ -141,7 +141,7 @@ (defmethod realize-mirror ((port graphic-forms-port) (gadget scroll-bar)) (gfs::debug-format "realizing ~a~%" gadget) (let* ((parent-mirror (sheet-mirror (sheet-parent gadget))) - (mirror (make-instance 'gfw-scrollbar :parent parent-mirror :style :vertical))) + (mirror (make-instance 'gfw-scroll-bar :parent parent-mirror :style :vertical))) (climi::port-register-mirror port gadget mirror) mirror)) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/graft.lisp 2007/03/14 23:33:25 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/graft.lisp 2007/03/14 23:42:40 1.2 @@ -37,7 +37,7 @@ (defmethod graft-height ((graft graphic-forms-graft) &key (units :device)) (gfw:with-root-window (window) - (let ((size (first (gethash (gfs:obtain-system-metrics) :display-sizes)))) + (let ((size (first (gethash :display-sizes (gfs:obtain-system-metrics))))) (gfw:with-graphics-context (gc window) (ecase units (:device (gfs:size-height size)) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/14 23:33:25 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/14 23:42:40 1.2 @@ -92,10 +92,12 @@ ;; (gfw:with-graphics-context (gc (climi::port-lookup-mirror (port-of medium) (medium-sheet medium))) (let ((old-data (if (font-of medium) (gfg:data-object (font-of medium) gc))) - (face-name (case family - ((:fix :fixed) "Lucida Console") - (:serif "Times New Roman") - (:sansserif "Arial"))) + (face-name (if (stringp family) + family + (ecase family + ((:fix :fixed) "Lucida Console") + (:serif "Times New Roman") + (:sans-serif "Arial")))) (pnt-size (case size (:tiny 6) (:very-small 8) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/14 23:33:25 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/14 23:42:40 1.2 @@ -122,10 +122,21 @@ (setf (get :graphic-forms :port-type) 'graphic-forms-port) (setf (get :graphic-forms :server-path-parser) 'parse-graphic-forms-server-path) +(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 + (or (find-class + (intern (concatenate 'string (symbol-name type) "-PANE") :climi) + nil) + (if (keywordp type) + (find-class (intern (symbol-name type) :climi)) + (find-class type))))) + (defgeneric make-pane-2 (type &rest initargs) (:documentation "Implement this to instantiate specific pane types.") (:method (type &rest initargs) - (apply #'make-instance type initargs))) + (apply #'make-instance (resolve-abstract-pane-name type) initargs))) ;;; ;;; helper functions @@ -211,7 +222,7 @@ (mirror (make-instance 'gfw-panel :sheet sheet :dispatcher *sheet-dispatcher* - :style '(:border) + :style '() ;was: '(:border) :parent parent))) (setf (gfw:size mirror) (requirement->size req)) (multiple-value-bind (x y) @@ -335,6 +346,16 @@ ;;; Set the keyboard input focus for the port. +(defmethod port-frame-keyboard-input-focus + ((port graphic-forms-port) frame) + ;; fixme + (frame-properties frame 'focus)) + +(defmethod (setf port-frame-keyboard-input-focus) + (focus (port graphic-forms-port) frame) + (gfw:give-focus (sheet-mirror focus)) + (setf (frame-properties frame 'focus) focus)) + (defmethod %set-port-keyboard-focus (focus (port graphic-forms-port) &key timestamp) (declare (ignore timestamp)) ()) @@ -420,6 +441,109 @@ :sheet (sheet (gfw:owner mirror)) :item (sheet mirror)))) +(defun translate-button-name (name) + (case name + (:left-button +pointer-left-button+) + (:right-button +pointer-right-button+) + (:middle-button +pointer-middle-button+) + (t + (warn "unknown button name: ~A" name) + nil))) + +(defmethod gfw:event-mouse-move + ((self sheet-event-dispatcher) mirror point button) + (setf (event (port self)) + (make-instance 'pointer-motion-event + :pointer 0 + :sheet (sheet mirror) + :x (gfs:point-x point) + :y (gfs:point-y point) + :button (translate-button-name button) + ;; FIXME: +;;; :timestamp +;;; :graft-x +;;; :graft-y + :modifier-state 0 + ))) + +(defmethod gfw:event-mouse-down ((self sheet-event-dispatcher) mirror point button) + (setf (event (port self)) + (make-instance 'pointer-button-press-event + :pointer 0 + :sheet (sheet mirror) + :x (gfs:point-x point) + :y (gfs:point-y point) + :button (translate-button-name button) + ;; FIXME: +;;; :timestamp +;;; :graft-x +;;; :graft-y + :modifier-state 0 + ))) + +(defmethod gfw:event-mouse-up ((self sheet-event-dispatcher) mirror point button) + (setf (event (port self)) + (make-instance 'pointer-button-release-event + :pointer 0 + :sheet (sheet mirror) + :x (gfs:point-x point) + :y (gfs:point-y point) + :button (translate-button-name button) + ;; FIXME: +;;; :timestamp +;;; :graft-x +;;; :graft-y + :modifier-state 0 + ))) + +(defun char-to-sym (char) + (case char + (#\ :| |) (#\! :!) (#\" :|"|) (#\# :|#|) (#\$ :$) (#\% :%) (#\& :&) + (#\' :|'|) (#\( :|(|) (#\) :|)|) (#\* :*) (#\+ :+) (#\, :|,|) (#\- :-) + (#\. :|.|) (#\/ :/) (#\0 :|0|) (#\1 :|1|) (#\2 :|2|) (#\3 :|3|) (#\4 :|4|) + (#\5 :|5|) (#\6 :|6|) (#\7 :|7|) (#\8 :|8|) (#\9 :|9|) (#\: :|:|) (#\; :|;|) + (#\< :<) (#\= :=) (#\> :>) (#\? :?) (#\@ :@) (#\A :A) (#\B :B) (#\C :C) + (#\D :D) (#\E :E) (#\F :F) (#\G :G) (#\H :H) (#\I :I) (#\J :J) (#\K :K) + (#\L :L) (#\M :M) (#\N :N) (#\O :O) (#\P :P) (#\Q :Q) (#\R :R) (#\S :S) + (#\T :T) (#\U :U) (#\V :V) (#\W :W) (#\X :X) (#\Y :Y) (#\Z :Z) (#\[ :[) + (#\\ :|\\|) (#\] :]) (#\_ :_) (#\` :|`|) (#\a :|a|) (#\b :|b|) (#\c :|c|) + (#\d :|d|) (#\e :|e|) (#\f :|f|) (#\g :|g|) (#\h :|h|) (#\i :|i|) (#\j :|j|) + (#\k :|k|) (#\l :|l|) (#\m :|m|) (#\n :|n|) (#\o :|o|) (#\p :|p|) (#\q :|q|) + (#\r :|r|) (#\s :|s|) (#\t :|t|) (#\u :|u|) (#\v :|v|) (#\w :|w|) (#\x :|x|) + (#\y :|y|) (#\z :|z|) (#\{ :{) (#\| :|\||) (#\} :}) (#\Backspace :BACKSPACE) + (#\Tab :TAB) (#\Return :RETURN) (#\Rubout :DELETE))) + +(defmethod gfw:event-key-down ((self sheet-event-dispatcher) mirror code char) + (setf (event (port self)) + (make-instance 'key-press-event + :key-name (char-to-sym char) + :key-character char + :sheet (sheet mirror) + ;; FIXME: + :x 0 + :y 0 + :modifier-state 0 +;;; :timestamp time +;;; :graft-x root-x +;;; :graft-y root-y + ))) + +(defmethod gfw:event-key-up ((self sheet-event-dispatcher) mirror code char) + (setf (event (port self)) + (make-instance 'key-release-event + :key-name (char-to-sym char) + :key-character char + :sheet (sheet mirror) + ;; FIXME: + :x 0 + :y 0 + :modifier-state 0 +;;; :timestamp time +;;; :graft-x root-x +;;; :graft-y root-y + ))) + + ;;; ;;; McCLIM handle-event methods ;;; From dlichteblau at common-lisp.net Fri Mar 16 14:42:51 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Fri, 16 Mar 2007 09:42:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/Graphic-Forms Message-ID: <20070316144251.4857545092@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv934 Modified Files: gadgets.lisp medium.lisp port.lisp utils.lisp Log Message: More little clim-g-f fixes. demodemo still looks terrible but its buttons work. The Quit menu in the address book works. * Backends/Graphic-Forms/gadgets.lisp ((REALIZE-MIRROR PUSH-BUTTON)): Set the dispatcher. * Backends/Graphic-Forms/medium.lisp (add-medium-to-render): Do it only if the double buffering image has been installed. (RENDER-MEDIUM-BUFFER): Renamed from render-medium, since it is only used for the buffering image. (RENDER-PENDING-MEDIUMS): Use render-medium-buffer. (INK-TO-COLOR): New function. (TARGET-OF): Return (and create if needed) image-of, or return the normal mirror if no buffering has been requested. (TEXT-STYLE-TO-FONT): New function, based on the old sync-text-style. (SYNC-TEXT-STYLE): Use text-style-to-font. (MEDIUM-DRAW-POLYGON, MEDIUM-DRAW-RECTANGLE*): Use the medium ink. Use target-of instead of image-of. (TEXT-STYLE-*, MEDIUM-DRAW-TEXT*, MEDIUM-CLEAR-AREA): Use target-of instead of image-of. (TEXT-SIZE): Merge the text styles properly. (MEDIUM-DRAW-TEXT*): At least make some effort to draw the text above the y coordinate, not below it. Probably not correct yet. (MEDIUM-FINISH-OUTPUT, MEDIUM-FORCE-OUTPUT): Only if image-of is set. * Backends/Graphic-Forms/port.lisp (GFW-MENU-ITEM-PANE): New slot callback, needed for those commands that sit directly in the menu bar. (SHEET-DESIRED-INK): Copy&paste from CLX. (EVENT-PAINT): Clear the affected area with the desired color when enqueing an repaint, as expected by the frontend. (EVENT-RESIZE): Resize image-of only if it exists. (GADGET-EVENT, BUTTON-PRESSED-EVENT): New classes. (EVENT-SELECT): Handle push buttons. ((HANDLE-EVENT PUSH-BUTTON BUTTON-PRESSED-EVENT)): New method. (HANDLE-MENU-CLICKED-EVENT): Call the callback if present. * Backends/Graphic-Forms/utils.lisp (COORDINATES->POINTS): Rewritten to loop over the vector (it's not a list). --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/14 23:42:40 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/16 14:42:49 1.3 @@ -123,7 +123,11 @@ (defmethod realize-mirror ((port graphic-forms-port) (gadget push-button)) (gfs::debug-format "realizing ~a~%" gadget) (let* ((parent-mirror (sheet-mirror (sheet-parent gadget))) - (mirror (make-instance 'gfw-button :parent parent-mirror :style '(:push-button)))) + (mirror (make-instance 'gfw-button + :sheet gadget + :parent parent-mirror + :dispatcher *pane-dispatcher* + :style '(:push-button)))) (if (gadget-label gadget) (setf (gfw:text mirror) (gadget-label gadget))) (climi::port-register-mirror port gadget mirror) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/14 23:49:05 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/16 14:42:49 1.4 @@ -37,21 +37,45 @@ (defvar *mediums-to-render* nil) (defun add-medium-to-render (medium) - (pushnew medium *mediums-to-render* :test #'eql)) + (when (image-of medium) + (pushnew medium *mediums-to-render* :test #'eql))) (defun remove-medium-to-render (medium) (setf *mediums-to-render* (remove medium *mediums-to-render*))) -(defun render-medium (medium) +(defun render-medium-buffer (medium) (let ((mirror (climi::port-lookup-mirror (port-of medium) (medium-sheet medium)))) (gfw:with-graphics-context (gc mirror) (gfg:draw-image gc (image-of medium) *medium-origin*)))) (defun render-pending-mediums () (loop for medium in *mediums-to-render* - do (render-medium medium)) + do (render-medium-buffer medium)) (setf *mediums-to-render* nil)) +(defun ink-to-color (medium ink) + (cond + ((eql ink +foreground-ink+) + (setf ink (medium-foreground medium))) + ((eql ink +background-ink+) + (setf ink (medium-background medium)))) + (multiple-value-bind (red green blue) (clim:color-rgb ink) + (gfg:make-color :red (truncate (* red 256)) + :green (truncate (* green 256)) + :blue (truncate (* blue 256))))) + +(defun target-of (medium) + (let ((sheet (medium-sheet medium))) + (if (climi::pane-double-buffering sheet) + (or (image-of medium) + (let* ((region (climi::sheet-mirror-region sheet)) + (width (floor (bounding-rectangle-max-x region))) + (height (floor (bounding-rectangle-max-y region)))) + (setf (image-of medium) + (make-instance 'gfg:image + :size (gfs:make-size width height))))) + (sheet-mirror (medium-sheet medium))))) + (defun resize-medium-buffer (medium size) (let ((old-image (image-of medium))) (when old-image @@ -81,6 +105,19 @@ (symbol (symbol-name text)))) (defun sync-text-style (medium text-style) + (gfw:with-graphics-context + (gc (climi::port-lookup-mirror (port-of medium) (medium-sheet medium))) + (let* ((old-data + (when (font-of medium) + (gfg:data-object (font-of medium) gc))) + (new-font (text-style-to-font gc text-style old-data))) + (when new-font + (when old-data + (gfs:dispose (font-of medium)) + (setf (font-of medium) nil)) + (setf (font-of medium) new-font))))) + +(defun text-style-to-font (gc text-style old-data) (multiple-value-bind (family face size) (text-style-components (merge-text-styles text-style *default-text-style*)) #+nil (gfs::debug-format "family: ~a face: ~a size: ~a~%" family face size) @@ -90,53 +127,47 @@ ;; FIXME: externalize these specific choices so that applications can ;; have better control over them ;; - (gfw:with-graphics-context (gc (climi::port-lookup-mirror (port-of medium) (medium-sheet medium))) - (let ((old-data (if (font-of medium) (gfg:data-object (font-of medium) gc))) - (face-name (if (stringp family) - family - (ecase family - ((:fix :fixed) "Lucida Console") - (:serif "Times New Roman") - (:sans-serif "Arial")))) - (pnt-size (case size - (:tiny 6) - (:very-small 8) - (:small 10) - (:normal 12) - (:large 14) - (:very-large 16) - (:huge 18) - (otherwise 10))) - (style nil)) - (pushnew (case face - ((:bold :bold-italic :bold-oblique :italic-bold :oblique-bold) - :bold) - (otherwise - :normal)) - style) - (pushnew (case face - ((:bold-italic :italic :italic-bold) - :italic) - (otherwise - :normal)) - style) - (pushnew (case family - ((:fix :fixed) :fixed) - (otherwise :normal)) - style) - (when (or (null old-data) - (not (eql pnt-size (gfg:font-data-point-size old-data))) - (string-not-equal face-name (gfg:font-data-face-name old-data)) - (/= (length style) - (length (intersection style (gfg:font-data-style old-data))))) - (when old-data - (gfs:dispose (font-of medium)) - (setf (font-of medium) nil)) - (let ((new-data (gfg:make-font-data :face-name face-name - :point-size pnt-size - :style style))) - #+nil (gfs::debug-format "new font data: ~a~%" new-data) - (setf (font-of medium) (make-instance 'gfg:font :gc gc :data new-data)))))))) + (let ((face-name (if (stringp family) + family + (ecase family + ((:fix :fixed) "Lucida Console") + (:serif "Times New Roman") + (:sans-serif "Arial")))) + (pnt-size (case size + (:tiny 6) + (:very-small 8) + (:small 10) + (:normal 12) + (:large 14) + (:very-large 16) + (:huge 18) + (otherwise 10))) + (style nil)) + (pushnew (case face + ((:bold :bold-italic :bold-oblique :italic-bold :oblique-bold) + :bold) + (otherwise + :normal)) + style) + (pushnew (case face + ((:bold-italic :italic :italic-bold) + :italic) + (otherwise + :normal)) + style) + (pushnew (case family + ((:fix :fixed) :fixed) + (otherwise :normal)) + style) + (when (or (null old-data) + (not (eql pnt-size (gfg:font-data-point-size old-data))) + (string-not-equal face-name (gfg:font-data-face-name old-data)) + (/= (length style) + (length (intersection style (gfg:font-data-style old-data))))) + (let ((new-data (gfg:make-font-data :face-name face-name + :point-size pnt-size + :style style))) + (make-instance 'gfg:font :gc gc :data new-data)))))) (defmethod (setf medium-text-style) :before (text-style (medium graphic-forms-medium)) (sync-text-style medium @@ -190,11 +221,12 @@ (defmethod medium-draw-polygon* ((medium graphic-forms-medium) coord-seq closed filled) #+nil (gfs::debug-format "draw-polygon ~a ~a ~a~%" coord-seq closed filled) - (when (image-of medium) - (gfw:with-graphics-context (gc (image-of medium)) - (setf (gfg:background-color gc) gfg:*color-white* - (gfg:foreground-color gc) gfg:*color-black*) - (let ((points-list (coordinates->points coord-seq))) + (when (target-of medium) + (gfw:with-graphics-context (gc (target-of medium)) + (let ((points-list (coordinates->points coord-seq)) + (color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color) (if filled (gfg:draw-filled-polygon gc points-list) (gfg:draw-polygon gc points-list)))) @@ -202,11 +234,12 @@ (defmethod medium-draw-rectangle* ((medium graphic-forms-medium) left top right bottom filled) #+nil (gfs::debug-format "draw-rectangle ~a ~a ~a ~a ~a~%" left top right bottom filled) - (when (image-of medium) - (gfw:with-graphics-context (gc (image-of medium)) - (setf (gfg:background-color gc) gfg:*color-white* - (gfg:foreground-color gc) gfg:*color-black*) - (let ((rect (coordinates->rectangle left top right bottom))) + (when (target-of medium) + (gfw:with-graphics-context (gc (target-of medium)) + (let ((rect (coordinates->rectangle left top right bottom)) + (color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color) (if filled (gfg:draw-filled-rectangle gc rect) (gfg:draw-rectangle gc rect)))) @@ -229,21 +262,21 @@ (defmethod text-style-ascent (text-style (medium graphic-forms-medium)) (let ((font (font-of medium))) (if font - (gfw:with-graphics-context (gc (image-of medium)) + (gfw:with-graphics-context (gc (target-of medium)) (gfg:ascent (gfg:metrics gc font))) 1))) (defmethod text-style-descent (text-style (medium graphic-forms-medium)) (let ((font (font-of medium))) (if font - (gfw:with-graphics-context (gc (image-of medium)) + (gfw:with-graphics-context (gc (target-of medium)) (gfg:descent (gfg:metrics gc font))) 1))) (defmethod text-style-height (text-style (medium graphic-forms-medium)) (let ((font (font-of medium))) (if font - (gfw:with-graphics-context (gc (image-of medium)) + (gfw:with-graphics-context (gc (target-of medium)) (gfg:height (gfg:metrics gc font))) 1))) @@ -252,7 +285,7 @@ (width 1) (text (normalize-text-data char))) (if font - (gfw:with-graphics-context (gc (image-of medium)) + (gfw:with-graphics-context (gc (target-of medium)) (setf (gfg:font gc) font) (setf width (gfs:size-width (gfg:text-extent gc text))))) width)) @@ -260,34 +293,30 @@ (defmethod text-style-width (text-style (medium graphic-forms-medium)) (let ((font (font-of medium))) (if font - (gfw:with-graphics-context (gc (image-of medium)) + (gfw:with-graphics-context (gc (target-of medium)) (gfg:average-char-width (gfg:metrics gc font))) 1))) (defmethod text-size ((medium graphic-forms-medium) string &key text-style (start 0) end) (setf string (normalize-text-data string)) -#| - (setf text-style (merge-text-styles (or text-style (make-text-style nil nil nil)) - (medium-default-text-style medium))) -|# - ;; FIXME: handle embedded newlines - ;; - (let ((font (font-of medium))) - (if font - (gfw:with-graphics-context (gc (image-of medium)) - (let ((metrics (gfg:metrics gc font)) - (width (gfs:size-width (gfg:text-extent gc (subseq string - start - (or end (length string))))))) - (values width - (gfg:height metrics) - width - (gfg:height metrics) - (gfg:ascent metrics)))) - (values 1 1 1 1 1)))) + (setf text-style (or text-style (make-text-style nil nil nil))) + (setf text-style + (merge-text-styles text-style (medium-default-text-style medium))) + (gfw:with-graphics-context (gc (target-of medium)) + (let* ((font (text-style-to-font gc text-style nil)) + (metrics (gfg:metrics gc font)) + (width (gfs:size-width (gfg:text-extent gc (subseq string + start + (or end (length string))))))) + (values width + (gfg:height metrics) + width + (gfg:height metrics) + (gfg:ascent metrics))))) (defmethod climi::text-bounding-rectangle* ((medium graphic-forms-medium) string &key text-style (start 0) end) + ;; fixme, completely wrong (text-size medium string :text-style text-style :start start :end end)) (defmethod medium-draw-text* ((medium graphic-forms-medium) string x y @@ -295,15 +324,18 @@ align-x align-y toward-x toward-y transform-glyphs) #+nil (gfs::debug-format "medium-draw-text: ~d, ~d ~s~%" x y string) - (when (image-of medium) + (when (target-of medium) (setf string (normalize-text-data string)) - (gfw:with-graphics-context (gc (image-of medium)) + (gfw:with-graphics-context (gc (target-of medium)) (let ((font (font-of medium))) (if font (setf (gfg:font gc) font)) - (gfg:draw-text gc - (subseq string start (or end (length string))) - (gfs:make-point :x x :y y)))) + (let ((h (gfg:height (gfg:metrics gc font))) + (x (round-coordinate x)) + (y (round-coordinate y))) + (gfg:draw-text gc + (subseq string start (or end (length string))) + (gfs:make-point :x x :y (- y h)))))) (add-medium-to-render medium))) (defmethod medium-buffering-output-p ((medium graphic-forms-medium)) @@ -318,15 +350,17 @@ ()) (defmethod medium-finish-output ((medium graphic-forms-medium)) - (render-medium medium)) + (when (image-of medium) + (render-medium-buffer medium))) (defmethod medium-force-output ((medium graphic-forms-medium)) - (render-medium medium)) + (when (image-of medium) + (render-medium-buffer medium))) (defmethod medium-clear-area ((medium graphic-forms-medium) left top right bottom) - (when (image-of medium) + (when (target-of medium) (let ((rect (coordinates->rectangle left top right bottom))) - (gfw:with-graphics-context (gc (image-of medium)) + (gfw:with-graphics-context (gc (target-of medium)) (setf (gfg:background-color gc) gfg:*color-white* (gfg:foreground-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc rect))) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/14 23:49:05 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/16 14:42:49 1.4 @@ -59,6 +59,7 @@ :accessor item :initarg :item :initform nil) + (callback :initarg :value-changed-callback :accessor callback) (command :accessor command :initarg :command @@ -408,12 +409,35 @@ (setf (event (port self)) (make-instance 'window-manager-delete-event :sheet (sheet mirror)))) +;; copy&paste from port.lisp|CLX: +(defun sheet-desired-ink (sheet) + (typecase sheet + (sheet-with-medium-mixin + (medium-background sheet)) + (basic-pane + ;; CHECKME [is this sensible?] seems to be + (let ((background (pane-background sheet))) + (if (typep background 'color) + background + +white+))) + (t + +white+))) + (defmethod gfw:event-paint ((self sheet-event-dispatcher) mirror gc rect) (declare (ignore gc)) (let ((sheet (sheet mirror))) - (setf (event (port self)) (make-instance 'window-repaint-event - :sheet sheet - :region (translate-rectangle rect))))) + (when (and (typep sheet 'sheet-with-medium-mixin) + (not (image-of (sheet-medium sheet)))) + (gfw:with-graphics-context (gc mirror) + (let ((c (ink-to-color (sheet-medium sheet) + (sheet-desired-ink sheet)))) + (setf (gfg:background-color gc) c + (gfg:foreground-color gc) c)) + (gfg:draw-filled-rectangle gc rect))) + (setf (event (port self)) + (make-instance 'window-repaint-event + :sheet sheet + :region (translate-rectangle rect))))) (defun generate-configuration-event (mirror pnt size) (make-instance 'window-configuration-event @@ -431,15 +455,26 @@ (let ((sheet (sheet mirror))) (if (and sheet (subtypep (class-of sheet) 'sheet-with-medium-mixin)) (let ((medium (climi::sheet-medium sheet))) - (if medium + (if (and medium (image-of medium)) (resize-medium-buffer medium size)))) (setf (event (port self)) (generate-configuration-event mirror (gfw:location mirror) size)))) +(defclass gadget-event (window-event) ()) +(defclass button-pressed-event (gadget-event) ()) + (defmethod gfw:event-select ((self pane-event-dispatcher) mirror) - (setf (event (port self)) (make-instance 'menu-clicked-event - :sheet (sheet (gfw:owner mirror)) - :item (sheet mirror)))) + (setf (event (port self)) + (typecase mirror + (gfw-button + (make-instance 'button-pressed-event :sheet (sheet mirror))) + (t + (make-instance 'menu-clicked-event + :sheet (sheet (gfw:owner mirror)) + :item (sheet mirror)))))) + +(defmethod handle-event ((pane push-button) (event button-pressed-event)) + (activate-callback pane (gadget-client pane) (gadget-id pane))) (defun translate-button-name (name) (case name @@ -553,8 +588,9 @@ (if pane (let ((menu-item (item pane))) (if menu-item - (if (eql (command-menu-item-type menu-item) :command) - (climi::throw-object-ptype menu-item 'menu-item))))))) + (if (eql (command-menu-item-type menu-item) :command) + (climi::throw-object-ptype menu-item 'menu-item)) + (funcall (callback pane) pane nil)))))) (defmethod handle-event ((pane gfw-menu-pane) (event menu-clicked-event)) (handle-menu-clicked-event event)) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/utils.lisp 2007/03/14 23:33:25 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/utils.lisp 2007/03/16 14:42:51 1.2 @@ -44,10 +44,8 @@ :width (round-coordinate (- right left)) :height (round-coordinate (- bottom top)))) -(defun coordinates->points (list) - (cond - ((null list) (values)) - ((and (car list) (cdr list)) - (concatenate 'list (list (gfs:make-point :x (round-coordinate (car list)) - :y (round-coordinate (car (cdr list))))) - (coordinates->points (cdr (cdr list))))))) +(defun coordinates->points (seq) + (loop for i from 2 below (length seq) by 2 + collect + (gfs:make-point :x (round-coordinate (elt seq i)) + :y (round-coordinate (elt seq (+ i 1)))))) From dlichteblau at common-lisp.net Fri Mar 16 15:31:57 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Fri, 16 Mar 2007 10:31:57 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/Graphic-Forms Message-ID: <20070316153157.83E17481AB@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv13705 Modified Files: medium.lisp Log Message: clim-g-f medium fixes: Handle transformations like CLIM-CLX does. Implemented missing medium functions (beware untested code). * Backends/Graphic-Forms/medium.lisp (MEDIUM-DRAW-POINT*, MEDIUM-DRAW-POINTS*, MEDIUM-DRAW-LINE*, MEDIUM-DRAW-LINES*, MEDIUM-DRAW-RECTANGLES*, MEDIUM-DRAW-ELLIPSE*, MEDIUM-DRAW-CIRCLE*): Implemented. (MEDIUM-DRAW-POLYGON*, MEDIUM-DRAW-RECTANGLE*): Transform the coordinates. (INK-TO-COLOR): Cap at 255. --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/16 14:42:49 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/16 15:31:56 1.5 @@ -1,4 +1,4 @@ -;;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS -*- +;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS -*- ;;; (c) 2006 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: @@ -60,9 +60,9 @@ ((eql ink +background-ink+) (setf ink (medium-background medium)))) (multiple-value-bind (red green blue) (clim:color-rgb ink) - (gfg:make-color :red (truncate (* red 256)) - :green (truncate (* green 256)) - :blue (truncate (* blue 256))))) + (gfg:make-color :red (min (truncate (* red 256)) 255) + :green (min (truncate (* green 256)) 255) + :blue (min (truncate (* blue 256)) 255)))) (defun target-of (medium) (let ((sheet (medium-sheet medium))) @@ -202,62 +202,163 @@ ())) (defmethod medium-draw-point* ((medium graphic-forms-medium) x y) - ()) + (when (target-of medium) + (gfw:with-graphics-context (gc (target-of medium)) + (let ((color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) + (let ((tr (sheet-native-transformation (medium-sheet medium)))) + (climi::with-transformed-position (tr x y) + (gfg:draw-point gc (gfs:make-point :x (round-coordinate x) + :y (round-coordinate y)))))) + (add-medium-to-render medium))) (defmethod medium-draw-points* ((medium graphic-forms-medium) coord-seq) - ()) + (when (target-of medium) + (gfw:with-graphics-context (gc (target-of medium)) + (let ((color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) + (let ((tr (sheet-native-transformation (medium-sheet medium)))) + (loop for (x y) on (coerce coord-seq 'list) by #'cddr do + (climi::with-transformed-position (tr x y) + (gfg:draw-point gc + (gfs:make-point :x (round-coordinate x) + :y (round-coordinate y))))))) + (add-medium-to-render medium))) (defmethod medium-draw-line* ((medium graphic-forms-medium) x1 y1 x2 y2) - ()) + (when (target-of medium) + (gfw:with-graphics-context (gc (target-of medium)) + (let ((color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) + (let ((tr (sheet-native-transformation (medium-sheet medium)))) + (climi::with-transformed-position (tr x1 y1) + (climi::with-transformed-position (tr x2 y2) + (gfg:draw-line gc + (gfs:make-point :x (round-coordinate x1) + :y (round-coordinate y1)) + (gfs:make-point :x (round-coordinate x2) + :y (round-coordinate y2))))))) + (add-medium-to-render medium))) -;; FIXME: Invert the transformation and apply it here, as the :around -;; methods on transform-coordinates-mixin will cause it to be applied -;; twice, and we need to undo one of those. The -;; transform-coordinates-mixin stuff needs to be eliminated. (defmethod medium-draw-lines* ((medium graphic-forms-medium) coord-seq) - (let ((tr (invert-transformation (medium-transformation medium)))) - (declare (ignore tr)) - nil)) + (when (target-of medium) + (gfw:with-graphics-context (gc (target-of medium)) + (let ((color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) + (let ((tr (sheet-native-transformation (medium-sheet medium)))) + (loop for (x1 y1 x2 y2) on (coerce coord-seq 'list) by #'cddddr do + (climi::with-transformed-position (tr x1 y1) + (climi::with-transformed-position (tr x2 y2) + (gfg:draw-line gc + (gfs:make-point :x (round-coordinate x1) + :y (round-coordinate y1)) + (gfs:make-point :x (round-coordinate x2) + :y (round-coordinate y2)))))))) + (add-medium-to-render medium))) (defmethod medium-draw-polygon* ((medium graphic-forms-medium) coord-seq closed filled) - #+nil (gfs::debug-format "draw-polygon ~a ~a ~a~%" coord-seq closed filled) (when (target-of medium) (gfw:with-graphics-context (gc (target-of medium)) - (let ((points-list (coordinates->points coord-seq)) - (color (ink-to-color medium (medium-ink medium)))) - (setf (gfg:background-color gc) color - (gfg:foreground-color gc) color) - (if filled - (gfg:draw-filled-polygon gc points-list) - (gfg:draw-polygon gc points-list)))) + (climi::with-transformed-positions + ((sheet-native-transformation (medium-sheet medium)) coord-seq) + (let ((points-list (coordinates->points coord-seq)) + (color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color) + (when (and closed (not filled)) + (push (car (last points-list)) points-list)) + (if filled + (gfg:draw-filled-polygon gc points-list) + (gfg:draw-polygon gc points-list))))) (add-medium-to-render medium))) (defmethod medium-draw-rectangle* ((medium graphic-forms-medium) left top right bottom filled) - #+nil (gfs::debug-format "draw-rectangle ~a ~a ~a ~a ~a~%" left top right bottom filled) (when (target-of medium) (gfw:with-graphics-context (gc (target-of medium)) - (let ((rect (coordinates->rectangle left top right bottom)) + (let ((tr (sheet-native-transformation (medium-sheet medium)))) + (climi::with-transformed-position (tr left top) + (climi::with-transformed-position (tr right bottom) + (let ((rect (coordinates->rectangle left top right bottom)) + (color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color) + (if filled + (gfg:draw-filled-rectangle gc rect) + (gfg:draw-rectangle gc rect))))))) + (add-medium-to-render medium))) + +(defmethod medium-draw-rectangles* ((medium graphic-forms-medium) position-seq filled) + (when (target-of medium) + (gfw:with-graphics-context (gc (target-of medium)) + (let ((tr (sheet-native-transformation (medium-sheet medium))) (color (ink-to-color medium (medium-ink medium)))) (setf (gfg:background-color gc) color (gfg:foreground-color gc) color) - (if filled - (gfg:draw-filled-rectangle gc rect) - (gfg:draw-rectangle gc rect)))) + (loop for i below (length position-seq) by 4 do + (let ((x1 (round-coordinate (elt position-seq (+ i 0)))) + (y1 (round-coordinate (elt position-seq (+ i 1)))) + (x2 (round-coordinate (elt position-seq (+ i 2)))) + (y2 (round-coordinate (elt position-seq (+ i 3))))) + (climi::with-transformed-position (tr x1 y1) + (climi::with-transformed-position (tr x2 y2) + (let ((rect (coordinates->rectangle x1 y1 x2 y2))) + (if filled + (gfg:draw-filled-rectangle gc rect) + (gfg:draw-rectangle gc rect))))))))) (add-medium-to-render medium))) -(defmethod medium-draw-rectangles* ((medium graphic-forms-medium) position-seq filled) - ()) - +;; FIXME: completely untested. Not sure we're even using the right GFG h +;; functions. Are start-point and end-point right? (defmethod medium-draw-ellipse* ((medium graphic-forms-medium) center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled) - ()) + (unless (or (= radius-2-dx radius-1-dy 0) (= radius-1-dx radius-2-dy 0)) + (error "MEDIUM-DRAW-ELLIPSE* not for non axis-aligned ellipses.")) + (when (target-of medium) + (gfw:with-graphics-context (gc (target-of medium)) + (let ((color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) + (climi::with-transformed-position + ((sheet-native-transformation (medium-sheet medium)) + center-x center-y) + (let* ((radius-dx (abs (+ radius-1-dx radius-2-dx))) + (radius-dy (abs (+ radius-1-dy radius-2-dy))) + (min-x (round-coordinate (- center-x radius-dx))) + (min-y (round-coordinate (- center-y radius-dy))) + (max-x (round-coordinate (+ center-x radius-dx))) + (max-y (round-coordinate (+ center-y radius-dy))) + (rect (coordinates->rectangle min-x min-y max-x max-y)) + (start-point + (gfs:make-point :x (round-coordinate + (* (cos start-angle) radius-dx)) + :y (round-coordinate + (* (sin start-angle) radius-dy)))) + (end-point + (gfs:make-point :x (round-coordinate + (* (cos end-angle) radius-dx)) + :y (round-coordinate + (* (sin end-angle) radius-dy))))) + (if filled + (gfg:draw-filled-pie-wedge gc rect start-point end-point) + (gfg:draw-pie-wedge gc rect start-point end-point))))) + (add-medium-to-render medium))) +;; FIXME: completely untested. (defmethod medium-draw-circle* ((medium graphic-forms-medium) center-x center-y radius start-angle end-angle filled) - ()) + (medium-draw-ellipse* medium + center-x center-y + radius radius + radius radius + start-angle end-angle + filled)) (defmethod text-style-ascent (text-style (medium graphic-forms-medium)) (let ((font (font-of medium))) From junrue at common-lisp.net Sun Mar 18 03:02:23 2007 From: junrue at common-lisp.net (junrue) Date: Sat, 17 Mar 2007 22:02:23 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/Graphic-Forms Message-ID: <20070318030223.AB8C234025@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv13475 Modified Files: graft.lisp Log Message: fixed a typo in graft-width; revised graft-height to be consistent in how the desktop window size is obtained --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/graft.lisp 2007/03/14 23:49:05 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/graft.lisp 2007/03/18 03:02:22 1.4 @@ -26,7 +26,7 @@ (defmethod graft-width ((graft graphic-forms-graft) &key (units :device)) (gfw:with-root-window (window) - (let ((size (gfs:size window))) + (let ((size (gfw:size window))) (gfw:with-graphics-context (gc window) (ecase units (:device (gfs:size-width size)) @@ -37,7 +37,7 @@ (defmethod graft-height ((graft graphic-forms-graft) &key (units :device)) (gfw:with-root-window (window) - (let ((size (first (gethash :display-sizes (gfs:obtain-system-metrics))))) + (let ((size (gfw:size window))) (gfw:with-graphics-context (gc window) (ecase units (:device (gfs:size-height size)) From dlichteblau at common-lisp.net Sun Mar 18 14:29:00 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 18 Mar 2007 09:29:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/Graphic-Forms Message-ID: <20070318142900.F0714A0F2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv5295 Modified Files: port.lisp Log Message: No idea why graphic-forms works this way, but get-next-event consistently processed more than one event, all of which were discarded except for the last one. Push the events into a list instead and return them in order. This fixes disappearing pane contents, since most repaint events were lost. * Backends/Graphic-Forms/port.lisp (GRAPHIC-FORMS-PORT): New slot EVENTS, renamed from EVENT. (ENQUEUE): New function. (GET-NEXT-EVENT): Rewritten to pop from EVENTS. (EVENT-CLOSE, EVENT-PAINT, EVENT-MOVE, EVENT-RESIZE, EVENT-SELECT, EVENT-MOUSE-MOVE, EVENT-MOUSE-UP, EVENT-MOUSE-DOWN, EVENT-KEY-DOWN, EVENT-KEY-UP): Use enqueue. --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/16 14:42:49 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/18 14:29:00 1.5 @@ -103,13 +103,16 @@ (defclass graphic-forms-port (basic-port) ((id) - (event - :accessor event + (events + :accessor events :initform nil) (pointer :accessor port-pointer :initform (make-instance 'gfw-pointer)))) +(defun enqueue (port event) + (push event (events port))) + (defvar *sheet-dispatcher* (make-instance 'sheet-event-dispatcher)) (defvar *pane-dispatcher* (make-instance 'pane-event-dispatcher)) @@ -263,20 +266,17 @@ (defmethod get-next-event ((port graphic-forms-port) &key wait-function (timeout nil)) (declare (ignore wait-function timeout)) ; FIXME - (setf (event port) nil) - (cffi:with-foreign-object (msg-ptr 'gfs::msg) - (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0)) - (event nil)) - (cffi:with-foreign-slots ((gfs::hwnd gfs::message gfs::wparam gfs::lparam - gfs::time gfs::pnt) - msg-ptr gfs::msg) - (unless (gfw::default-message-filter gm msg-ptr) - (if (setf event (event port)) - (setf (slot-value event 'climi::timestamp) gfs::time) - #+nil (gfs::debug-format "unhandled Win32 message ID: #x~x~%" - (gfs::lparam-low-word gfs::message)))) - (setf (event port) nil)) - event))) + (or (pop (events port)) + (cffi:with-foreign-object (msg-ptr 'gfs::msg) + (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0))) + (cffi:with-foreign-slots ((gfs::hwnd gfs::message gfs::wparam gfs::lparam + gfs::time gfs::pnt) + msg-ptr gfs::msg) + (unless (gfw::default-message-filter gm msg-ptr) + (dolist (event (events port)) + (setf (slot-value event 'climi::timestamp) gfs::time))))) + (setf (events port) (nreverse (events port))) + (pop (events port))))) (defmethod process-next-event :after ((port graphic-forms-port) &key wait-function (timeout nil)) (declare (ignore wait-function timeout)) @@ -406,8 +406,8 @@ (gfs::debug-format "menu item: ~a invoked~%" item)) (defmethod gfw:event-close ((self sheet-event-dispatcher) mirror) - (setf (event (port self)) (make-instance 'window-manager-delete-event - :sheet (sheet mirror)))) + (enqueue (port self) + (make-instance 'window-manager-delete-event :sheet (sheet mirror)))) ;; copy&paste from port.lisp|CLX: (defun sheet-desired-ink (sheet) @@ -434,10 +434,10 @@ (setf (gfg:background-color gc) c (gfg:foreground-color gc) c)) (gfg:draw-filled-rectangle gc rect))) - (setf (event (port self)) - (make-instance 'window-repaint-event - :sheet sheet - :region (translate-rectangle rect))))) + (enqueue (port self) + (make-instance 'window-repaint-event + :sheet sheet + :region (translate-rectangle rect))))) (defun generate-configuration-event (mirror pnt size) (make-instance 'window-configuration-event @@ -448,7 +448,8 @@ :height (gfs:size-height size))) (defmethod gfw:event-move ((self sheet-event-dispatcher) mirror pnt) - (setf (event (port self)) (generate-configuration-event mirror pnt (gfw:client-size mirror)))) + (enqueue (port self) + (generate-configuration-event mirror pnt (gfw:client-size mirror)))) (defmethod gfw:event-resize ((self sheet-event-dispatcher) mirror size type) (declare (ignore type)) @@ -457,21 +458,21 @@ (let ((medium (climi::sheet-medium sheet))) (if (and medium (image-of medium)) (resize-medium-buffer medium size)))) - (setf (event (port self)) - (generate-configuration-event mirror (gfw:location mirror) size)))) + (enqueue (port self) + (generate-configuration-event mirror (gfw:location mirror) size)))) (defclass gadget-event (window-event) ()) (defclass button-pressed-event (gadget-event) ()) (defmethod gfw:event-select ((self pane-event-dispatcher) mirror) - (setf (event (port self)) - (typecase mirror - (gfw-button - (make-instance 'button-pressed-event :sheet (sheet mirror))) - (t - (make-instance 'menu-clicked-event - :sheet (sheet (gfw:owner mirror)) - :item (sheet mirror)))))) + (enqueue (port self) + (typecase mirror + (gfw-button + (make-instance 'button-pressed-event :sheet (sheet mirror))) + (t + (make-instance 'menu-clicked-event + :sheet (sheet (gfw:owner mirror)) + :item (sheet mirror)))))) (defmethod handle-event ((pane push-button) (event button-pressed-event)) (activate-callback pane (gadget-client pane) (gadget-id pane))) @@ -487,49 +488,46 @@ (defmethod gfw:event-mouse-move ((self sheet-event-dispatcher) mirror point button) - (setf (event (port self)) - (make-instance 'pointer-motion-event - :pointer 0 - :sheet (sheet mirror) - :x (gfs:point-x point) - :y (gfs:point-y point) - :button (translate-button-name button) - ;; FIXME: -;;; :timestamp + (enqueue (port self) + (make-instance 'pointer-motion-event + :pointer 0 + :sheet (sheet mirror) + :x (gfs:point-x point) + :y (gfs:point-y point) + :button (translate-button-name button) + ;; FIXME: ;;; :graft-x ;;; :graft-y - :modifier-state 0 - ))) + :modifier-state 0 + ))) (defmethod gfw:event-mouse-down ((self sheet-event-dispatcher) mirror point button) - (setf (event (port self)) - (make-instance 'pointer-button-press-event - :pointer 0 - :sheet (sheet mirror) - :x (gfs:point-x point) - :y (gfs:point-y point) - :button (translate-button-name button) - ;; FIXME: -;;; :timestamp + (enqueue (port self) + (make-instance 'pointer-button-press-event + :pointer 0 + :sheet (sheet mirror) + :x (gfs:point-x point) + :y (gfs:point-y point) + :button (translate-button-name button) + ;; FIXME: ;;; :graft-x ;;; :graft-y - :modifier-state 0 - ))) + :modifier-state 0 + ))) (defmethod gfw:event-mouse-up ((self sheet-event-dispatcher) mirror point button) - (setf (event (port self)) - (make-instance 'pointer-button-release-event - :pointer 0 - :sheet (sheet mirror) - :x (gfs:point-x point) - :y (gfs:point-y point) - :button (translate-button-name button) - ;; FIXME: -;;; :timestamp + (enqueue (port self) + (make-instance 'pointer-button-release-event + :pointer 0 + :sheet (sheet mirror) + :x (gfs:point-x point) + :y (gfs:point-y point) + :button (translate-button-name button) + ;; FIXME: ;;; :graft-x ;;; :graft-y - :modifier-state 0 - ))) + :modifier-state 0 + ))) (defun char-to-sym (char) (case char @@ -549,34 +547,32 @@ (#\Tab :TAB) (#\Return :RETURN) (#\Rubout :DELETE))) (defmethod gfw:event-key-down ((self sheet-event-dispatcher) mirror code char) - (setf (event (port self)) - (make-instance 'key-press-event - :key-name (char-to-sym char) - :key-character char - :sheet (sheet mirror) - ;; FIXME: - :x 0 - :y 0 - :modifier-state 0 -;;; :timestamp time + (enqueue (port self) + (make-instance 'key-press-event + :key-name (char-to-sym char) + :key-character char + :sheet (sheet mirror) + ;; FIXME: + :x 0 + :y 0 + :modifier-state 0 ;;; :graft-x root-x ;;; :graft-y root-y - ))) + ))) (defmethod gfw:event-key-up ((self sheet-event-dispatcher) mirror code char) - (setf (event (port self)) - (make-instance 'key-release-event - :key-name (char-to-sym char) - :key-character char - :sheet (sheet mirror) - ;; FIXME: - :x 0 - :y 0 - :modifier-state 0 -;;; :timestamp time + (enqueue (port self) + (make-instance 'key-release-event + :key-name (char-to-sym char) + :key-character char + :sheet (sheet mirror) + ;; FIXME: + :x 0 + :y 0 + :modifier-state 0 ;;; :graft-x root-x ;;; :graft-y root-y - ))) + ))) ;;; From junrue at common-lisp.net Sun Mar 18 17:15:55 2007 From: junrue at common-lisp.net (junrue) Date: Sun, 18 Mar 2007 12:15:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/Graphic-Forms Message-ID: <20070318171555.C550D7C051@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv7676 Modified Files: medium.lisp Log Message: medium-draw-text works better with an explicit call to sync-text-style --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/16 15:31:56 1.5 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/18 17:15:55 1.6 @@ -426,6 +426,9 @@ toward-x toward-y transform-glyphs) #+nil (gfs::debug-format "medium-draw-text: ~d, ~d ~s~%" x y string) (when (target-of medium) + (sync-text-style medium + (merge-text-styles (medium-text-style medium) + (medium-default-text-style medium))) (setf string (normalize-text-data string)) (gfw:with-graphics-context (gc (target-of medium)) (let ((font (font-of medium))) From ahefner at common-lisp.net Tue Mar 20 01:39:29 2007 From: ahefner at common-lisp.net (ahefner) Date: Mon, 19 Mar 2007 20:39:29 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070320013929.9729B45097@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19266 Modified Files: commands.lisp Log Message: Don't return a value from map-over-command-menu-items (was trickling down to make lookup-keystroke-item return nonsense in the case where lookup failed). --- /project/mcclim/cvsroot/mcclim/commands.lisp 2007/01/17 12:09:46 1.70 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2007/03/20 01:39:29 1.71 @@ -403,7 +403,8 @@ menu-name (and (slot-boundp item 'keystroke) keystroke) item))) - (slot-value (find-command-table command-table) 'menu))) + (slot-value (find-command-table command-table) 'menu)) + (values)) ;; At this point we should still see the gesture name as supplied by the ;; programmer in 'gesture' From ahefner at common-lisp.net Tue Mar 20 01:41:17 2007 From: ahefner at common-lisp.net (ahefner) Date: Mon, 19 Mar 2007 20:41:17 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070320014117.E3FB14F014@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv20583 Modified Files: bordered-output.lisp medium.lisp Log Message: Merge with medium line style. Eliminated merge-line-styles due to the contraint in the spec that you can't have NIL components in your line style. --- /project/mcclim/cvsroot/mcclim/bordered-output.lisp 2007/03/12 17:36:52 1.16 +++ /project/mcclim/cvsroot/mcclim/bordered-output.lisp 2007/03/20 01:41:17 1.17 @@ -173,13 +173,12 @@ (defmacro %%line-style-for-method () `(or line-style - (merge-line-styles - (make-line-style - :unit (or line-unit :point) - :thickness (or line-thickness 1) - :cap-shape (or line-cap-shape :butt) - :dashes line-dashes) - (medium-line-style stream)))) + (let ((mls (medium-line-style stream))) + (make-line-style + :unit (or line-unit (line-style-unit mls)) + :thickness (or line-thickness (line-style-thickness mls)) + :cap-shape (or line-cap-shape (line-style-cap-shape mls)) + :dashes (or line-dashes (line-style-dashes mls)))))) (defmacro %%adjusting-for-padding (&body body) `(let ((left (- left padding-left)) @@ -201,7 +200,7 @@ ;; The Franz User guide implies that &key isn't needed. (pushnew '&key arglist) `(progn - (pushnew ,shape *border-types*) + (pushnew ',shape *border-types*) (defmethod draw-output-border-over ((shape (eql ',shape)) stream record &rest drawing-options) (with-border-edges (stream record) @@ -675,7 +674,7 @@ new-drawing-options) ;; Great, this again.. (queue-repaint stream - (make-instance 'window-repaint-event + (make-instance 'window-repaint-event :sheet stream :region (transform-region (sheet-native-transformation stream) --- /project/mcclim/cvsroot/mcclim/medium.lisp 2007/02/05 02:57:58 1.62 +++ /project/mcclim/cvsroot/mcclim/medium.lisp 2007/03/20 01:41:17 1.63 @@ -500,18 +500,6 @@ (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 Tue Mar 20 01:43:55 2007 From: ahefner at common-lisp.net (ahefner) Date: Mon, 19 Mar 2007 20:43:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070320014355.AC3AA4F010@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22184 Modified Files: panes.lisp sheets.lisp Log Message: Small hacks that appear to make output to unadopted sheets work. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2007/03/04 15:08:00 1.181 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2007/03/20 01:43:55 1.182 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.181 2007/03/04 15:08:00 thenriksen Exp $ +;;; $Id: panes.lisp,v 1.182 2007/03/20 01:43:55 ahefner Exp $ (in-package :clim-internals) @@ -2548,7 +2548,8 @@ (stream-close-text-output-record pane) (let ((output-history (stream-output-history pane))) (with-bounding-rectangle* (left top right bottom) output-history - (medium-clear-area (sheet-medium pane) left top right bottom)) + (when (sheet-viewable-p pane) + (medium-clear-area (sheet-medium pane) left top right bottom))) (clear-output-record output-history)) (window-erase-viewport pane) (let ((cursor (stream-text-cursor pane))) --- /project/mcclim/cvsroot/mcclim/sheets.lisp 2006/11/09 20:24:20 1.53 +++ /project/mcclim/cvsroot/mcclim/sheets.lisp 2007/03/20 01:43:55 1.54 @@ -84,7 +84,8 @@ :initform (make-bounding-rectangle 0 0 100 100) :accessor sheet-region) (native-transformation :type (or null transformation) - :initform nil + ;:initform nil + :initform +identity-transformation+ :writer %%set-sheet-native-transformation :reader %%sheet-native-transformation) (native-region :type (or null region) @@ -95,7 +96,7 @@ :initform nil) (pointer-cursor :accessor sheet-pointer-cursor :initarg :pointer-cursor - :initform :default) + :initform :default) (enabled-p :type boolean :initarg :enabled-p :initform t From ahefner at common-lisp.net Tue Mar 20 01:46:14 2007 From: ahefner at common-lisp.net (ahefner) Date: Mon, 19 Mar 2007 20:46:14 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20070320014614.CA4FB50030@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv22583 Modified Files: clim-fig.lisp fire.lisp Log Message: Cleanup some port-destroying cruft in the examples. --- /project/mcclim/cvsroot/mcclim/Examples/clim-fig.lisp 2006/12/26 16:44:46 1.31 +++ /project/mcclim/cvsroot/mcclim/Examples/clim-fig.lisp 2007/03/20 01:46:14 1.32 @@ -160,19 +160,7 @@ (return-from handle-move-object))))) (defun clim-fig () - (loop for port in climi::*all-ports* - do (destroy-port port)) - (setq climi::*all-ports* nil) - (run-frame-top-level (make-application-frame 'clim-fig)) - ;(setq frame (make-application-frame 'clim-fig)) - ;(setq fm (frame-manager frame)) - ;(setq port (climi::frame-manager-port fm)) - ;(setq pane (first (frame-panes frame))) - ;(setq medium (sheet-medium pane)) - ;(setq graft (graft frame)) - ;(setq vbox (climi::frame-pane frame)) - ;(run-frame-top-level frame) - ) + (run-frame-top-level (make-application-frame 'clim-fig))) (defun make-colored-button (color &key width height) (make-pane 'push-button --- /project/mcclim/cvsroot/mcclim/Examples/fire.lisp 2005/02/02 06:32:32 1.5 +++ /project/mcclim/cvsroot/mcclim/Examples/fire.lisp 2007/03/20 01:46:14 1.6 @@ -92,9 +92,6 @@ ;; test functions (defun fire () - (loop for port in climi::*all-ports* - do (destroy-port port)) - (setq climi::*all-ports* nil) (run-frame-top-level (make-application-frame 'firelights))) (defmethod fire-frame-top-level ((frame application-frame)) From ahefner at common-lisp.net Tue Mar 20 01:48:40 2007 From: ahefner at common-lisp.net (ahefner) Date: Mon, 19 Mar 2007 20:48:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070320014840.80C3350030@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22720 Modified Files: recording.lisp Log Message: Optimize a few cases in recompute-extent-for-changed-child, generalizing an optimization by Robert Strandh. --- /project/mcclim/cvsroot/mcclim/recording.lisp 2007/02/05 03:06:14 1.130 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2007/03/20 01:48:38 1.131 @@ -608,10 +608,10 @@ (defmethod clear-output-record ((record basic-output-record)) (error "Cannot clear ~S." record)) -(defmethod clear-output-record :before ((record compound-output-record)) +(defmethod clear-output-record :before ((record compound-output-record)) (let ((sheet (find-output-record-sheet record))) (when sheet - (map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet)))) + (map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet)))) (defmethod clear-output-record :after ((record compound-output-record)) ;; XXX banish x and y @@ -774,63 +774,78 @@ (setf (rectangle-edges* record) (values new-x1 new-y1 new-x2 new-y2))))))) - (defmethod recompute-extent-for-changed-child ((record compound-output-record) changed-child old-min-x old-min-y old-max-x old-max-y) (with-bounding-rectangle* (ox1 oy1 ox2 oy2) record (with-bounding-rectangle* (cx1 cy1 cx2 cy2) changed-child - ;; 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. - (multiple-value-bind (nx1 ny1 nx2 ny2) - (cond - ;; The child has been deleted; who knows what the - ;; new bounding box might be. - ((not (output-record-parent changed-child)) - (%tree-recompute-extent* record)) - ;; Only one child of record, and we already have the bounds. - ((eql (output-record-count record) 1) - (values cx1 cy1 cx2 cy2)) - ;; If our record occupied no space (had no children, or had only - ;; children similarly occupying no space, hackishly determined by - ;; null-bounding-rectangle-p), recompute the extent now, otherwise - ;; the next COND clause would, as an optimization, attempt to extend - ;; our current bounding rectangle, which is invalid. - ((null-bounding-rectangle-p record) - (%tree-recompute-extent* record)) - ;; In the following cases, we can grow the new bounding rectangle - ;; from its previous state: - ((or - ;; If the child was originally empty, it should not have affected - ;; previous computation of our bounding rectangle. - ;; This is hackish for reasons similar to the above. - (and (zerop old-min-x) (zerop old-min-y) - (zerop old-max-x) (zerop old-max-y)) - ;; New child bounds contain old child bounds, so use min/max - ;; to extend the already-calculated rectangle. - (and (<= cx1 old-min-x) (<= cy1 old-min-y) - (>= cx2 old-max-x) (>= cy2 old-max-y))) - (values (min cx1 ox1) (min cy1 oy1) - (max cx2 ox2) (max cy2 oy2))) - ;; No shortcuts - we must compute a new bounding box from those of - ;; all our children. We want to avoid this - in worst cases, such as - ;; a toplevel output history, large graph, or table, there may exist - ;; thousands of children. Without the above optimizations, - ;; construction becomes O(N^2) due to bounding rectangle calculation. - (t (%tree-recompute-extent* record))) - ;; XXX banish x, y - (with-slots (x y) - record - (setf x nx1 y ny1) - (setf (rectangle-edges* record) (values nx1 ny1 nx2 ny2)) - (let ((parent (output-record-parent record))) - (unless (or (null parent) - (and (= nx1 ox1) (= ny1 oy1) - (= nx2 ox2) (= nx2 oy2))) - (recompute-extent-for-changed-child parent record - ox1 oy1 ox2 oy2))))))) + (let ((child-was-empty (and (= old-min-x old-min-y) ; =( + (= old-max-x old-max-y)))) + ;; 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. + (multiple-value-bind (nx1 ny1 nx2 ny2) + (cond + ;; The child has been deleted, but none of its edges contribute + ;; to the bounding rectangle of the parent, so the bounding + ;; rectangle cannot be changed by its deletion. + ;; This is also true if the child was empty. + ((or child-was-empty + (and (output-record-parent changed-child) + (> old-min-x ox1) + (> old-min-y oy1) + (< old-max-x ox2) + (< old-max-y oy2))) + (values ox1 oy1 ox2 oy2)) + ;; The child has been deleted; who knows what the + ;; new bounding box might be. + ((not (output-record-parent changed-child)) + (%tree-recompute-extent* record)) + ;; Only one child of record, and we already have the bounds. + ((eql (output-record-count record) 1) + (values cx1 cy1 cx2 cy2)) + ;; If our record occupied no space (had no children, or had only + ;; children similarly occupying no space, hackishly determined by + ;; null-bounding-rectangle-p), recompute the extent now, otherwise + ;; the next COND clause would, as an optimization, attempt to extend + ;; our current bounding rectangle, which is invalid. + ((null-bounding-rectangle-p record) + (%tree-recompute-extent* record)) + ;; In the following cases, we can grow the new bounding rectangle + ;; from its previous state: + ((or + ;; If the child was originally empty, it should not have affected + ;; previous computation of our bounding rectangle. + child-was-empty + ;; No child edge which may have defined the bounding rectangle of + ;; the parent has shrunk inward, so min/max the new child rectangle + ;; against the existing rectangle. Other edges of the child may have + ;; moved, but this can't affect the parent bounding rectangle. + (and (or (> old-min-x ox1) (>= old-min-x cx1)) + (or (> old-min-y oy1) (>= old-min-y cy1)) + (or (< old-max-x ox2) (<= old-max-x cx2)) + (or (< old-max-y oy2) (<= old-max-y cy2)))) + ;; In these cases, we can grow the rectangle using min/max. + (values (min cx1 ox1) (min cy1 oy1) + (max cx2 ox2) (max cy2 oy2))) + ;; No shortcuts - we must compute a new bounding box from those of + ;; all our children. We want to avoid this - in worst cases, such as + ;; a toplevel output history, large graph, or table, there may exist + ;; thousands of children. Without the above optimizations, + ;; construction becomes O(N^2) due to bounding rectangle calculation. + (t (%tree-recompute-extent* record))) + ;; XXX banish x, y + (with-slots (x y) + record + (setf x nx1 y ny1) + (setf (rectangle-edges* record) (values nx1 ny1 nx2 ny2)) + (let ((parent (output-record-parent record))) + (unless (or (null parent) + (and (= nx1 ox1) (= ny1 oy1) + (= nx2 ox2) (= nx2 oy2))) + (recompute-extent-for-changed-child parent record + ox1 oy1 ox2 oy2)))))))) record) ;; There was once an :around method on recompute-extent-for-changed-child here, @@ -1975,9 +1990,9 @@ (with-slots (strings) record (if (= 1 (length strings)) (styled-string-string (first strings)) - (with-output-to-string (result) - (loop for styled-string in strings - do (write-string (styled-string-string styled-string) result)))))) + (with-output-to-string (result) + (loop for styled-string in strings + do (write-string (styled-string-string styled-string) result)))))) ;;; 16.3.4. Top-Level Output Records (defclass stream-output-history-mixin () From ahefner at common-lisp.net Tue Mar 20 01:51:22 2007 From: ahefner at common-lisp.net (ahefner) Date: Mon, 19 Mar 2007 20:51:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Extensions Message-ID: <20070320015122.41BFB59085@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions In directory clnet:/tmp/cvs-serv23102/d Modified Files: tab-layout.lisp Log Message: Pixie tab layout. Slight refactoring of the basic tab layout necessary so that the implementation can be reused. Tweaked space allocation of pixie buttons. --- /project/mcclim/cvsroot/mcclim/Extensions/tab-layout.lisp 2007/02/04 14:53:32 1.2 +++ /project/mcclim/cvsroot/mcclim/Extensions/tab-layout.lisp 2007/03/20 01:51:22 1.3 @@ -273,7 +273,7 @@ :pages (list ,@(mapcar (lambda (spec) `(make-tab-page , at spec :presentation-type - ,ptypevar)) + ,ptypevar)) body)) , at initargs)))) @@ -309,26 +309,6 @@ ;;; generic TAB-LAYOUT-PANE implementation -(defclass tab-layout-pane (tab-layout) - ((header-pane :accessor tab-layout-header-pane - :initarg :header-pane)) - (:documentation "A pure-lisp implementation of the tab-layout, this is -the generic implementation chosen by the CLX frame manager automatically. -Users should create panes for type TAB-LAYOUT, not TAB-LAYOUT-PANE, so -that the frame manager can customize the implementation.")) - -(defmethod (setf tab-layout-enabled-page) - (page (parent tab-layout-pane)) - (let ((old-page (tab-layout-enabled-page parent))) - (unless (equal page old-page) - (when old-page - (setf (sheet-enabled-p (tab-page-pane old-page)) nil)) - (when page - (setf (sheet-enabled-p (tab-page-pane page)) t))) - (when page - (setf (sheet-enabled-p (tab-page-pane page)) t))) - (call-next-method)) - (defclass tab-bar-view (gadget-view) ()) @@ -369,33 +349,64 @@ (tab-page-drawing-options tab-page)) (stream-increment-cursor-position stream 10 0)) +(defclass tab-layout-pane (tab-layout) + ((header-pane :accessor tab-layout-header-pane + :initarg :header-pane) + (header-display-function + :accessor header-display-function + :initarg :header-display-function + :initform 'default-display-tab-header)) + (:documentation "A pure-lisp implementation of the tab-layout, this is +the generic implementation chosen by the CLX frame manager automatically. +Users should create panes for type TAB-LAYOUT, not TAB-LAYOUT-PANE, so +that the frame manager can customize the implementation.")) + +(defmethod (setf tab-layout-enabled-page) + (page (parent tab-layout-pane)) + (let ((old-page (tab-layout-enabled-page parent))) + (unless (equal page old-page) + (when old-page + (setf (sheet-enabled-p (tab-page-pane old-page)) nil)) + (when page + (setf (sheet-enabled-p (tab-page-pane page)) t))) + (when page + (setf (sheet-enabled-p (tab-page-pane page)) t))) + (call-next-method)) + +(defun default-display-tab-header (tab-layout pane) + (stream-increment-cursor-position pane 0 3) + (draw-line* pane + 0 + 17 + (slot-value pane 'climi::current-width) + 17 + :ink +black+) + (mapc (lambda (page) + (with-output-as-presentation + (pane (tab-page-pane page) + (tab-page-presentation-type page)) + (present page 'tab-page :stream pane))) + (tab-layout-pages tab-layout))) + +(defclass tab-bar-pane (application-pane) + () + (:default-initargs :default-view +tab-bar-view+)) + +(defmethod compose-space ((pane tab-bar-pane) &key width height) + (declare (ignore width height)) + (make-space-requirement :min-height 22 :height 22 :max-height 22)) + (defmethod initialize-instance :after ((instance tab-layout-pane) &key pages) (let ((current (tab-layout-enabled-page instance))) (dolist (page pages) (setf (sheet-enabled-p (tab-page-pane page)) (eq page current)))) (let ((header - (make-clim-stream-pane - :default-view +tab-bar-view+ + (make-pane 'tab-bar-pane :display-time :command-loop - :scroll-bars nil - :borders nil - :height 22 :display-function (lambda (frame pane) - (declare (ignore frame)) - (stream-increment-cursor-position pane 0 3) - (draw-line* pane - 0 - 17 - (slot-value pane 'climi::current-width) - 17 - :ink +black+) - (mapc (lambda (page) - (with-output-as-presentation - (pane (tab-page-pane page) - (tab-page-presentation-type page)) - (present page 'tab-page :stream pane))) - (tab-layout-pages instance)))))) + (declare (ignore frame)) + (funcall (header-display-function instance) instance pane))))) (setf (tab-layout-header-pane instance) header) (sheet-adopt-child instance header) (setf (sheet-enabled-p header) t))) @@ -430,6 +441,8 @@ (defmethod clim-tab-layout:note-tab-page-changed ((layout tab-layout-pane) page) (redisplay-frame-pane (pane-frame layout) + (tab-layout-header-pane layout) + #+NIL (car (sheet-children (car (sheet-children (tab-layout-header-pane layout))))) From ahefner at common-lisp.net Tue Mar 20 01:51:22 2007 From: ahefner at common-lisp.net (ahefner) Date: Mon, 19 Mar 2007 20:51:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Looks Message-ID: <20070320015122.AABD359085@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Looks In directory clnet:/tmp/cvs-serv23102/Looks Modified Files: pixie.lisp Log Message: Pixie tab layout. Slight refactoring of the basic tab layout necessary so that the implementation can be reused. Tweaked space allocation of pixie buttons. --- /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2007/02/07 12:44:22 1.20 +++ /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2007/03/20 01:51:22 1.21 @@ -984,6 +984,7 @@ (defmethod compose-space ((gadget pixie-push-button-pane) &key width height) (declare (ignore width height)) + ;; Why does a button have spacing options, anyway? (space-requirement+* (space-requirement+* (compose-label-space gadget) :min-width (* 2 (pane-x-spacing gadget)) :width (* 2 (pane-x-spacing gadget)) @@ -991,12 +992,12 @@ :min-height (* 2 (pane-y-spacing gadget)) :height (* 2 (pane-y-spacing gadget)) :max-height (* 2 (pane-y-spacing gadget))) - :min-width (* 2 *3d-border-thickness*) - :width (* 2 *3d-border-thickness*) - :max-width (* 2 *3d-border-thickness*) - :min-height (* 2 *3d-border-thickness*) - :height (* 2 *3d-border-thickness*) - :max-height (* 2 *3d-border-thickness*))) + :min-width (* 8 *3d-border-thickness*) + :width (* 8 *3d-border-thickness*) + :max-width (* 8 *3d-border-thickness*) + :min-height (* 4 *3d-border-thickness*) + :height (* 4 *3d-border-thickness*) + :max-height (* 4 *3d-border-thickness*))) ; factor out the dragging code into a mixin (defmethod handle-event ((pane pixie-push-button-pane) (event pointer-enter-event)) @@ -1041,8 +1042,8 @@ (y1 (+ y1 1)) (x2 (- x2 1)) (y2 (- y2 1))) - (let ((x2 (- x2 1)) - (y2 (- y2 1))) + (let ((x2 (- x2 1)) ; Removing this magic weirdness slightly uglifies the + (y2 (- y2 1))) ; scroll bar. Not sure why, but FIXME. (cond ((or (not pressedp) (eq dragging :outside)) @@ -1140,3 +1141,130 @@ (defmethod allocate-space ((pane pixie-text-field-pane) w h) (resize-sheet pane w h)) + +;;;; Pixie tab-layout. Reuses implementation of the generic tab-layout-pane. + +(define-pixie-gadget clim-tab-layout:tab-layout pixie-tab-layout-pane) +(define-pixie-gadget clim-tab-layout::tab-bar-pane pixie-tab-bar-pane) + +(defclass pixie-tab-bar-view (gadget-view) + ((selected :initform nil + :initarg :selected + :reader pixie-tab-view-selected-p))) + +(defparameter +pixie-tab-bar-view+ + (make-instance 'pixie-tab-bar-view :selected nil)) + +(defparameter +pixie-selected-tab-bar-view+ + (make-instance 'pixie-tab-bar-view :selected t)) + + + +(defclass pixie-tab-layout-pane (clim-tab-layout:tab-layout-pane) + () + (:default-initargs + :header-display-function 'pixie-display-tab-header)) + +(defclass pixie-tab-bar-pane (application-pane pixie-gadget) + () + (:default-initargs + :default-view +pixie-tab-bar-view+ + :background +gray83+ + :text-style (make-text-style :sans-serif :roman :small))) + +(defmethod compose-space ((pane pixie-tab-bar-pane) &key width height) + (declare (ignore width height)) + (let ((h (+ 6 ; padding on the top + 6 ; padding on the bottom + (text-style-ascent (pane-text-style pane) pane) + (text-style-descent (pane-text-style pane) pane)))) + (make-space-requirement :min-height h :height h :max-height h))) + +(defun draw-pixie-tab-bar-bottom (pane) + (let ((y0 (bounding-rectangle-min-y (sheet-region pane))) + (y1 (bounding-rectangle-max-y (sheet-region pane)))) + (draw-line* pane 0 (- y1 6) +fill+ (- y1 6) :ink *3d-light-color*) + (draw-line* pane 0 (- y1 1) +fill+ (- y1 1) :ink *3d-dark-color*) + #+NIL (draw-line* pane 0 (1- y1) x1 (1- y1) :ink +gray30+))) + +(defmethod draw-output-border-over + ((shape (eql 'pixie-tab-bar-border)) stream record &key &allow-other-keys) + (declare (ignore shape stream record))) + +(defmethod draw-output-border-under + ((shape (eql 'pixie-tab-bar-border)) stream record + &key background enabled &allow-other-keys) + (with-border-edges (stream record) + (declare (ignore bottom)) + (with-bounding-rectangle* (x0 y0 x1 y1) (sheet-region stream) + (declare (ignore x0 x1 y0)) + (let ((bottom (- y1 7)) + (left (- left 4 (if enabled 2 0))) + (right (+ right 4 (if enabled 2 0))) + (top (- top 2 #+NIL (if enabled 2 0)))) + (draw-rectangle* stream left top right (+ bottom (if enabled 2 1)) + :filled t :ink background) + (draw-line* stream (1+ left) (1- top) (- right 1) (1- top) :ink +white+) + (draw-point* stream left top :ink +white+) + (draw-line* stream (1- left) bottom (1- left) (1+ top) :ink +white+) + (draw-line* stream right bottom right top :ink +gray66+) + (draw-point* stream right top :ink +gray40+) + (draw-line* stream (1+ right) bottom (1+ right) (1+ top) :ink +gray40+))))) + +(define-default-highlighting-method 'pixie-tab-bar-border) + +(define-presentation-method present + (tab-page (type clim-tab-layout:tab-page) stream (view pixie-tab-bar-view) &key) + (stream-increment-cursor-position stream 5 0) + (surrounding-output-with-border (stream :shape 'pixie-tab-bar-border + :enabled (pixie-tab-view-selected-p view) + :highlight-background +gray94+ + :background +gray83+ + :move-cursor nil) + (apply #'invoke-with-drawing-options stream + (lambda (rest) + (declare (ignore rest)) + (write-string (clim-tab-layout:tab-page-title tab-page) stream)) + (clim-tab-layout:tab-page-drawing-options tab-page))) + (stream-increment-cursor-position stream 6 0)) + +(defun pixie-display-tab-header (tab-layout pane) + (draw-pixie-tab-bar-bottom pane) + (setf (stream-cursor-position pane) + (values 3 (- (bounding-rectangle-height (sheet-region pane)) + 7 + (text-style-descent (pane-text-style pane) pane) + (text-style-ascent (pane-text-style pane) pane)))) + (let ((enabled-page-drawers nil)) + (mapc (lambda (page) + ;; This gets a little silly, but the tabs are laid out simply by + ;; letting the cursor move from left to right. In order to make + ;; the selected tab overlap, we can't draw it until after the other + ;; tabs. We then draw it slightly larger in each direcetion. But the + ;; cursor has to have moved as though it were smaller (so that it + ;; overlaps its neighbors), so draw it initially, note its position, + ;; and redraw a larger version once everything is done. + (let ((enabled (sheet-enabled-p (clim-tab-layout:tab-page-pane page)))) + (when enabled + (multiple-value-bind (x y) (stream-cursor-position pane) + (push (lambda () + (setf (stream-cursor-position pane) + (values x (- y 2))) + (with-output-as-presentation + (pane (clim-tab-layout:tab-page-pane page) + (clim-tab-layout:tab-page-presentation-type page)) + (present page 'clim-tab-layout:tab-page :stream pane + :view +pixie-selected-tab-bar-view+))) + enabled-page-drawers))) + (let ((record + (with-output-as-presentation + (pane (clim-tab-layout:tab-page-pane page) + (clim-tab-layout:tab-page-presentation-type page)) + (present page 'clim-tab-layout:tab-page :stream pane)))) + ;; Because piling the presentations on top of each other confuses + ;; CLIM as to which should be highlighted, erase the smaller one. + ;; The cursor has already been moved, so we don't need it. + (when enabled + (delete-output-record record (output-record-parent record)))))) + (clim-tab-layout:tab-layout-pages tab-layout)) + (mapcar #'funcall enabled-page-drawers)))