mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS update: Directory change: mcclim/Extensions
by mretzlaff＠common-lisp.net 24 Nov '05

24 Nov '05

Update of /project/mcclim/cvsroot/mcclim/Extensions In directory common-lisp.net:/tmp/cvs-serv13379/Extensions Log Message: Directory /project/mcclim/cvsroot/mcclim/Extensions added to the repository Date: Thu Nov 24 19:31:55 2005 Author: mretzlaff New directory mcclim/Extensions added

1 0

[mcclim-cvs] CVS update: mcclim/transforms.lisp
by gbaumann＠common-lisp.net 22 Nov '05

22 Nov '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv23878 Modified Files: transforms.lisp Log Message: Some times we would build standard-translations, that really should be the identity transformation. Date: Tue Nov 22 12:40:02 2005 Author: gbaumann Index: mcclim/transforms.lisp diff -u mcclim/transforms.lisp:1.29 mcclim/transforms.lisp:1.30 --- mcclim/transforms.lisp:1.29 Wed Feb 2 11:18:58 2005 +++ mcclim/transforms.lisp Tue Nov 22 12:40:02 2005 @@ -4,7 +4,7 @@ ;;; Created: 1998-09-29 ;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> ;;; License: LGPL (See file COPYING for details). -;;; $Id: transforms.lisp,v 1.29 2005/02/02 10:18:58 tmoore Exp $ +;;; $Id: transforms.lisp,v 1.30 2005/11/22 11:40:02 gbaumann Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2003 by Gilbert Baumann ;;; (c) copyright 2000 by @@ -133,8 +133,11 @@ (values mxx mxy myx myy tx ty))) (defun make-translation-transformation (dx dy) - (make-instance 'standard-translation - :dx (coordinate dx) :dy (coordinate dy))) + (cond ((and (coordinate= dx 0) (coordinate= dy 0)) + +identity-transformation+) + (t + (make-instance 'standard-translation + :dx (coordinate dx) :dy (coordinate dy))))) (defun make-rotation-transformation (angle &optional origin) (if origin @@ -666,9 +669,7 @@ ;; (compose-transformations A B)x = (A o B)x = ABx (with-slots ((dx1 dx) (dy1 dy)) transformation1 (with-slots ((dx2 dx) (dy2 dy)) transformation2 - (make-instance 'standard-translation - :dx (+ dx1 dx2) - :dy (+ dy1 dy2))))) + (make-translation-transformation (+ dx1 dx2) (+ dy1 dy2))))) (defmethod compose-transformations (transformation2 (transformation1 standard-identity-transformation))

1 0

[mcclim-cvs] CVS update: mcclim/Backends/PostScript/class.lisp mcclim/Backends/PostScript/graphics.lisp mcclim/Backends/PostScript/paper.lisp mcclim/Backends/PostScript/sheet.lisp
by crhodes＠common-lisp.net 31 Oct '05

31 Oct '05

Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory common-lisp.net:/tmp/cvs-serv32722/Backends/PostScript Modified Files: class.lisp graphics.lisp paper.lisp sheet.lisp Log Message: Add support for EPS output in the postscript backend. Essentially this is done by using output recording; we draw to a recording stream, measure the bounding box, then replay the output record. There's a currently unused (and undefined) hook for outputing device fonts, which we are using locally in the tablature editor; however, our implementation of device fonts sucks utterly majorly. Also add rudimentary test file. Date: Mon Oct 31 11:21:14 2005 Author: crhodes Index: mcclim/Backends/PostScript/class.lisp diff -u mcclim/Backends/PostScript/class.lisp:1.6 mcclim/Backends/PostScript/class.lisp:1.7 --- mcclim/Backends/PostScript/class.lisp:1.6 Thu Jul 4 08:57:43 2002 +++ mcclim/Backends/PostScript/class.lisp Mon Oct 31 11:21:14 2005 @@ -37,7 +37,8 @@ ;;;; Medium (defclass postscript-medium (basic-medium) - ()) + ((device-fonts :initform nil + :accessor device-fonts))) (defmacro postscript-medium-graphics-state (medium) `(first (slot-value (medium-sheet ,medium) 'graphics-state-stack))) @@ -84,7 +85,9 @@ *default-postscript-title*)) (for (or (getf header-comments :for) *default-postscript-for*)) - (region (paper-region device-type orientation)) + (region (case device-type + ((:eps) +everywhere+) + (t (paper-region device-type orientation)))) (transform (make-postscript-transformation device-type orientation))) (make-instance 'postscript-stream :file-stream file-stream Index: mcclim/Backends/PostScript/graphics.lisp diff -u mcclim/Backends/PostScript/graphics.lisp:1.13 mcclim/Backends/PostScript/graphics.lisp:1.14 --- mcclim/Backends/PostScript/graphics.lisp:1.13 Mon Aug 1 18:50:43 2005 +++ mcclim/Backends/PostScript/graphics.lisp Mon Oct 31 11:21:14 2005 @@ -169,23 +169,25 @@ "Native transformation") ;;; Postscript output utilities -(defmacro with-graphics-state ((medium) &body body) - `(invoke-with-graphics-state ,medium +(defmacro with-graphics-state ((stream) &body body) + `(invoke-with-graphics-state ,stream (lambda () ,@body))) -(defun postscript-save-graphics-state (medium) - (push (copy-list (postscript-medium-graphics-state medium)) - (slot-value (medium-sheet medium) 'graphics-state-stack)) - (format (postscript-medium-file-stream medium) "gsave~%")) - -(defun postscript-restore-graphics-state (medium) - (pop (slot-value (medium-sheet medium) 'graphics-state-stack)) - (format (postscript-medium-file-stream medium) "grestore~%")) +(defun postscript-save-graphics-state (stream) + (push (copy-list (first (slot-value stream 'graphics-state-stack))) + (slot-value stream 'graphics-state-stack)) + (when (stream-drawing-p stream) + (format (postscript-stream-file-stream stream) "gsave~%"))) + +(defun postscript-restore-graphics-state (stream) + (pop (slot-value stream 'graphics-state-stack)) + (when (stream-drawing-p stream) + (format (postscript-stream-file-stream stream) "grestore~%"))) -(defun invoke-with-graphics-state (medium continuation) - (postscript-save-graphics-state medium) +(defun invoke-with-graphics-state (stream continuation) + (postscript-save-graphics-state stream) (funcall continuation) - (postscript-restore-graphics-state medium)) + (postscript-restore-graphics-state stream)) ;;; Postscript path functions @@ -346,8 +348,8 @@ ;; does only one level of saving graphics state, so we can restore ;; and save again GS to obtain an initial CP. It is ugly, but I see ;; no other way now. -- APD, 2002-02-11 - (postscript-restore-graphics-state medium) - (postscript-save-graphics-state medium) + (postscript-restore-graphics-state (medium-sheet medium)) + (postscript-save-graphics-state (medium-sheet medium)) (postscript-set-clipping-region stream (medium-clipping-region medium))) @@ -494,7 +496,7 @@ (let ((*transformation* (sheet-native-transformation (medium-sheet medium)))) (let ((file-stream (postscript-medium-file-stream medium))) (postscript-actualize-graphics-state file-stream medium :color :text-style) - (with-graphics-state (medium) + (with-graphics-state ((medium-sheet medium)) #+ignore (when transform-glyphs ;; Index: mcclim/Backends/PostScript/paper.lisp diff -u mcclim/Backends/PostScript/paper.lisp:1.2 mcclim/Backends/PostScript/paper.lisp:1.3 --- mcclim/Backends/PostScript/paper.lisp:1.2 Fri May 31 04:32:10 2002 +++ mcclim/Backends/PostScript/paper.lisp Mon Oct 31 11:21:14 2005 @@ -55,6 +55,9 @@ (make-rectangle* 0 0 width height))) (defun make-postscript-transformation (paper-size-name orientation) + (when (eq paper-size-name :eps) + (return-from make-postscript-transformation + (make-reflection-transformation* 0 0 1 0))) (multiple-value-bind (width height) (paper-size paper-size-name) (case orientation (:portrait (make-3-point-transformation* @@ -63,4 +66,4 @@ (:landscape (make-3-point-transformation* 0 0 0 width height 0 width height 0 height width 0)) - (t (error "Unknown orientation"))))) \ No newline at end of file + (t (error "Unknown orientation"))))) Index: mcclim/Backends/PostScript/sheet.lisp diff -u mcclim/Backends/PostScript/sheet.lisp:1.9 mcclim/Backends/PostScript/sheet.lisp:1.10 --- mcclim/Backends/PostScript/sheet.lisp:1.9 Thu Apr 1 06:26:46 2004 +++ mcclim/Backends/PostScript/sheet.lisp Mon Oct 31 11:21:14 2005 @@ -58,29 +58,45 @@ orientation header-comments))) (unwind-protect (progn + (with-output-recording-options (stream :record t :draw nil) + (with-graphics-state (stream) + ;; we need at least one level of saving -- APD, 2002-02-11 + (funcall continuation stream))) (with-slots (file-stream title for orientation paper) stream - (format file-stream "%!PS-Adobe-3.0~%") + (format file-stream "%!PS-Adobe-3.0~@[ EPSF-3.0~*~]~%" + (eq device-type :eps)) (format file-stream "%%Creator: McCLIM~%") (format file-stream "%%Title: ~A~%" title) (format file-stream "%%For: ~A~%" for) (format file-stream "%%LanguageLevel: 2~%") - (multiple-value-bind (width height) - (paper-size paper) - (format file-stream "%%BoundingBox: 0 0 ~A ~A~%" width height) - (format file-stream "%%DocumentMedia: ~A ~A ~A 0 () ()~%" - paper width height)) - (format file-stream "%%Orientation: ~A~%" - (ecase orientation - (:portrait "Portrait") - (:landscape "Landscape"))) - (format file-stream "%%Pages: (atend)~%") + (case paper + ((:eps) + (let ((record (stream-output-history stream))) + (multiple-value-bind (lx ly ux uy) (bounding-rectangle* record) + (format file-stream "%%BoundingBox: ~A ~A ~A ~A~%" + (floor lx) (- (ceiling uy)) + (ceiling ux) (- (floor ly)))))) + (t + (multiple-value-bind (width height) + (paper-size paper) + (format file-stream "%%BoundingBox: 0 0 ~A ~A~%" width height) + (format file-stream "%%DocumentMedia: ~A ~A ~A 0 () ()~%" + paper width height)) + (format file-stream "%%Orientation: ~A~%" + (ecase orientation + (:portrait "Portrait") + (:landscape "Landscape"))) + (format file-stream "%%Pages: (atend)~%"))) (format file-stream "%%DocumentNeededResources: (atend)~%") (format file-stream "%%EndComments~%~%") (write-postcript-dictionary file-stream) - (start-page stream)) - (with-graphics-state ((sheet-medium stream)) - ;; we need at least one level of saving -- APD, 2002-02-11 - (funcall continuation stream))) + (dolist (text-style (device-fonts (sheet-medium stream))) + (write-font-to-postscript-stream (sheet-medium stream) text-style)) + (start-page stream) + (let ((record (stream-output-history stream))) + (with-output-recording-options (stream :draw t :record nil) + (with-graphics-state (stream) + (replay record stream)))))) (with-slots (file-stream current-page) stream (format file-stream "end~%showpage~%~%") (format file-stream "%%Trailer~%")

1 0

[mcclim-cvs] CVS update: mcclim/Tests/postscript.lisp
by crhodes＠common-lisp.net 31 Oct '05

31 Oct '05

Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv32722/Tests Added Files: postscript.lisp Log Message: Add support for EPS output in the postscript backend. Essentially this is done by using output recording; we draw to a recording stream, measure the bounding box, then replay the output record. There's a currently unused (and undefined) hook for outputing device fonts, which we are using locally in the tablature editor; however, our implementation of device fonts sucks utterly majorly. Also add rudimentary test file. Date: Mon Oct 31 11:21:11 2005 Author: crhodes

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/medium.lisp
by rstrandh＠common-lisp.net 27 Oct '05

27 Oct '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv6115/Backends/CLX Modified Files: medium.lisp Log Message: Implemented double buffering for CLIM stream panes that want it. Use the `:double-buffering t' initarg to obtain it. Date: Thu Oct 27 03:21:35 2005 Author: rstrandh Index: mcclim/Backends/CLX/medium.lisp diff -u mcclim/Backends/CLX/medium.lisp:1.67 mcclim/Backends/CLX/medium.lisp:1.68 --- mcclim/Backends/CLX/medium.lisp:1.67 Sun Aug 14 14:47:42 2005 +++ mcclim/Backends/CLX/medium.lisp Thu Oct 27 03:21:35 2005 @@ -34,15 +34,11 @@ ;;; CLX-MEDIUM class (defclass clx-medium (basic-medium) - ((gc - :initform nil) - (picture - :initform nil) + ((gc :initform nil) + (picture :initform nil) #+unicode - (fontset - :initform nil - :accessor medium-fontset) - )) + (fontset :initform nil :accessor medium-fontset) + (buffer :initform nil :accessor medium-buffer))) #+CLX-EXT-RENDER (defun clx-medium-picture (clx-medium) @@ -338,19 +334,19 @@ (defmacro with-clx-graphics ((medium) &body body) `(let* ((port (port ,medium)) - (mirror (port-lookup-mirror port (medium-sheet ,medium)))) + (mirror (or (medium-buffer medium) (port-lookup-mirror port (medium-sheet ,medium))))) (when mirror (let* ((line-style (medium-line-style ,medium)) - (ink (medium-ink ,medium)) - (gc (medium-gcontext ,medium ink)) - #+unicode - (*fontset* (or (medium-fontset ,medium) - (setf (medium-fontset ,medium) - (text-style-to-X-fontset (port ,medium) *default-text-style*))))) - line-style ink - (unwind-protect - (progn ,@body) - #+ignore(xlib:free-gcontext gc)))))) + (ink (medium-ink ,medium)) + (gc (medium-gcontext ,medium ink)) + #+unicode + (*fontset* (or (medium-fontset ,medium) + (setf (medium-fontset ,medium) + (text-style-to-X-fontset (port ,medium) *default-text-style*))))) + line-style ink + (unwind-protect + (progn ,@body) + #+ignore(xlib:free-gcontext gc)))))) ;;; Pixmaps @@ -367,7 +363,7 @@ (medium-gcontext from-drawable +background-ink+) (round-coordinate from-x) (round-coordinate from-y) (round width) (round height) - (sheet-direct-mirror (medium-sheet to-drawable)) + (or (medium-buffer to-drawable) (sheet-direct-mirror (medium-sheet to-drawable))) (round-coordinate to-x) (round-coordinate to-y))))) (defmethod medium-copy-area ((from-drawable clx-medium) from-x from-y width height @@ -389,7 +385,7 @@ (medium-gcontext to-drawable +background-ink+) (round-coordinate from-x) (round-coordinate from-y) (round width) (round height) - (sheet-direct-mirror (medium-sheet to-drawable)) + (or (medium-buffer to-drawable) (sheet-direct-mirror (medium-sheet to-drawable))) (round-coordinate to-x) (round-coordinate to-y)))) (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height @@ -1013,13 +1009,16 @@ (min-y (round-coordinate (min top bottom))) (max-x (round-coordinate (max left right))) (max-y (round-coordinate (max top bottom)))) - (xlib:clear-area (port-lookup-mirror (port medium) - (medium-sheet medium)) - :x (max #x-8000 (min #x7fff min-x)) - :y (max #x-8000 (min #x7fff min-y)) - :width (max 0 (min #xffff (- max-x min-x))) - :height (max 0 (min #xffff (- max-y min-y))))))))) - + (xlib:draw-rectangle (or (medium-buffer medium) + (port-lookup-mirror (port medium) + (medium-sheet medium))) + (medium-gcontext medium (medium-background medium)) + (max #x-8000 (min #x7fff min-x)) + (max #x-8000 (min #x7fff min-y)) + (max 0 (min #xffff (- max-x min-x))) + (max 0 (min #xffff (- max-y min-y))) + t)))))) + (defmethod medium-beep ((medium clx-medium)) (xlib:bell (clx-port-display (port medium)))) @@ -1040,3 +1039,18 @@ (defmethod medium-miter-limit ((medium clx-medium)) #.(* pi (/ 11 180))) + +(defmethod climi::medium-invoke-with-possible-double-buffering (frame pane (medium clx-medium) continuation) + (if (climi::pane-double-buffering pane) + (let* ((mirror (sheet-direct-mirror pane)) + (width (xlib:drawable-width mirror)) + (height (xlib:drawable-height mirror)) + (depth (xlib:drawable-depth mirror)) + (pixmap (xlib:create-pixmap :width width :height height :depth depth :drawable mirror))) + (setf (medium-buffer medium) pixmap) + (unwind-protect (funcall continuation) + (xlib:copy-area pixmap (medium-gcontext medium (medium-foreground medium)) 0 0 width height mirror 0 0) + (xlib:free-pixmap pixmap) + (setf (medium-buffer medium) nil))) + (funcall continuation))) +

1 0

[mcclim-cvs] CVS update: mcclim/frames.lisp mcclim/panes.lisp
by rstrandh＠common-lisp.net 27 Oct '05

27 Oct '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv6115 Modified Files: frames.lisp panes.lisp Log Message: Implemented double buffering for CLIM stream panes that want it. Use the `:double-buffering t' initarg to obtain it. Date: Thu Oct 27 03:21:34 2005 Author: rstrandh Index: mcclim/frames.lisp diff -u mcclim/frames.lisp:1.108 mcclim/frames.lisp:1.109 --- mcclim/frames.lisp:1.108 Thu Aug 18 05:17:21 2005 +++ mcclim/frames.lisp Thu Oct 27 03:21:33 2005 @@ -427,6 +427,23 @@ (declare (ignore pane force-p)) nil) +(defgeneric medium-invoke-with-possible-double-buffering (frame pane medium continuation)) + +(defmethod medium-invoke-with-possible-double-buffering (frame pane medium continuation) + (funcall continuation)) + +(defgeneric invoke-with-possible-double-buffering (frame pane continuation)) + +(defmethod invoke-with-possible-double-buffering (frame pane continuation) + (declare (ignore frame pane)) + (funcall continuation)) + +(defmethod invoke-with-possible-double-buffering (frame (pane sheet-with-medium-mixin) continuation) + (medium-invoke-with-possible-double-buffering frame pane (sheet-medium pane) continuation)) + +(defmacro with-possible-double-buffering ((frame pane) &body body) + `(invoke-with-possible-double-buffering ,frame ,pane (lambda () ,@body))) + (defmethod redisplay-frame-pane :around ((frame application-frame) pane &key force-p) (multiple-value-bind (redisplayp clearp) @@ -439,9 +456,10 @@ (when hilited (highlight-presentation-1 (car hilited) (cdr hilited) :unhighlight) (setf (frame-hilited-presentation frame) nil))) - (when clearp - (window-clear pane)) - (call-next-method) + (with-possible-double-buffering (frame pane) + (when clearp + (window-clear pane)) + (call-next-method)) (unless (or (eq redisplayp :command-loop) (eq redisplayp :no-clear)) (setf (pane-needs-redisplay pane) nil))))) Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.155 mcclim/panes.lisp:1.156 --- mcclim/panes.lisp:1.155 Tue Aug 30 00:39:31 2005 +++ mcclim/panes.lisp Thu Oct 27 03:21:33 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.155 2005/08/29 22:39:31 mretzlaff Exp $ +;;; $Id: panes.lisp,v 1.156 2005/10/27 01:21:33 rstrandh Exp $ (in-package :clim-internals) @@ -2219,6 +2219,12 @@ (declare (ignore force-p)) (invoke-display-function frame pane)) +(defgeneric pane-double-buffering (pane)) + +(defmethod pane-double-buffering (pane) + (declare (ignore pane)) + nil) + (defclass clim-stream-pane (updating-output-stream-mixin pane-display-mixin permanent-medium-sheet-output-mixin @@ -2252,6 +2258,9 @@ (end-of-page-action :initform :scroll :initarg :end-of-line-action :reader pane-end-of-page-action) + (double-buffering :initform nil + :initarg :double-buffering + :reader pane-double-buffering) ;; Slots of space-requirement-options-mixin defined with accessors for our ;; convenience (user-width :accessor pane-user-width)

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/dev-commands.lisp
by mretzlaff＠common-lisp.net 13 Oct '05

13 Oct '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv8918 Modified Files: dev-commands.lisp Log Message: SORT-PATHNAMES changed: For pathnames that represent directories (first (last (pathname-directory pathname))) will be the :KEY to SORT them. Date: Thu Oct 13 17:15:24 2005 Author: mretzlaff Index: mcclim/Apps/Listener/dev-commands.lisp diff -u mcclim/Apps/Listener/dev-commands.lisp:1.30 mcclim/Apps/Listener/dev-commands.lisp:1.31 --- mcclim/Apps/Listener/dev-commands.lisp:1.30 Wed Aug 31 07:50:37 2005 +++ mcclim/Apps/Listener/dev-commands.lisp Thu Oct 13 17:15:24 2005 @@ -1029,7 +1029,10 @@ (defun sort-pathnames (list sort-by) (case sort-by ; <--- FIXME - ('name (sort list #'string-lessp :key #'file-namestring)) + ('name (sort list #'string-lessp + :key (lambda (pathname) + (or (file-namestring pathname) + (first (last (pathname-directory pathname))))))) (t list))) (defun split-sort-pathnames (list group-dirs sort-by)

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/util.lisp
by mretzlaff＠common-lisp.net 13 Oct '05

13 Oct '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv5766 Modified Files: util.lisp Log Message: Adds a version of LIST-DIRECTORY for Allegro Common Lisp, and adds a read-time check for :ALLEGRO to GEN-WILD-PATHNAME as ACL doesn't allow PATHNAMES to have :VERSION specified as :WILD (ACL now gets :UNSPECIFIC). (A bug report has been sent to Franz a while ago.) Date: Thu Oct 13 16:32:13 2005 Author: mretzlaff Index: mcclim/Apps/Listener/util.lisp diff -u mcclim/Apps/Listener/util.lisp:1.18 mcclim/Apps/Listener/util.lisp:1.19 --- mcclim/Apps/Listener/util.lisp:1.18 Wed Aug 31 07:50:37 2005 +++ mcclim/Apps/Listener/util.lisp Thu Oct 13 16:32:13 2005 @@ -138,8 +138,12 @@ (defun list-directory (pathname) (directory pathname :directories t :follow-links nil)) +#+ALLEGRO +(defun list-directory (pathname) + (directory pathname :directories-are-files nil)) + ;; Fallback to ANSI CL -#-(OR CMU SBCL OPENMCL) +#-(OR CMU SBCL OPENMCL ALLEGRO) (defun list-directory (pathname) (directory pathname)) @@ -257,7 +261,8 @@ :directory (pathname-directory pathname) :name (or (pathname-name pathname) :wild) :type (or (pathname-type pathname) :wild) - :version (or :wild + :version (or #+allegro :unspecific + :wild ;#-SBCL (pathname-version pathname) ;#+SBCL :newest )))

1 0

[mcclim-cvs] CVS update: mcclim/stream-output.lisp mcclim/gadgets.lisp
by rschlatte＠common-lisp.net 12 Oct '05

12 Oct '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv20252 Modified Files: stream-output.lisp gadgets.lisp Log Message: Draw hollow or filled cursor in text-field gadget, depending on whether the gadget is armed or not. Date: Wed Oct 12 16:22:28 2005 Author: rschlatte Index: mcclim/stream-output.lisp diff -u mcclim/stream-output.lisp:1.56 mcclim/stream-output.lisp:1.57 --- mcclim/stream-output.lisp:1.56 Sat Aug 13 16:28:20 2005 +++ mcclim/stream-output.lisp Wed Oct 12 16:22:27 2005 @@ -78,6 +78,9 @@ (x :initform 0 :initarg :x-position) (y :initform 0 :initarg :y-position) (width :initform 8) + (appearance :type (member :solid :hollow) + :initarg :appearance :initform :hollow + :accessor cursor-appearance) ;; XXX what does "cursor is active" mean? ;; It means that the sheet (stream) updates the cursor, though ;; currently the cursor appears to be always updated after stream @@ -142,7 +145,8 @@ (draw-rectangle* (sheet-medium (cursor-sheet cursor)) x y (+ x width) (+ y height) - :filled t + :filled (ecase (cursor-appearance cursor) + (:solid t) (:hollow nil)) :ink +flipping-ink+))))) (defmethod display-cursor ((cursor cursor-mixin) state) @@ -154,7 +158,8 @@ (:draw (draw-rectangle* (sheet-medium (cursor-sheet cursor)) x y (+ x width) (+ y height) - :filled t + :filled (ecase (cursor-appearance cursor) + (:solid t) (:hollow nil)) :ink +foreground-ink+ )) (:erase @@ -168,7 +173,8 @@ (draw-rectangle* (sheet-medium (cursor-sheet cursor)) x y (+ x width) (+ y height) - :filled t + :filled (ecase (cursor-appearance cursor) + (:solid t) (:hollow nil)) :ink +background-ink+)))))) ;;; Standard-Text-Cursor class Index: mcclim/gadgets.lisp diff -u mcclim/gadgets.lisp:1.90 mcclim/gadgets.lisp:1.91 --- mcclim/gadgets.lisp:1.90 Mon May 23 14:43:34 2005 +++ mcclim/gadgets.lisp Wed Oct 12 16:22:27 2005 @@ -2634,13 +2634,20 @@ (declare (ignore client id)) (let ((port (port gadget))) (setf (previous-focus gadget) (port-keyboard-input-focus port)) - (setf (port-keyboard-input-focus port) gadget))) + (setf (port-keyboard-input-focus port) gadget)) + (let ((cursor (cursor (area gadget)))) + (letf (((cursor-state cursor) nil)) + (setf (cursor-appearance cursor) :solid)))) (defmethod disarmed-callback :after ((gadget text-field-pane) client id) (declare (ignore client id)) (let ((port (port gadget))) (setf (port-keyboard-input-focus port) (previous-focus gadget)) - (setf (previous-focus gadget) nil))) + (setf (previous-focus gadget) nil)) + (let ((cursor (cursor (area gadget)))) + (letf (((cursor-state cursor) nil)) + (setf (cursor-appearance cursor) :hollow)))) + (defmethod handle-event ((gadget text-field-pane) (event key-press-event)) (let ((gesture (convert-to-gesture event))

1 0

[mcclim-cvs] CVS update: mcclim/.cvsignore
by rschlatte＠common-lisp.net 11 Oct '05

11 Oct '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv13758 Modified Files: .cvsignore Log Message: Update various .cvsignore files to unclutter my pcl-cvs screen Date: Tue Oct 11 15:54:46 2005 Author: rschlatte Index: mcclim/.cvsignore diff -u mcclim/.cvsignore:1.1 mcclim/.cvsignore:1.2 --- mcclim/.cvsignore:1.1 Sun Aug 8 18:19:53 2004 +++ mcclim/.cvsignore Tue Oct 11 15:54:46 2005 @@ -1 +1,2 @@ *.dfsl +*.fasl

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs