[mcclim-cvs] CVS mcclim
ahefner
ahefner at common-lisp.net
Mon Jan 21 01:26:42 UTC 2008
Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv24542
Modified Files:
graphics.lisp medium.lisp recording.lisp sheets.lisp
Log Message:
Drawing optimizations, with a focus on eliminating clipping rectangle
changes and transformation cache invalidations (the latter generally
caused by the former). Shortcuts for special cases in d-g-w-o-internal,
merge-text-styles, regions. Further mcclim-freetype optimization -
minimize modification of picture-clip-rectangle and painting of the
foreground tile (this used to happen for every single draw-text call).
One or two optimizations in output record playback.
The mcclim-freetype changes require a fix to CLX, available in
Christophe's CLX in darcs, or from here:
http://vintage-digital.com/hefner/mcclim/xrender-clip-state.diff
--- /project/mcclim/cvsroot/mcclim/graphics.lisp 2008/01/09 16:57:54 1.59
+++ /project/mcclim/cvsroot/mcclim/graphics.lisp 2008/01/21 01:26:42 1.60
@@ -89,26 +89,29 @@
(changed-line-style line-style-p)
(changed-text-style text-style-p))
(unwind-protect
- (progn
+ (progn
(when (eq ink old-ink) (setf ink nil))
- (if ink
+ (when ink
(setf (medium-ink medium) ink))
- (if transformation
+ (when transformation
(setf (medium-transformation medium)
(compose-transformations old-transform transformation)))
(when (and clipping-region old-clip
- (region-equal clipping-region old-clip))
- (setf clipping-region nil))
-
- (if clipping-region
- (setf (medium-clipping-region medium)
- (region-intersection (if transformation
- (transform-region transformation old-clip)
- old-clip)
- clipping-region)))
- (if (null line-style)
+ (or (eq clipping-region +everywhere+)
+ (eq clipping-region old-clip)
+ (region-contains-region-p clipping-region old-clip))
+ #+NIL (region-equal clipping-region old-clip))
+ (setf clipping-region nil))
+
+ (when clipping-region
+ (setf (medium-clipping-region medium)
+ (region-intersection (if transformation
+ (transform-region transformation old-clip)
+ old-clip)
+ clipping-region)))
+ (when (null line-style)
(setf line-style old-line-style))
(when (or line-unit line-thickness dashes-p line-joint-shape line-cap-shape)
(setf changed-line-style t)
@@ -128,7 +131,7 @@
(if text-style-p
(setf text-style (merge-text-styles text-style
(medium-merged-text-style medium)))
- (setf text-style (medium-merged-text-style medium)))
+ (setf text-style (medium-merged-text-style medium)))
(when (or text-family-p text-face-p text-size-p)
(setf changed-text-style t)
(setf text-style (merge-text-styles (make-text-style text-family
--- /project/mcclim/cvsroot/mcclim/medium.lisp 2007/03/20 01:41:17 1.63
+++ /project/mcclim/cvsroot/mcclim/medium.lisp 2008/01/21 01:26:42 1.64
@@ -199,7 +199,8 @@
(defun device-font-text-style-p (s)
(typep s 'device-font-text-style))
-(defmethod text-style-equalp ((style1 device-font-text-style) (style2 device-font-text-style))
+(defmethod text-style-equalp ((style1 device-font-text-style)
+ (style2 device-font-text-style))
(eq style1 style2))
(defmethod text-style-mapping ((port basic-port) text-style
@@ -236,6 +237,10 @@
;;; Text-style utilities
(defmethod merge-text-styles (s1 s2)
+ (when (and (typep s1 'text-style)
+ (typep s2 'text-style)
+ (eq s1 s2))
+ (return-from merge-text-styles s1))
(setq s1 (parse-text-style s1))
(setq s2 (parse-text-style s2))
(if (and (not (device-font-text-style-p s1))
@@ -398,7 +403,7 @@
(defmethod (setf medium-clipping-region) :after (region (medium medium))
(declare (ignore region))
- (let ((sheet (medium-sheet medium)))
+ (let ((sheet (medium-sheet medium)))
(when sheet
(invalidate-cached-regions sheet))))
--- /project/mcclim/cvsroot/mcclim/recording.lisp 2007/09/07 16:49:11 1.135
+++ /project/mcclim/cvsroot/mcclim/recording.lisp 2008/01/21 01:26:42 1.136
@@ -518,6 +518,7 @@
;; since an enqueued repaint does not occur immediately, and highlight
;; rectangles are not recorded, newer highlighting gets wiped out
;; shortly after being drawn. So, we aren't ready for this yet.
+ ;; ..Actually, it isn't necessarily faster. Depends on the app.
#+NIL
(queue-repaint stream (make-instance 'window-repaint-event
:sheet stream
@@ -1030,15 +1031,21 @@
(apply function (tree-output-record-entry-record child) function-args)))
(defmethod map-over-output-records-1 (function (record standard-tree-output-record) function-args)
- (map-over-tree-output-records function record (%record-to-spatial-tree-rectangle record) :most-recent-last
+ (map-over-tree-output-records function record
+ (%record-to-spatial-tree-rectangle record) :most-recent-last
function-args))
-(defmethod map-over-output-records-containing-position (function (record standard-tree-output-record) x y &optional x-offset y-offset &rest function-args)
+(defmethod map-over-output-records-containing-position
+ (function (record standard-tree-output-record) x y
+ &optional x-offset y-offset &rest function-args)
(declare (ignore x-offset y-offset))
- (map-over-tree-output-records function record (rectangles:make-rectangle :lows `(,x ,y) :highs `(,x ,y)) :most-recent-first
+ (map-over-tree-output-records function record
+ (rectangles:make-rectangle :lows `(,x ,y) :highs `(,x ,y)) :most-recent-first
function-args))
-(defmethod map-over-output-records-overlapping-region (function (record standard-tree-output-record) region &optional x-offset y-offset &rest function-args)
+(defmethod map-over-output-records-overlapping-region
+ (function (record standard-tree-output-record) region
+ &optional x-offset y-offset &rest function-args)
(declare (ignore x-offset y-offset))
(typecase region
(everywhere-region (map-over-output-records-1 function record function-args))
@@ -1122,8 +1129,12 @@
(defmethod replay-output-record :around
((record gs-clip-mixin) stream &optional region x-offset y-offset)
(declare (ignore region x-offset y-offset))
- (with-drawing-options (stream :clipping-region (graphics-state-clip record))
- (call-next-method)))
+ (let ((clipping-region (graphics-state-clip record)))
+ (if (or (eq clipping-region +everywhere+) ; !!!
+ (region-contains-region-p clipping-region (medium-clipping-region stream)))
+ (call-next-method)
+ (with-drawing-options (stream :clipping-region (graphics-state-clip record))
+ (call-next-method)))))
(defrecord-predicate gs-clip-mixin ((:clipping-region clip))
(if-supplied (clip)
@@ -1719,7 +1730,7 @@
(:bottom (incf top (- point-y descent))
(incf bottom (- point-y descent)))
(:center (incf top (+ point-y (ceiling (- ascent descent) 2)))
- (incf bottom (+ point-y (ceiling (- ascent descent) 2)))))
+ (incf bottom (+ point-xy (ceiling (- ascent descent) 2)))))
(values left top right bottom))))
(defmethod* (setf output-record-position) :around
@@ -1875,6 +1886,11 @@
;; the styled strings here not simply be output
;; records? Then we could just replay them and all
;; would be well. -- CSR, 20060528.
+ ;; But then we'd have to implement the output record
+ ;; protocols for them. Are we allowed no internal
+ ;; structure of our own? -- Hefner, 20080118
+
+ ;; Some optimization might be possible here.
(with-drawing-options (stream
:ink (graphics-state-ink substring)
:clipping-region (graphics-state-clip substring)
@@ -2131,6 +2147,7 @@
line
string-width
&optional (start 0) end)
+
(when (and (stream-recording-p stream)
(slot-value stream 'local-record-p))
(let* ((medium (sheet-medium stream))
@@ -2150,9 +2167,10 @@
:text-style text-style))
height
ascent))))
+
(when (stream-drawing-p stream)
(without-local-recording stream
- (call-next-method))))
+ (call-next-method))))
#+nil
(defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
--- /project/mcclim/cvsroot/mcclim/sheets.lisp 2007/03/20 01:43:55 1.54
+++ /project/mcclim/cvsroot/mcclim/sheets.lisp 2008/01/21 01:26:42 1.55
@@ -643,8 +643,8 @@
(update-mirror-geometry sheet))
(defmethod sheet-native-region ((sheet mirrored-sheet-mixin))
- (with-slots (native-region) sheet
- (unless native-region
+ (with-slots (native-region) sheet
+ (unless native-region
(let ((this-region (transform-region (sheet-native-transformation sheet)
(sheet-region sheet)))
(parent (sheet-parent sheet)))
More information about the Mcclim-cvs
mailing list