mcclim-cvs August 2007

mcclim-cvs@common-lisp.net

3 participants
26 discussions

[mcclim-cvs] CVS mcclim/Backends/PostScript
by crhodes 28 Aug '07

28 Aug '07

Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory clnet:/tmp/cvs-serv11067/Backends/PostScript Modified Files: graphics.lisp Log Message: Allow addition of a rectangle set path in postscript. Needed for clipping regions, at least, in certain complicated beam groups in gsharp. --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp 2007/07/11 15:26:20 1.19 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp 2007/08/28 14:50:25 1.20 @@ -228,6 +228,10 @@ (let ((ellipse (transform-region *transformation* ellipse))) (put-ellipse stream ellipse t))) +(defmethod postscript-add-path (stream (rs climi::standard-rectangle-set)) + (map-over-region-set-regions + (lambda (r) (postscript-add-path stream r)) + rs)) ;;; Graphics state

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 26 Aug '07

26 Aug '07

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv27401 Modified Files: keys.lisp Log Message: revert my previous commit for the release because of unresolved bugs --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keys.lisp 2007/07/15 12:00:08 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keys.lisp 2007/08/26 20:55:25 1.4 @@ -64,7 +64,6 @@ (DEFINE-KEY 91 (T :[ #\[)) (DEFINE-KEY 92 (T :|\\| #\\)) (DEFINE-KEY 93 (T :] #\])) -(DEFINE-KEY 94 (T :^ #\^)) (DEFINE-KEY 95 (T :_ #\_)) (DEFINE-KEY 96 (T :|`| #\`)) (DEFINE-KEY 97 (T :|a| #\a)) @@ -96,27 +95,16 @@ (DEFINE-KEY 123 (T :{ #\{)) (DEFINE-KEY 124 (T :|\|| #\|)) (DEFINE-KEY 125 (T :} #\})) -(DEFINE-KEY 167 (T :SECTION NIL)) -(DEFINE-KEY 176 (T :DEGREE NIL)) -(DEFINE-KEY 196 (T :A-DIAERESIS #.(code-char 196))) -(DEFINE-KEY 214 (T :O-DIAERESIS #.(code-char 214))) -(DEFINE-KEY 220 (T :U-DIAERESIS #.(code-char 220))) -(DEFINE-KEY 223 (T :SSHARP #.(code-char 223))) -(DEFINE-KEY 228 (T :|a-DIAERESIS| #.(code-char 228))) -(DEFINE-KEY 246 (T :|o-DIAERESIS| #.(code-char 246))) -(DEFINE-KEY 252 (T :|u-DIAERESIS| #.(code-char 252))) (DEFINE-KEY 65056 (T :ISO-LEFT-TAB NIL)) (DEFINE-KEY 65106 (T :DEAD-CIRCUMFLEX NIL)) (DEFINE-KEY 65107 (T :DEAD-TILDE NIL)) -(DEFINE-KEY 65237 ((12) :BACKSPACE #\Backspace) (T :TERMINATE-SERVER NIL)) (DEFINE-KEY 65273 (T :POINTER-ENABLE-KEYS NIL)) (DEFINE-KEY 65288 (T :BACKSPACE #\Backspace)) -(DEFINE-KEY 65288 ((4 8 0) :BACKSPACE #\Backspace) (T :TERMINATE-SERVER NIL)) (DEFINE-KEY 65289 (T :TAB #\Tab)) (DEFINE-KEY 65293 (T :RETURN #\Return)) (DEFINE-KEY 65299 ((9 1) :BREAK NIL) (T :PAUSE NIL)) (DEFINE-KEY 65300 (T :SCROLL-LOCK NIL)) -(DEFINE-KEY 65301 ((12 8) :PRINT NIL) (T :SYS-REQ NIL)) +(DEFINE-KEY 65301 (T :SYS-REQ NIL)) (DEFINE-KEY 65307 (T :ESCAPE NIL)) (DEFINE-KEY 65312 (T :MULTI-KEY NIL)) (DEFINE-KEY 65360 (T :HOME NIL)) @@ -128,11 +116,9 @@ (DEFINE-KEY 65366 (T :NEXT NIL)) (DEFINE-KEY 65367 (T :END NIL)) (DEFINE-KEY 65377 ((12 4 8 0) :PRINT NIL) (T :SYS-REQ NIL)) -(DEFINE-KEY 65377 ((4 0) :PRINT NIL) (T :SYS-REQ NIL)) (DEFINE-KEY 65379 (T :INSERT NIL)) (DEFINE-KEY 65383 (T :MENU NIL)) (DEFINE-KEY 65387 ((12 4) :PAUSE NIL) (T :BREAK NIL)) -(DEFINE-KEY 65406 (T :MODE-SWITCH NIL)) (DEFINE-KEY 65407 (T :NUM-LOCK NIL)) (DEFINE-KEY 65421 (T :KP-ENTER NIL)) (DEFINE-KEY 65429 (T :KP-HOME NIL)) @@ -151,11 +137,6 @@ (DEFINE-KEY 65453 (T :KP-SUBTRACT NIL)) (DEFINE-KEY 65454 (T :KP-DECIMAL NIL)) (DEFINE-KEY 65455 (T :KP-DIVIDE NIL)) -(DEFINE-KEY 65450 ((4 8 0) :KP-MULTIPLY NIL) (T NIL NIL)) -(DEFINE-KEY 65451 ((4 8 0) :KP-ADD NIL) (T NIL NIL)) -(DEFINE-KEY 65452 (T :KP-SEPARATOR NIL)) -(DEFINE-KEY 65453 ((4 8 0) :KP-SUBTRACT NIL) (T NIL NIL)) -(DEFINE-KEY 65455 ((4 8 0) :KP-DIVIDE NIL) (T NIL NIL)) (DEFINE-KEY 65456 (T :KP-0 NIL)) (DEFINE-KEY 65457 (T :KP-1 NIL)) (DEFINE-KEY 65458 (T :KP-2 NIL)) @@ -177,18 +158,6 @@ (DEFINE-KEY 65478 (T :F9 NIL)) (DEFINE-KEY 65479 (T :F10 NIL)) (DEFINE-KEY 65480 (T :F11 NIL)) -(DEFINE-KEY 65470 ((4 8 0) :F1 NIL) (T NIL NIL)) -(DEFINE-KEY 65471 ((4 8 0) :F2 NIL) (T NIL NIL)) -(DEFINE-KEY 65472 ((4 8 0) :F3 NIL) (T NIL NIL)) -(DEFINE-KEY 65473 ((4 8 0) :F4 NIL) (T NIL NIL)) -(DEFINE-KEY 65474 ((4 8 0) :F5 NIL) (T NIL NIL)) -(DEFINE-KEY 65475 ((4 8 0) :F6 NIL) (T NIL NIL)) -(DEFINE-KEY 65476 ((4 8 0) :F7 NIL) (T NIL NIL)) -(DEFINE-KEY 65477 ((4 8 0) :F8 NIL) (T NIL NIL)) -(DEFINE-KEY 65478 ((4 8 0) :F9 NIL) (T NIL NIL)) -(DEFINE-KEY 65479 ((4 8 0) :F10 NIL) (T NIL NIL)) -(DEFINE-KEY 65480 ((4 8 0) :F11 NIL) (T NIL NIL)) -(DEFINE-KEY 65481 ((4 8 0) :F12 NIL) (T NIL NIL)) (DEFINE-KEY 65505 (T :SHIFT-LEFT NIL)) (DEFINE-KEY 65506 (T :SHIFT-RIGHT NIL)) (DEFINE-KEY 65507 (T :CONTROL-LEFT NIL)) @@ -196,25 +165,7 @@ (DEFINE-KEY 65509 (T :CAPS-LOCK NIL)) (DEFINE-KEY 65511 (T :META-LEFT NIL)) (DEFINE-KEY 65512 (T :META-RIGHT NIL)) -(DEFINE-KEY 65513 (T :ALT-LEFT NIL)) -(DEFINE-KEY 65515 (T :SUPER-LEFT NIL)) (DEFINE-KEY 65535 (T :DELETE #\Rubout)) (DEFINE-KEY 268828535 (T :SUN-AUDIO-LOWER-VOLUME NIL)) (DEFINE-KEY 268828536 (T :SUN-AUDIO-MUTE NIL)) -(DEFINE-KEY 268828537 (T :SUN-AUDIO-RAISE-VOLUME NIL)) -(DEFINE-KEY 269024769 ((12) :F1 NIL) (T NIL NIL)) -(DEFINE-KEY 269024770 ((12) :F2 NIL) (T NIL NIL)) -(DEFINE-KEY 269024771 ((12) :F3 NIL) (T NIL NIL)) -(DEFINE-KEY 269024772 ((12) :F4 NIL) (T NIL NIL)) -(DEFINE-KEY 269024773 ((12) :F5 NIL) (T NIL NIL)) -(DEFINE-KEY 269024774 ((12) :F6 NIL) (T NIL NIL)) -(DEFINE-KEY 269024775 ((12) :F7 NIL) (T NIL NIL)) -(DEFINE-KEY 269024776 ((12) :F8 NIL) (T NIL NIL)) -(DEFINE-KEY 269024777 ((12) :F9 NIL) (T NIL NIL)) -(DEFINE-KEY 269024778 ((12) :F10 NIL) (T NIL NIL)) -(DEFINE-KEY 269024779 ((12) :F11 NIL) (T NIL NIL)) -(DEFINE-KEY 269024780 ((12) :F12 NIL) (T NIL NIL)) -(DEFINE-KEY 269024800 ((12) :KP-DIVIDE NIL) (T NIL NIL)) -(DEFINE-KEY 269024801 ((12) :KP-MULTIPLY NIL) (T NIL NIL)) -(DEFINE-KEY 269024802 ((12) :KP-ADD NIL) (T NIL NIL)) -(DEFINE-KEY 269024803 ((12) :KP-SUBTRACT NIL) (T NIL NIL)) +(DEFINE-KEY 268828537 (T :SUN-AUDIO-RAISE-VOLUME NIL)) \ No newline at end of file

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 26 Aug '07

26 Aug '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv14745 Modified Files: NEWS Log Message: Added mention of the space-requirement stuff for the layout panes. --- /project/mcclim/cvsroot/mcclim/NEWS 2007/08/20 18:32:26 1.22 +++ /project/mcclim/cvsroot/mcclim/NEWS 2007/08/26 16:02:47 1.23 @@ -1,4 +1,6 @@ * Changes in mcclim-0.9.5 relative to 0.9.4: +** specification compliance: various layout panes no longer quite as + aggressive at eating the space requirements of their children. ** Drei now has better support for delimiter gestures. ** Installation: the systems clim-listener, scigraph, clim-examples, and clouseau can now be loaded without loading the system mcclim

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 24 Aug '07

24 Aug '07

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv4113/Drei Modified Files: lisp-syntax.lisp Log Message: Make Drei's form-at-top-level-p function more general. Also, an indentation fix. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/08/20 18:43:06 1.30 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/08/24 13:07:53 1.31 @@ -1441,7 +1441,7 @@ (defgeneric form-at-top-level-p (form) (:documentation "Return NIL if `form' is not a top-level-form, T otherwise.") - (:method ((form form)) + (:method ((form parser-symbol)) (or (typep (parent form) 'form*) (null (parent form))))) @@ -1539,10 +1539,10 @@ (defmethod display-parse-tree :around (parse-symbol stream (drei drei) (syntax lisp-syntax)) (with-slots (top bot) drei - (when (and (start-offset parse-symbol) - (mark< (start-offset parse-symbol) bot) - (mark> (end-offset parse-symbol) top)) - (call-next-method)))) + (when (and (start-offset parse-symbol) + (mark< (start-offset parse-symbol) bot) + (mark> (end-offset parse-symbol) top)) + (call-next-method)))) (defmethod display-parse-tree (parse-symbol stream (drei drei) (syntax lisp-syntax))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 24 Aug '07

24 Aug '07

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv3818/Drei Modified Files: drei-redisplay.lisp Log Message: Fix handling of tabs in Drei cursor positioning. This is a hack. The real solution is to stop using tabs. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/08/06 13:19:03 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/08/24 13:04:40 1.8 @@ -194,7 +194,12 @@ for object = (when go-again (object-before line-beg-mark)) while go-again - when (characterp object) + if (eql object #\Tab) + do (progn (incf displacement (string-size array)) + (incf displacement (tab-width pane)) + (setf (fill-pointer array) 0)) + else if (and (characterp object) + (not (eql object #\Tab))) do (vector-push-extend object array) else do (progn (incf displacement (string-size array)) (incf displacement (object-size object))

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 22 Aug '07

22 Aug '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv27201 Modified Files: text-editor-gadget.lisp gadgets.lisp Log Message: Attempt at cleaning up the text-field and text-editor gadget mess. Drei/Goatee selection now more elegant and complex setups (scrolling, minibuffer for Drei) now handled well without relying on undocumented McCLIM quirks. The various size-specification-features should also work now. --- /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2007/02/07 12:44:17 1.8 +++ /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2007/08/21 22:09:01 1.9 @@ -27,30 +27,89 @@ ;;; This file contains the concrete implementation of the text-field ;;; and text-editor gadgets. It is loaded rather late, because it -;;; requires Drei. +;;; requires Drei. Half of the complexity here is about working around +;;; annoying Goatee quirks, generalising it to three editor substrates +;;; is nontrivial. (in-package :clim-internals) -;;; ------------------------------------------------------------------------------------------ -;;; 30.4.8 The concrete text-field Gadget +;;; The text editor gadget(s) is implemented as a class implementing +;;; the text editor gadget protocol, but containing an editor +;;; substrate object that takes care of the actual editing logic, +;;; redisplay, etc. The substrates need to be gadgets themselves and +;;; are defined here. -(defclass text-field-pane (text-field - drei:drei-gadget-pane) - ((previous-focus :accessor previous-focus :initform nil - :documentation - "The pane that previously had keyboard focus") - (activation-gestures :accessor activation-gestures - :initarg :activation-gestures - :documentation "gestures that cause the -activate callback to be called")) - (:default-initargs - :activation-gestures *standard-activation-gestures*)) +(defparameter *default-text-field-text-style* + (make-text-style :fixed :roman :normal)) + +(defclass editor-substrate-mixin (value-gadget) + ((activation-gestures :reader activation-gestures + :initarg :activation-gestures) + (user :reader user-gadget + :initarg :user-gadget + :documentation "The editor gadget using this editor substrate." + :initform (error "Editor substrates must have a user."))) + (:documentation "A mixin class for text editor gadget substrates.") + (:default-initargs :activation-gestures '())) + +(defmethod gadget-id ((gadget editor-substrate-mixin)) + (gadget-id (user-gadget gadget))) + +(defmethod (setf gadget-id) (value (gadget editor-substrate-mixin)) + (setf (gadget-id (user-gadget gadget)) value)) + +(defmethod gadget-client ((gadget editor-substrate-mixin)) + (gadget-client (user-gadget gadget))) + +(defmethod (setf gadget-client) (value (gadget editor-substrate-mixin)) + (setf (gadget-client (user-gadget gadget)) value)) + +(defmethod gadget-armed-callback ((gadget editor-substrate-mixin)) + (gadget-armed-callback (user-gadget gadget))) + +(defmethod gadget-disarmed-callback ((gadget editor-substrate-mixin)) + (gadget-disarmed-callback (user-gadget gadget))) + +(defclass text-field-substrate-mixin (editor-substrate-mixin) + () + (:documentation "A mixin class for editor substrates used for text field gadgets.")) -(defmethod initialize-instance :after ((object text-field-pane) &key value) - ;; Why doesn't `value-gadget' do this for us? - (setf (gadget-value object) value)) +(defclass text-editor-substrate-mixin (editor-substrate-mixin) + ((ncolumns :reader text-editor-ncolumns + :initarg :ncolumns + :initform nil + :type (or null integer)) + (nlines :reader text-editor-nlines + :initarg :nlines + :initform nil + :type (or null integer))) + (:documentation "A mixin class for editor substrates used for text editor gadgets.")) + +;;; Now, define the Drei substrate. + +(defclass drei-editor-substrate (drei:drei-gadget-pane + editor-substrate-mixin) + () + (:documentation "A class for Drei-based editor substrates.")) -(defmethod compose-space ((pane text-field-pane) &key width height) +(defmethod (setf gadget-value) :after (value (gadget drei-editor-substrate) + &key invoke-callback) + (declare (ignore invoke-callback)) + ;; Hm! I wonder if this can cause trouble. I think not. + (drei:display-drei gadget)) + +(defclass drei-text-field-substrate (text-field-substrate-mixin + drei-editor-substrate) + () + (:documentation "The class for Drei-based text field substrates.")) + +(defmethod drei:handle-gesture ((drei drei-text-field-substrate) gesture) + (if (with-activation-gestures ((activation-gestures drei)) + (activation-gesture-p gesture)) + (activate-callback drei (gadget-client drei) (gadget-id drei)) + (call-next-method))) + +(defmethod compose-space ((pane drei-text-field-substrate) &key width height) (declare (ignore width height)) (with-sheet-medium (medium pane) (let ((as (text-style-ascent (medium-text-style medium) medium)) @@ -59,44 +118,14 @@ (let ((width w) (height (+ as ds))) (make-space-requirement :height height :max-height height :min-height height - :min-width width :width width))))) + :min-width width :width width))))) -(defmethod drei:handle-gesture ((drei text-field-pane) gesture) - (if (with-activation-gestures ((activation-gestures drei)) - (activation-gesture-p gesture)) - (activate-callback drei (gadget-client drei) (gadget-id drei)) - (call-next-method))) - -(defmethod allocate-space ((pane text-field-pane) w h) - (resize-sheet pane w h)) - -;;; ------------------------------------------------------------------------------------------ -;;; 30.4.9 The concrete text-editor Gadget +(defclass drei-text-editor-substrate (text-editor-substrate-mixin + drei-editor-substrate) + () + (:documentation "The class for Drei-based text editor substrates.")) -(defclass text-editor-pane (text-editor drei:drei-gadget-pane) - ((ncolumns :type (or null integer) - :initarg :ncolumns - :initform nil - :accessor text-editor-ncolumns) - (nlines :type (or null integer) - :initarg :nlines - :initform nil - :accessor text-editor-nlines)) - (:default-initargs :activation-gestures nil)) - -(defmethod initialize-instance :after ((object text-editor-pane) &key value) - ;; Why doesn't `value-gadget' do this for us? - (setf (gadget-value object) value)) - -(defmethod make-pane-1 :around (fm (frame application-frame) - (type (eql 'text-editor)) - &rest args &key) - (apply #'make-pane-1 fm frame :drei - :drei-class 'text-editor-pane - :minibuffer t - args)) - -(defmethod compose-space ((pane text-editor-pane) &key width height) +(defmethod compose-space ((pane drei-text-editor-substrate) &key width height) (with-sheet-medium (medium pane) (let* ((text-style (medium-text-style medium)) (line-height (+ (text-style-height text-style medium) @@ -113,86 +142,72 @@ (height (if nlines (+ (* nlines line-height)) height))) - (list :width width :max-width width :min-width width - :height height :max-height height :min-height height))))))) + (list + :width width :max-width width :min-width width + :height height :max-height height :min-height height))))))) -(defmethod allocate-space ((pane text-editor-pane) w h) +(defmethod allocate-space ((pane drei-text-editor-substrate) w h) (resize-sheet pane w h)) -;;; ------------------------------------------------------------------------------------------ -;;; 30.4.9 Alternative Goatee-based implementation - -(defparameter *default-text-field-text-style* - (make-text-style :fixed :roman :normal)) +;;; Now, define the Goatee substrate. -(defclass goatee-text-field-pane (text-field - standard-extended-output-stream - standard-output-recording-stream - basic-pane) - ((area :accessor area :initform nil - :documentation "The Goatee area used for text editing.") - (previous-focus :accessor previous-focus :initform nil - :documentation - "The pane that previously had keyboard focus") - (activation-gestures :accessor activation-gestures - :initarg :activation-gestures - :documentation "gestures that cause the - activate callback to be called")) +(defclass goatee-editor-substrate (editor-substrate-mixin + text-field + clim-stream-pane) + ((area :accessor area + :initform nil + :documentation "The Goatee area used for text editing.") + ;; This hack is necessary because the Goatee editing area is not + ;; created until the first redisplay... yuck. + (value :documentation "The initial value for the Goatee area.")) (:default-initargs - :text-style *default-text-field-text-style* - :activation-gestures *standard-activation-gestures*)) + :text-style *default-text-field-text-style*)) -(defmethod initialize-instance :after ((gadget text-field) &rest rest) - (unless (getf rest :normal) - (setf (slot-value gadget 'current-color) +white+ - (slot-value gadget 'normal) +white+))) - -(defmethod initialize-instance :after ((pane goatee-text-field-pane) &rest rest) +(defmethod initialize-instance :after ((pane goatee-editor-substrate) &rest rest) (declare (ignore rest)) - #-nil (setf (medium-text-style (sheet-medium pane)) - (slot-value pane 'text-style))) + (setf (medium-text-style (sheet-medium pane)) + (slot-value pane 'text-style))) ;; Is there really a benefit to waiting until the first painting to ;; create the goatee instance? Why not use INITIALIZE-INSTANCE? -(defmethod handle-repaint :before ((pane goatee-text-field-pane) region) +(defmethod handle-repaint :before ((pane goatee-editor-substrate) region) (declare (ignore region)) (unless (area pane) (multiple-value-bind (cx cy) - (stream-cursor-position pane) + (stream-cursor-position pane) (setf (cursor-visibility (stream-text-cursor pane)) nil) (setf (area pane) (make-instance 'goatee:simple-screen-area - :area-stream pane - :x-position cx - :y-position cy - :initial-contents (slot-value pane - 'value)))) + :area-stream pane + :x-position cx + :y-position cy + :initial-contents (slot-value pane 'value)))) (stream-add-output-record pane (area pane)))) ;;; This implements click-to-focus-keyboard-and-pass-click-through ;;; behaviour. -(defmethod handle-event :before - ((gadget goatee-text-field-pane) (event pointer-button-press-event)) +(defmethod handle-event :before + ((gadget goatee-editor-substrate) (event pointer-button-press-event)) (let ((previous (stream-set-input-focus gadget))) (when (and previous (typep previous 'gadget)) (disarmed-callback previous (gadget-client previous) (gadget-id previous))) (armed-callback gadget (gadget-client gadget) (gadget-id gadget)))) -(defmethod armed-callback :after ((gadget goatee-text-field-pane) client id) +(defmethod armed-callback :after ((gadget goatee-editor-substrate) client id) (declare (ignore client id)) (handle-repaint gadget +everywhere+) ;FIXME: trigger initialization (let ((cursor (cursor (area gadget)))) (letf (((cursor-state cursor) nil)) (setf (cursor-appearance cursor) :solid)))) -(defmethod disarmed-callback :after ((gadget goatee-text-field-pane) client id) +(defmethod disarmed-callback :after ((gadget goatee-editor-substrate) client id) (declare (ignore client id)) (handle-repaint gadget +everywhere+) ;FIXME: trigger initialization (let ((cursor (cursor (area gadget)))) (letf (((cursor-state cursor) nil)) (setf (cursor-appearance cursor) :hollow)))) -(defmethod handle-event - ((gadget goatee-text-field-pane) (event key-press-event)) +(defmethod handle-event + ((gadget goatee-editor-substrate) (event key-press-event)) (let ((gesture (convert-to-gesture event)) (*activation-gestures* (activation-gestures gadget))) (when (activation-gesture-p gesture) @@ -209,7 +224,7 @@ (gadget-id gadget) new-value))))) -(defmethod (setf gadget-value) :after (new-value (gadget goatee-text-field-pane) +(defmethod (setf gadget-value) :after (new-value (gadget goatee-editor-substrate) &key invoke-callback) (declare (ignore invoke-callback)) (let* ((area (area gadget)) @@ -221,7 +236,7 @@ (goatee::redisplay-area area))) #+nil -(defmethod handle-repaint ((pane goatee-text-field-pane) region) +(defmethod handle-repaint ((pane goatee-editor-substrate) region) (declare (ignore region)) (with-special-choices (pane) (with-sheet-medium (medium pane) @@ -233,8 +248,12 @@ :align-x :left :align-y :baseline))))) +(defclass goatee-text-field-substrate (text-field-substrate-mixin + goatee-editor-substrate) + () + (:documentation "The class for Goatee-based text field substrates.")) -(defmethod compose-space ((pane goatee-text-field-pane) &key width height) +(defmethod compose-space ((pane goatee-text-field-substrate) &key width height) (declare (ignore width height)) (with-sheet-medium (medium pane) (let ((as (text-style-ascent (medium-text-style medium) medium)) @@ -243,48 +262,140 @@ (let ((width w) (height (+ as ds))) (make-space-requirement :width width :height height - :max-width width :max-height height - :min-width width :min-height height))))) + :max-width width :max-height height + :min-width width :min-height height))))) + +(defclass goatee-text-editor-substrate (text-editor-substrate-mixin + goatee-editor-substrate) + () + (:documentation "The class for Goatee-based text field substrates.")) -(defmethod allocate-space ((pane goatee-text-field-pane) w h) +(defmethod compose-space ((pane goatee-text-editor-substrate) &key width height) + (with-sheet-medium (medium pane) + (let* ((text-style (medium-text-style medium)) + (line-height (+ (text-style-height text-style medium) + (stream-vertical-spacing pane))) + (column-width (text-style-width text-style medium))) + (with-accessors ((ncolumns text-editor-ncolumns) + (nlines text-editor-nlines)) pane + (apply #'space-requirement-combine* #'(lambda (req1 req2) + (or req2 req1)) + (call-next-method) + (let ((width (if ncolumns + (+ (* ncolumns column-width)) + width)) + (height (if nlines + (+ (* nlines line-height)) + height))) + (list :width width :max-width width :min-width width + :height height :max-height height :min-height height))))))) + +(defmethod allocate-space ((pane goatee-text-editor-substrate) w h) (resize-sheet pane w h)) -(defclass goatee-text-editor-pane (goatee-text-field-pane) - ((width :type integer - :initarg :width - :initform 300 - :reader text-editor-width) - (height :type integer - :initarg :height - :initform 300 - :reader text-editor-height)) - (:default-initargs :activation-gestures nil)) - -(defmethod compose-space ((pane goatee-text-editor-pane) &key width height) - (declare (ignore width height)) - (let ((width (text-editor-width pane)) - (height (text-editor-height pane))) - (make-space-requirement :width width - :min-width width - :max-width width - :height height - :min-height height - :max-height height))) +(defun make-text-field-substrate (user &rest args) + "Create an appropriate text field gadget editing substrate object." + (let* ((substrate (apply #'make-pane (if *use-goatee* + 'goatee-text-field-substrate + 'drei-text-field-substrate) + :user-gadget user args)) + (sheet substrate)) + (values substrate sheet))) + +(defun make-text-editor-substrate (user &rest args &key scroll-bars value + &allow-other-keys) + "Create an appropriate text editor gadget editing substrate +object. Returns two values, the first is the substrate object, +the second is the sheet that should be adopted by the user +gadget." + (let* ((minibuffer (when (and (not *use-goatee*) scroll-bars) + (make-pane 'drei::drei-minibuffer-pane))) + (substrate (apply #'make-pane (if *use-goatee* + 'goatee-text-editor-substrate + 'drei-text-editor-substrate) + :user-gadget user + :minibuffer minibuffer args)) + (sheet (if scroll-bars + (scrolling (:scroll-bars scroll-bars) + substrate) + substrate))) + (if *use-goatee* + (setf (slot-value substrate 'value) value) + (setf (gadget-value substrate) value)) + (values substrate (if minibuffer + (vertically () [90 lines skipped] --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2007/03/04 22:27:30 1.106 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2007/08/21 22:09:01 1.107 @@ -644,6 +644,11 @@ (:documentation "The value is a string") (:default-initargs :value "")) +(defmethod initialize-instance :after ((gadget text-field) &rest rest) + (unless (getf rest :normal) + (setf (slot-value gadget 'current-color) +white+ + (slot-value gadget 'normal) +white+))) + ;;; 30.4.9 The abstract text-editor Gadget (defclass text-editor (text-field)

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 21 Aug '07

21 Aug '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22905 Modified Files: panes.lisp Log Message: Attempt at making layout panes (scrollers in particular) less likely to eat space requirements. Issues may still crop up, I do not vouch for its correctness, but the old way was certainly just wrong. Please test. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2007/07/21 13:18:59 1.183 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2007/08/21 21:45:49 1.184 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.183 2007/07/21 13:18:59 rstrandh Exp $ +;;; $Id: panes.lisp,v 1.184 2007/08/21 21:45:49 thenriksen Exp $ (in-package :clim-internals) @@ -1171,7 +1171,7 @@ sum (space-requirement-max-major sr) into max-major maximize (space-requirement-minor sr) into minor maximize (space-requirement-min-minor sr) into min-minor - maximize (space-requirement-max-minor sr) into max-minor + minimize (space-requirement-max-minor sr) into max-minor finally (return (space-requirement+* @@ -1830,8 +1830,15 @@ (defmethod compose-space ((pane viewport-pane) &key width height) (declare (ignorable width height)) - ; I _think_ this is right, it certainly shouldn't be the requirements of the child. - (make-space-requirement)) + ;; I _think_ this is right, it certainly shouldn't be the + ;; requirements of the child, apart from the max sizes. If the child + ;; does not want to go bigger than a specific size, we should not + ;; force it to do so. + (let ((child-sr (compose-space (first (sheet-children pane))))) + (if child-sr + (make-space-requirement :max-width (space-requirement-max-width child-sr) + :max-height (space-requirement-max-height child-sr)) + (make-space-requirement)))) (defmethod allocate-space ((pane viewport-pane) width height) (with-slots (hscrollbar vscrollbar) (sheet-parent pane) @@ -1960,34 +1967,59 @@ (defmethod compose-space ((pane scroller-pane) &key width height) (declare (ignore width height)) (with-slots (viewport vscrollbar hscrollbar suggested-width suggested-height - x-spacing y-spacing scroll-bar) + x-spacing y-spacing scroll-bar) pane (if viewport (let ((req - ; v-- where does this requirement come from? - ; a: just an arbitrary default - (make-space-requirement + ;; v-- where does this requirement come from? + ;; a: just an arbitrary default + (make-space-requirement :width suggested-width :height suggested-height :max-width +fill+ :max-height +fill+ :min-width (max (* 2 x-spacing) (if (null scroll-bar) 0 30)) - :min-height (max (* 2 y-spacing) (if (null scroll-bar) 0 30))) - #+nil - (make-space-requirement :height +fill+ :width +fill+))) + :min-height (max (* 2 y-spacing) (if (null scroll-bar) 0 30)))) + (viewport-child (first (sheet-children viewport)))) (when vscrollbar (setq req (space-requirement+* - (space-requirement-combine #'max - req - (compose-space vscrollbar)) - :height *scrollbar-thickness* - :min-height *scrollbar-thickness* - :max-height *scrollbar-thickness*))) + (space-requirement-combine #'max + req + (compose-space vscrollbar)) + :height *scrollbar-thickness* + :min-height *scrollbar-thickness* + :max-height *scrollbar-thickness*))) (when hscrollbar (setq req (space-requirement+* - (space-requirement-combine #'max - req - (compose-space hscrollbar)) - :width *scrollbar-thickness* - :min-width *scrollbar-thickness* - :max-width *scrollbar-thickness*))) + (space-requirement-combine + #'max req (compose-space hscrollbar)) + :width *scrollbar-thickness* + :min-width *scrollbar-thickness* + :max-width *scrollbar-thickness*))) + (let* ((viewport-sr (compose-space viewport + :width suggested-width + :height suggested-height)) + (max-width (+ (space-requirement-max-width viewport-sr) + (if vscrollbar *scrollbar-thickness* 0) + ;; I don't know why this is necessary. + (if (extended-output-stream-p viewport-child) + (* 4 (stream-vertical-spacing viewport-child)) + 0))) + (max-height (+ (space-requirement-max-height viewport-sr) + (if hscrollbar *scrollbar-thickness* 0) + ;; I don't know why this is necessary. + (if (extended-output-stream-p viewport-child) + (* 4 (stream-vertical-spacing viewport-child)) + 0)))) + (setq req (make-space-requirement + :width (min (space-requirement-width req) + max-width) + :height (min (space-requirement-height req) + max-height) + :min-width (min (space-requirement-min-width req) + max-width) + :min-height (min (space-requirement-min-height req) + max-height) + :max-width max-width + :max-height max-height))) + req) (make-space-requirement))))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 20 Aug '07

20 Aug '07

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv20491/Drei Modified Files: input-editor.lisp Log Message: Fixed the nemesis for my earlier Drei hubris. Never declare the last bug fixed. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2007/08/20 14:27:13 1.18 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2007/08/20 20:07:45 1.19 @@ -341,9 +341,11 @@ ;; XXX: This behavior for the :rescan parameter is not mentioned ;; explicitly in any CLIM guide, but McCLIM input-editing ;; machinery relies on it. - (when (and (or rescan (not equal)) - (or rescan (not rescan-supplied-p))) - (queue-rescan stream)) + (if (and (or rescan (not equal)) + (not (and (null rescan) rescan-supplied-p))) + (queue-rescan stream) + (incf (stream-scan-pointer stream) (- (length new-contents) + (length old-contents)))) ;; We have to return "the position in the input buffer". We ;; return the insertion position. buffer-start)))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 20 Aug '07

20 Aug '07

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15306/Drei Modified Files: motion.lisp Log Message: Now considering the beginning of a buffer a page delimiter. --- /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2007/04/27 21:37:14 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2007/08/20 19:44:44 1.5 @@ -372,7 +372,7 @@ (progn (forward-object mark (length (page-delimiter syntax))) t) (progn (beginning-of-buffer mark) - nil)))) + t)))) (define-motion-fns page)

1 0

[mcclim-cvs] CVS mcclim/Drei/Tests
by thenriksen 20 Aug '07

20 Aug '07

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv15234/Drei/Tests Modified Files: editing-tests.lisp Log Message: Changed Drei tests to give more sensible information on errors. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/editing-tests.lisp 2007/08/15 10:03:32 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/editing-tests.lisp 2007/08/20 19:44:19 1.3 @@ -39,13 +39,13 @@ (let ((mark (clone-mark (point buffer) mark-stickto))) (setf (offset mark) offset) (funcall action buffer mark) - (is (string= (buffer-contents buffer) - end-contents)) + (is (string= end-contents + (buffer-contents buffer))) ;; `kill-ring-end-contents' is a list of what should ;; be at the top of the kill ring now. Assert that ;; it is. (handler-case (mapcar #'(lambda (killed-string expected) - (is (string= killed-string expected))) + (is (string= expected killed-string))) (loop repeat (length kill-ring-end-contents) collecting (coerce (kill-ring-yank kill-ring nil) 'string) do (rotate-yank-position kill-ring 1))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs August 2007