- mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

[mcclim-cvs] CVS update: mcclim/Backends/CLX/medium.lisp
by tmoore＠common-lisp.net 17 Feb '05

17 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv491 Modified Files: medium.lisp Log Message: Alastair Bridgewater's fix to medium-clear-area. Fixes Paolo bug clx-medium-clear-area-transform Date: Thu Feb 17 22:23:29 2005 Author: tmoore Index: mcclim/Backends/CLX/medium.lisp diff -u mcclim/Backends/CLX/medium.lisp:1.65 mcclim/Backends/CLX/medium.lisp:1.66 --- mcclim/Backends/CLX/medium.lisp:1.65 Tue Jan 18 14:35:26 2005 +++ mcclim/Backends/CLX/medium.lisp Thu Feb 17 22:23:29 2005 @@ -965,13 +965,19 @@ (xlib:display-force-output (clx-port-display (port medium)))) (defmethod medium-clear-area ((medium clx-medium) left top right bottom) - (let ((min-x (round-coordinate (min left right))) - (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 min-x :y min-y - :width (- max-x min-x) :height (- max-y min-y)))) + (let ((tr (sheet-native-transformation (medium-sheet medium)))) + (with-transformed-position (tr left top) + (with-transformed-position (tr right bottom) + (let ((min-x (round-coordinate (min left right))) + (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))))))))) (defmethod medium-beep ((medium clx-medium)) (xlib:bell (clx-port-display (port medium))))

1 0

[mcclim-cvs] CVS update: mcclim/mcclim.asd
by afuchs＠common-lisp.net 16 Feb '05

16 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv19230 Added Files: mcclim.asd Log Message: Adding the ASDF-only dependency-aware mcclim.asd file. This file buys McCLIM ASDF-INSTALLability, among other things. Date: Wed Feb 16 21:43:26 2005 Author: afuchs

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by pscott＠common-lisp.net 15 Feb '05

15 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv15800 Modified Files: inspector.lisp Log Message: Major changes: Added with-heading-style macro which currently bolds its output, and changed a bunch of things to use this everywhere we have headings. This makes the inspector look *much* nicer. Minor change: turned a (loop for foo in bar do ...) into a DOLIST, which uses less indentation and is arguably clearer. Date: Wed Feb 16 00:12:08 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.21 mcclim/Apps/Inspector/inspector.lisp:1.22 --- mcclim/Apps/Inspector/inspector.lisp:1.21 Fri Feb 11 22:41:25 2005 +++ mcclim/Apps/Inspector/inspector.lisp Wed Feb 16 00:12:07 2005 @@ -128,6 +128,12 @@ (declare (ignore acceptably for-context-type)) (format stream "~s" (cdr object))) +(defmacro with-heading-style ((stream) &body body) + "Cause text output from BODY to be formatted in a heading font. This +could be boldface, or a different style, or even another font." + `(with-text-face (,stream :bold) + ,@body)) + (defmacro inspector-table (header &body body) "Present OBJECT (captured from environment) in tabular form, with HEADER printed in a box at the top. BODY should output the rows of the @@ -140,7 +146,8 @@ (formatting-column (pane) (formatting-cell (pane) (surrounding-output-with-border (pane) - ,header)) + (with-heading-style (pane) + ,header))) (formatting-cell (pane) (formatting-table (pane) ,@body)))) @@ -151,7 +158,8 @@ environment created by INSPECTOR-TABLE." `(formatting-row (pane) (formatting-cell (pane :align-x :right) - ,left) + (with-heading-style (pane) + ,left)) (formatting-cell (pane) ,right))) @@ -159,7 +167,9 @@ "Print OBJECT's documentation, if any, to PANE" (when (handler-bind ((warning #'muffle-warning)) (documentation object t)) - (format pane "~&Documentation: ~A" (documentation object t)))) + (with-heading-style (pane) + (format pane "~&Documentation: ")) + (princ (documentation object t) pane))) (defun inspect-structure-or-object (object pane) "Inspect a structure or an object. Since both can be inspected in @@ -171,13 +181,13 @@ (print (class-name class) pane) (when (clim-mop:class-direct-superclasses class) (inspector-table-row - (format pane "Superclasses") + (princ "Superclasses" pane) (dolist (superclass (clim-mop:class-direct-superclasses class)) (inspect-object superclass pane) (terpri pane)))) (when (clim-mop:class-direct-subclasses class) (inspector-table-row - (format pane "Subclasses") + (princ "Subclasses" pane) (dolist (subclass (clim-mop:class-direct-subclasses class)) (inspect-object subclass pane) (terpri pane)))) @@ -191,6 +201,8 @@ (inspect-object (slot-value object slot-name) pane) (format pane "#<unbound slot>")))))))) +;; Try to print the normal, textual representation of an object, but +;; if that's too long, make an abbreviated "instance of ~S" version. ;; FIXME: should this be removed? It's really ugly. (defparameter *object-representation-max-length* 300 "Maximum number of characters of an object's textual representation @@ -208,9 +220,6 @@ (error () (format pane "#<unprintable ~S>" (class-name (class-of object))))))) -;; Try to print the normal, textual representation of an object, but -;; if that's too long, make an abbreviated "instance of ~S" version. - (defmethod inspect-object-briefly ((object standard-object) pane) (inspect-structure-or-object-briefly object pane)) @@ -319,24 +328,24 @@ (inspector-table (format pane "Generic Function: ~s" (clim-mop:generic-function-name object)) - (loop for method in (clim-mop:generic-function-methods object) - do (with-output-as-presentation - (pane method (presentation-type-of method)) - (formatting-row (pane) - (formatting-cell (pane) - (print (method-qualifiers method))) - (loop for specializer in (clim-mop:method-specializers method) - do (formatting-cell (pane) - (if (typep specializer 'clim-mop:eql-specializer) - (progn - (princ "(EQL " pane) - (inspect-object - (clim-mop:eql-specializer-object - specializer) - pane) - (princ ")" pane)) - (inspect-object (class-name specializer) - pane))))))))) + (dolist (method (clim-mop:generic-function-methods object)) + (with-output-as-presentation + (pane method (presentation-type-of method)) + (formatting-row (pane) + (formatting-cell (pane) + (print (method-qualifiers method))) + (loop for specializer in (clim-mop:method-specializers method) + do (formatting-cell (pane) + (if (typep specializer 'clim-mop:eql-specializer) + (progn + (princ "(EQL " pane) + (inspect-object + (clim-mop:eql-specializer-object + specializer) + pane) + (princ ")" pane)) + (inspect-object (class-name specializer) + pane))))))))) (defun pretty-print-function (fun) "Print a function in a readable way, returning a string. On most @@ -362,12 +371,15 @@ (defmethod inspect-object ((object function) pane) (with-output-as-presentation (pane object (presentation-type-of object)) - (format pane "Function: ~A" - (pretty-print-function object)) + (with-heading-style (pane) + (princ "Function: " pane)) + (princ (pretty-print-function object) pane) #+sbcl (unless (typep object 'generic-function) - (format pane "~&Type: ~A" - (sb-kernel:%simple-fun-type (sb-kernel:%closure-fun object)))) + (with-heading-style (pane) + (format pane "~&Type: ")) + (princ (sb-kernel:%simple-fun-type (sb-kernel:%closure-fun object)) + pane)) (print-documentation object pane))) (defmethod inspect-object-briefly ((object package) pane) @@ -386,8 +398,13 @@ (inspect-object nick pane))) (inspector-table-row (princ "Used by:") + ;; FIXME: This should use some sort of list formatting, so that + ;; it can obey conventions about *print-length* and reuse code + ;; for modifying it. To support this, list printing should + ;; support delimiterless, one-item-per-line display. (dolist (used-by (package-used-by-list object)) - (inspect-object used-by pane))) + (fresh-line pane) + (inspect-object used-by pane))) (inspector-table-row (princ "Uses:") (dolist (uses (package-use-list object)) @@ -580,19 +597,24 @@ (find slot-name (clim-mop:class-slots class) :key #'clim-mop:slot-definition-name)))) (when documentation - (format stream "~&Documentation: ~A~%" documentation)) - (format stream "~&Type: ~S~%" - (clim-mop:slot-definition-type slot-object)) - (format stream "~&Allocation: ~S~%" - (clim-mop:slot-definition-allocation slot-object)) + (with-heading-style (stream) + (format stream "~&Documentation: ")) + (format stream "~A~%" documentation)) + (with-heading-style (stream) + (format stream "~&Type: ")) + (format stream "~S~%" (clim-mop:slot-definition-type slot-object)) + (with-heading-style (stream) + (format stream "~&Allocation: ")) + (format stream "~S~%" (clim-mop:slot-definition-allocation slot-object)) ;; slot-definition-{readers,writers} only works for direct slot ;; definitions (let ((readers (clim-mop:slot-definition-readers slot-object))) (when readers - (format stream "~&Readers: ") + (with-heading-style (stream) + (format stream "~&Readers: ")) (present readers (presentation-type-of readers) :stream stream))) (let ((writers (clim-mop:slot-definition-writers slot-object))) (when writers - (format stream "~&Writers: ") + (with-heading-style (stream) + (format stream "~&Writers: ")) (present writers (presentation-type-of writers) :stream stream)))))) -

1 0

[mcclim-cvs] CVS update: mcclim/recording.lisp
by crhodes＠common-lisp.net 15 Feb '05

15 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv10043 Modified Files: recording.lisp Log Message: Maybe fix circle/ellipse drawing in with-room-for-graphics and with-first-quadrant-coordinates. (Weirdest. Coordinate. System. Ever.) Date: Tue Feb 15 12:28:11 2005 Author: crhodes Index: mcclim/recording.lisp diff -u mcclim/recording.lisp:1.117 mcclim/recording.lisp:1.118 --- mcclim/recording.lisp:1.117 Fri Feb 11 10:10:36 2005 +++ mcclim/recording.lisp Tue Feb 15 12:28:11 2005 @@ -1570,6 +1570,8 @@ ;; will break other things. -Hefner (setf start-angle (untransform-angle transform start-angle)) (setf end-angle (untransform-angle transform end-angle)) + (when (reflection-transformation-p transform) + (rotatef start-angle end-angle)) (multiple-value-bind (min-x min-y max-x max-y) (bounding-rectangle* (make-ellipse* center-x center-y radius-1-dx radius-1-dy

1 0

[mcclim-cvs] CVS update: mcclim/text-selection.lisp
by crhodes＠common-lisp.net 14 Feb '05

14 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv15230 Modified Files: text-selection.lisp Log Message: Fix bug reported by Paolo ("Missing CLIMI::Y2 slot error") Date: Mon Feb 14 17:31:42 2005 Author: crhodes Index: mcclim/text-selection.lisp diff -u mcclim/text-selection.lisp:1.3 mcclim/text-selection.lisp:1.4 --- mcclim/text-selection.lisp:1.3 Thu Feb 10 10:54:26 2005 +++ mcclim/text-selection.lisp Mon Feb 14 17:31:41 2005 @@ -410,7 +410,7 @@ (map nil (lambda (m) (with-slots (record styled-string start end) m - (with-slots (y1 y2) record + (with-standard-rectangle* (:y1 y1 :y2 y2) record (if (and old-y2 (>= y1 old-y2)) (progn (setf old-y2 nil)

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by pscott＠common-lisp.net 11 Feb '05

11 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv10021 Modified Files: inspector.lisp Log Message: Added "class:" to display of symbols. This is not, strictly speaking, a property of the symbol. However, this is useful enough that I think it's worth including, since it can eliminate some minor annoyances. Date: Fri Feb 11 22:41:25 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.20 mcclim/Apps/Inspector/inspector.lisp:1.21 --- mcclim/Apps/Inspector/inspector.lisp:1.20 Tue Feb 8 23:14:01 2005 +++ mcclim/Apps/Inspector/inspector.lisp Fri Feb 11 22:41:25 2005 @@ -475,6 +475,14 @@ (if (fboundp object) (inspect-object (symbol-function object) pane) (princ "unbound"))) + ;; This is not, strictly speaking, a property of the + ;; symbol. However, this is useful enough that I think it's worth + ;; including here, since it can eliminate some minor annoyances. + (inspector-table-row + (princ "class:") + (if (find-class object nil) + (inspect-object (find-class object) pane) + (princ "unbound"))) (inspector-table-row (princ "package:") (inspect-object (symbol-package object) pane))

1 0

[mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp
by tmoore＠common-lisp.net 11 Feb '05

11 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv15125 Modified Files: incremental-redisplay.lisp Log Message: In COMPUTE-DIFFERENCE-SET fix null visible-region case. Thanks to Christophe Rhodes. Date: Fri Feb 11 13:55:49 2005 Author: tmoore Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.43 mcclim/incremental-redisplay.lisp:1.44 --- mcclim/incremental-redisplay.lisp:1.43 Fri Feb 11 12:50:22 2005 +++ mcclim/incremental-redisplay.lisp Fri Feb 11 13:55:49 2005 @@ -453,10 +453,9 @@ (defmethod print-object ((obj standard-updating-output-record) stream) (print-unreadable-object (obj stream :type t :identity t) - (when (slot-boundp obj 'x1) - (with-slots (x1 y1 x2 y2) obj - (format stream "X ~S:~S Y ~S:~S " x1 x2 y1 y2)) - (format stream "~S" (output-record-dirty obj))) + (with-standard-rectangle (x1 y1 x2 y2) + obj + (format stream "X ~S:~S Y ~S:~S " x1 x2 y1 y2)) (when (slot-boundp obj 'unique-id) (let ((*print-length* 10) (*print-level* 3)) @@ -726,6 +725,7 @@ rect (make-bounding-rectangle min-x min-y max-x max-y))) +;;; work in progress (defvar *existing-output-records* nil) (defmethod compute-difference-set ((record standard-updating-output-record) @@ -746,7 +746,8 @@ (old-children (if (slot-boundp record 'old-children) (old-children record) nil))) - (unless (or (region-intersects-region-p visible-region record) + (unless (or (null visible-region) + (region-intersects-region-p visible-region record) (and old-children (region-intersects-region-p visible-region old-children))) (return-from compute-difference-set (values nil nil nil nil nil)))

1 0

[mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp
by tmoore＠common-lisp.net 11 Feb '05

11 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv11082 Modified Files: incremental-redisplay.lisp Log Message: Exit early from COMPUTE-DIFFERENCE-SET if both the old and new trees lie outside the visible region on the screen. This fixes a problem that I believe was introduced in 1.35: COMPUTE-DIFFERENCE-SET has to run on all updating-output records in a tree, but the full difference algorithm shouldn't be invoked if nothing is or was visible. Date: Fri Feb 11 12:50:22 2005 Author: tmoore Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.42 mcclim/incremental-redisplay.lisp:1.43 --- mcclim/incremental-redisplay.lisp:1.42 Tue Jan 18 10:16:30 2005 +++ mcclim/incremental-redisplay.lisp Fri Feb 11 12:50:22 2005 @@ -726,6 +726,8 @@ rect (make-bounding-rectangle min-x min-y max-x max-y))) +(defvar *existing-output-records* nil) + (defmethod compute-difference-set ((record standard-updating-output-record) &optional (check-overlapping t) offset-x offset-y @@ -733,7 +735,7 @@ (declare (ignore offset-x offset-y old-offset-x old-offset-y)) (when (eq (output-record-dirty record) :clean) (return-from compute-difference-set (values nil nil nil nil nil))) - (let* ((existing-output-records (make-hash-table :test #'eq)) + (let* ((existing-output-records nil) (draws nil) (moves (explicit-moves record)) (erases nil) @@ -744,6 +746,13 @@ (old-children (if (slot-boundp record 'old-children) (old-children record) nil))) + (unless (or (region-intersects-region-p visible-region record) + (and old-children + (region-intersects-region-p visible-region old-children))) + (return-from compute-difference-set (values nil nil nil nil nil))) + ;; I don't feel like adding another let and indenting this huge function + ;; some more.... + (setq existing-output-records (make-hash-table :test #'eq)) ;; XXX This means that compute-difference-set can't be called repeatedly on ;; the same tree; ugh. On the other hand, if we don't clear explicit-moves, ;; they can hang around in the tree for later passes and cause trouble.

1 0

[mcclim-cvs] CVS update: mcclim/regions.lisp
by crhodes＠common-lisp.net 11 Feb '05

11 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv6076 Modified Files: regions.lisp Log Message: Fix the declaration of the coordinate array Date: Fri Feb 11 11:05:57 2005 Author: crhodes Index: mcclim/regions.lisp diff -u mcclim/regions.lisp:1.29 mcclim/regions.lisp:1.30 --- mcclim/regions.lisp:1.29 Fri Feb 11 10:10:37 2005 +++ mcclim/regions.lisp Fri Feb 11 11:05:57 2005 @@ -4,7 +4,7 @@ ;;; Created: 1998-12-02 19:26 ;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> ;;; License: LGPL (See file COPYING for details). -;;; $Id: regions.lisp,v 1.29 2005/02/11 09:10:37 tmoore Exp $ +;;; $Id: regions.lisp,v 1.30 2005/02/11 10:05:57 crhodes Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2001 by Gilbert Baumann ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet(a)emi.u-bordeaux.fr) @@ -380,7 +380,7 @@ (defmacro with-standard-rectangle ((x1 y1 x2 y2) rectangle &body body) (with-gensyms (coords) `(let ((,coords (slot-value ,rectangle 'coordinates))) - (declare (type (array coordinate 4) ,coords)) + (declare (type (simple-array coordinate (4)) ,coords)) (let ((,x1 (aref ,coords 0)) (,y1 (aref ,coords 1)) (,x2 (aref ,coords 2)) @@ -391,7 +391,7 @@ (defmacro with-standard-rectangle* ((&key x1 y1 x2 y2) rectangle &body body) (with-gensyms (coords) `(let ((,coords (slot-value ,rectangle 'coordinates))) - (declare (type (array coordinate 4) ,coords)) + (declare (type (simple-array coordinate (4)) ,coords)) (let (,@(and x1 `((,x1 (aref ,coords 0)))) ,@(and y1 `((,y1 (aref ,coords 1)))) ,@(and x2 `((,x2 (aref ,coords 2)))) @@ -428,7 +428,7 @@ (defmethod* (setf rectangle-edges*) (x1 y1 x2 y2 (rectangle standard-rectangle)) (let ((coords (slot-value rectangle 'coordinates))) - (declare (type (array coordinate 4) coords)) + (declare (type (simple-array coordinate (4)) coords)) (setf (aref coords 0) x1) (setf (aref coords 1) y1) (setf (aref coords 2) x2)

1 0

[mcclim-cvs] CVS update: mcclim/Goatee/clim-area.lisp
by tmoore＠common-lisp.net 11 Feb '05

11 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Goatee In directory common-lisp.net:/tmp/cvs-serv6008/Goatee Modified Files: clim-area.lisp Log Message: Fixes for rectangle changes that didn't make it before Date: Fri Feb 11 11:03:07 2005 Author: tmoore Index: mcclim/Goatee/clim-area.lisp diff -u mcclim/Goatee/clim-area.lisp:1.29 mcclim/Goatee/clim-area.lisp:1.30 --- mcclim/Goatee/clim-area.lisp:1.29 Fri Feb 11 10:10:38 2005 +++ mcclim/Goatee/clim-area.lisp Fri Feb 11 11:03:07 2005 @@ -208,11 +208,11 @@ (unless (slot-boundp obj 'width) (setf (width obj) (line-text-width (editable-area obj) obj))) (unless (slot-boundp obj 'baseline) - (multiple-value-bind (x y) - (output-record-position obj) - (declare (ignore x)) - (setf (slot-value obj 'climi::y2) (+ y (ascent obj) (descent obj))) - (setf (baseline obj) (+ y (ascent obj)))))) + (climi::with-standard-rectangle* (:x1 x1 :y1 y1 :x2 x2) + obj + (setf (rectangle-edges* obj) + (values x1 y1 x2 (+ y1 (ascent obj) (descent obj)))) + (setf (baseline obj) (+ y1 (ascent obj)))))) (defmethod climi::map-over-output-records-1 (function (record screen-line) function-args)

1 0