mcclim-cvs January 2008

mcclim-cvs@common-lisp.net

7 participants
255 discussions

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 21 Jan '08

21 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv14980/Drei Modified Files: drei-redisplay.lisp Log Message: Be careful to draw only inside the strokes when highlighting them. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/20 19:50:20 1.46 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/21 20:23:40 1.47 @@ -576,7 +576,7 @@ (funcall (drawing-options-function (stroke-drawing-options stroke)) pane view stroke cursor-x cursor-y #'stroke-drawing-fn t) (when *highlight-strokes* - (draw-rectangle* pane x1 y1 x2 (1- y2) :filled nil :ink *stroke-boundary-ink*) + (draw-rectangle* pane x1 y1 (1- x2) (1- y2) :filled nil :ink *stroke-boundary-ink*) (draw-line* pane x1 (+ y1 center) x2 (+ y1 center) :ink *stroke-baseline-ink*))))) (defun end-line (line x1 y1 line-width line-height)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 21 Jan '08

21 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv18432/Drei Modified Files: core-commands.lisp drei.lisp packages.lisp views.lisp Log Message: Added new command table, `view-table', that contains generic commands used for all views. Currently this is limited to page-up/page-down commands, and it's not likely it will ever get anything but very high-level movement/scrolling commands (I want to add generic end-of-view/beginning-of-view commands too), because we can make so few assumptions about views. --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2008/01/20 19:50:20 1.14 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2008/01/21 17:08:28 1.15 @@ -295,26 +295,26 @@ 'movement-table '((:home :control))) -(define-command (com-page-down :name t :command-table movement-table) () +(define-command (com-page-down :name t :command-table view-table) () (page-down (editor-pane (drei-instance)) (current-view))) (set-key 'com-page-down - 'movement-table + 'view-table '((#\v :control))) (set-key 'com-page-down - 'movement-table + 'view-table '((:next))) -(define-command (com-page-up :name t :command-table movement-table) () +(define-command (com-page-up :name t :command-table view-table) () (page-up (editor-pane (drei-instance)) (current-view))) (set-key 'com-page-up - 'movement-table + 'view-table '((#\v :meta))) (set-key 'com-page-up - 'movement-table + 'view-table '((:prior))) (define-command (com-end-of-buffer :name t :command-table movement-table) () --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/19 10:24:19 1.29 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/21 17:08:28 1.30 @@ -162,6 +162,8 @@ (make-command-table 'info-table :errorp nil) ;;; Self-insertion. (make-command-table 'self-insert-table :errorp nil) +;;; View stuff (scrolling, etc) +(make-command-table 'view-table :errorp nil) ;;; Command table for concrete editor stuff. (define-syntax-command-table editor-table --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/20 19:50:20 1.44 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/21 17:08:28 1.45 @@ -244,6 +244,7 @@ #:comment-table #:deletion-table #:editing-table #:fill-table #:indent-table #:marking-table #:case-table #:movement-table #:search-table #:info-table #:self-insert-table + #:view-table #:editor-table #:exclusive-gadget-table #:exclusive-input-editor-table #:minibuffer --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/20 19:50:20 1.24 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/21 17:08:28 1.25 @@ -472,7 +472,7 @@ commands relevant for `view'.") (:method-combination append) (:method append ((view drei-view)) - '())) + '(view-table))) (defgeneric create-view-cursors (output-stream view) (:documentation "Create cursors for `view' that are to be

1 0

[mcclim-cvs] CVS mcclim
by ahefner 21 Jan '08

21 Jan '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25741 Modified Files: regions.lisp Log Message: Missed one. --- /project/mcclim/cvsroot/mcclim/regions.lisp 2008/01/15 15:45:17 1.36 +++ /project/mcclim/cvsroot/mcclim/regions.lisp 2008/01/21 01:34:13 1.37 @@ -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.36 2008/01/15 15:45:17 crhodes Exp $ +;;; $Id: regions.lisp,v 1.37 2008/01/21 01:34:13 ahefner Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2001 by Gilbert Baumann ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet(a)emi.u-bordeaux.fr) @@ -2213,7 +2213,8 @@ (not (region-equal +nowhere+ (region-intersection a b)))) (defmethod region-contains-region-p ((a region) (b region)) - (region-equal +nowhere+ (region-difference b a))) + (or (eq a b) + (region-equal +nowhere+ (region-difference b a)))) ;;;; ====================================================================================================

1 0

[mcclim-cvs] CVS mcclim/Experimental/freetype
by ahefner 21 Jan '08

21 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv24542/Experimental/freetype Modified Files: freetype-fonts.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/Experimental/freetype/freetype-fonts.lisp 2008/01/17 09:54:21 1.20 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/21 01:26:43 1.21 @@ -117,7 +117,7 @@ (let ((glyph-set (or (getf (xlib:display-plist display) 'the-glyph-set) (setf (getf (xlib:display-plist display) 'the-glyph-set) (xlib::render-create-glyph-set - (first (xlib::find-matching-picture-formats display + (first (xlib::find-matching-picture-formats display :alpha 8 :red 0 :green 0 :blue 0))))))) (setf lookaside (cons display glyph-set)) glyph-set)))) @@ -289,54 +289,86 @@ (xlib:drawable-root drawable)))))) (defun gcontext-picture (drawable gcontext) - (or (getf (xlib:gcontext-plist gcontext) 'picture) - (setf (getf (xlib:gcontext-plist gcontext) 'picture) - (let ((pixmap (xlib:create-pixmap :drawable drawable - :depth (xlib:drawable-depth drawable) - :width 1 :height 1))) - (list - (xlib::render-create-picture - pixmap - :format (xlib::find-window-picture-format (xlib:drawable-root drawable)) - :repeat :on) - pixmap))))) + (flet ((update-foreground (picture) + ;; FIXME! This makes assumptions about pixel format, and breaks + ;; on 16 bpp displays. + (let ((fg (the xlib:card32 (xlib:gcontext-foreground gcontext)))) + (xlib::render-fill-rectangle picture + :src + (list (ash (ldb (byte 8 16) fg) 8) + (ash (ldb (byte 8 8) fg) 8) + (ash (ldb (byte 8 0) fg) 8) + #xFFFF) + 0 0 1 1)))) + (let* ((fg (xlib:gcontext-foreground gcontext)) + (picture-info + (or (getf (xlib:gcontext-plist gcontext) 'picture) + (setf (getf (xlib:gcontext-plist gcontext) 'picture) + (let* ((pixmap (xlib:create-pixmap + :drawable drawable + :depth (xlib:drawable-depth drawable) + :width 1 :height 1)) + (picture (xlib::render-create-picture + pixmap + :format (xlib::find-window-picture-format + (xlib:drawable-root drawable)) + :repeat :on))) + (update-foreground picture) + (list fg + picture + pixmap)))))) + (unless (eql fg (first picture-info)) + (update-foreground (second picture-info)) + (setf (first picture-info) fg)) + (cdr picture-info)))) -(let ((buffer (make-array 1024 :element-type '(unsigned-byte 32) ; TODO: thread safety + +;;; Arbitrary restriction: No more than 65536 glyphs cached from +;;; a single font. I don't think that's unreasonable. + +(let ((buffer (make-array 1024 :element-type '(unsigned-byte 16) ; TODO: thread safety :adjustable nil :fill-pointer nil))) - (defmethod clim-clx::font-draw-glyphs ((font freetype-face) mirror gc x y string &key start end translate) - (declare (optimize (speed 3))) + (defun clim-clx::font-draw-glyphs (font #|(font freetype-face)|# mirror gc x y string + #|x0 y0 x1 y1|# &key start end translate) + (declare (optimize (speed 3)) + (type #-sbcl (integer 0 #.array-dimension-limit) + #+sbcl sb-int:index + start end) + (type string string)) (when (< (length buffer) (- end start)) (setf buffer (make-array (* 256 (ceiling (- end start) 256)) - :element-type '(unsigned-byte 32) + :element-type '(unsigned-byte 16) :adjustable nil :fill-pointer nil))) (let ((display (xlib:drawable-display mirror))) (destructuring-bind (source-picture source-pixmap) (gcontext-picture mirror gc) - (let* ((fg (xlib:gcontext-foreground gc)) - (cache (slot-value font 'glyph-id-cache)) + (let* ((cache (slot-value font 'glyph-id-cache)) (glyph-ids buffer)) + (loop for i from start below end ; TODO: Read optimization notes. Fix. Repeat. for i* upfrom 0 as char = (aref string i) as code = (char-code char) do (setf (aref buffer i*) - (or (gcache-get cache code) - (gcache-set cache code (font-glyph-id font char))))) + (the (unsigned-byte 16) + (or (gcache-get cache code) + (gcache-set cache code (font-glyph-id font char)))))) + + ;; Debugging - show the text rectangle + ;(setf (xlib:gcontext-foreground gc) #xFF0000) + ;(xlib:draw-rectangle mirror gc x0 y0 (- x1 x0) (- y1 y0)) + + ;; Sync the picture-clip-mask with that of the gcontext. + (unless (eq (xlib::picture-clip-mask (drawable-picture mirror)) + (xlib::gcontext-clip-mask gc)) + (setf (xlib::picture-clip-mask (drawable-picture mirror)) + (xlib::gcontext-clip-mask gc))) - (xlib::render-fill-rectangle source-picture - :src - (list (ash (ldb (byte 8 16) fg) 8) - (ash (ldb (byte 8 8) fg) 8) - (ash (ldb (byte 8 0) fg) 8) - #xFFFF) - 0 0 1 1) - (setf (xlib::picture-clip-mask (drawable-picture mirror)) - (xlib::gcontext-clip-mask gc)) (xlib::render-composite-glyphs (drawable-picture mirror) (display-the-glyph-set display) source-picture - x y + x y glyph-ids :end (- end start))))))) @@ -533,15 +565,34 @@ (text-style-character-width text-style medium #\m)) (defmethod text-size ((medium clx-medium) string &key text-style (start 0) end) + (declare (optimize (speed 3))) (when (characterp string) (setf string (make-string 1 :initial-element string))) + (check-type string string) (unless end (setf end (length string))) + (check-type start + #-sbcl (integer 0 #.array-dimension-limit) + #+sbcl sb-int:index) + (check-type end + #-sbcl (integer 0 #.array-dimension-limit) + #+sbcl sb-int:index) (unless text-style (setf text-style (medium-text-style medium))) (let ((xfont (text-style-to-X-font (port medium) text-style))) (cond ((= start end) (values 0 0 0 0 0)) (t - (let ((position-newline (position #\newline string :start start))) + (let ((position-newline + (macrolet ((p (type) + `(locally + (declare (type ,type string)) + (position #\newline string :start start)))) + (typecase string + (simple-base-string (p simple-base-string)) + #+SBCL (sb-kernel::simple-character-string (p sb-kernel::simple-character-string)) + #+SBCL (sb-kernel::character-string (p sb-kernel::character-string)) + (simple-string (p simple-string)) + (string (p string)))))) + (cond ((not (null position-newline)) (multiple-value-bind (width ascent descent left right font-ascent font-descent direction @@ -626,17 +677,18 @@ start end align-x align-y toward-x toward-y transform-glyphs) - (declare (ignore toward-x toward-y transform-glyphs)) + (declare (ignore toward-x toward-y transform-glyphs)) (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) x y) (with-clx-graphics (medium) (when (characterp string) (setq string (make-string 1 :initial-element string))) (when (null end) (setq end (length string))) - (multiple-value-bind (text-width text-height x-cursor y-cursor baseline) + (multiple-value-bind (text-width text-height x-cursor y-cursor baseline) (text-size medium string :start start :end end) (declare (ignore x-cursor y-cursor)) - (unless (and (eq align-x :left) (eq align-y :baseline)) + + (unless (and (eq align-x :left) (eq align-y :baseline)) (setq x (- x (ecase align-x (:left 0) (:center (round text-width 2)) @@ -645,17 +697,18 @@ (:top (+ y baseline)) (:center (+ y baseline (- (floor text-height 2)))) (:baseline y) - (:bottom (+ y baseline (- text-height))))))) - (let ((x (round-coordinate x)) - (y (round-coordinate y))) - (when (and (<= #x-8000 x #x7FFF) - (<= #x-8000 y #x7FFF)) - (multiple-value-bind (halt width) - (font-draw-glyphs - (text-style-to-X-font (port medium) (medium-text-style medium)) - mirror gc x y string - :start start :end end - :translate #'translate))))))) + (:bottom (+ y baseline (- text-height)))))) + + (let ((x (round-coordinate x)) + (y (round-coordinate y))) + (when (and (<= #x-8000 x #x7FFF) + (<= #x-8000 y #x7FFF)) + (font-draw-glyphs + (text-style-to-X-font (port medium) (medium-text-style medium)) + mirror gc x y string + #| x (- y baseline) (+ x text-width) (+ y (- text-height baseline )) |# + :start start :end end + :translate #'translate))))))) (defmethod (setf medium-text-style) :before (text-style (medium clx-medium)) @@ -679,5 +732,9 @@ (clim:region-intersection r (clim:sheet-region s))))) (unless (eql r clim:+nowhere+) (clim:with-drawing-options (m :clipping-region r) - (clim:draw-design m r :ink clim:+background-ink+) - (call-next-method s r))))) + ; This causes the logic cube to flicker. Is it critical? + ;(clim:draw-design m r :ink clim:+background-ink+) + (call-next-method s r) + ;; FIXME: Shouldn't McCLIM always do this? + (medium-force-output (sheet-medium s)))))) +

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by ahefner 21 Jan '08

21 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv24542/Backends/CLX Modified Files: medium.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/Backends/CLX/medium.lisp 2008/01/17 07:23:48 1.85 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/21 01:26:43 1.86 @@ -37,6 +37,7 @@ (defclass clx-medium (basic-medium) ((gc :initform nil) (picture :initform nil) + (clipping-region-dirty :initform t) (clipping-region-tmp :initform (vector 0 0 0 0) :documentation "This object is reused to avoid consing in the most common case when configuring the clipping region.") @@ -108,7 +109,7 @@ (let ((clipping-region (medium-device-region medium)) (tmp (slot-value medium 'clipping-region-tmp)) (port (port medium))) - (cond + (cond ((region-equal clipping-region +nowhere+) (setf (xlib:gcontext-clip-mask gc) #())) ((typep clipping-region 'standard-rectangle) @@ -135,8 +136,9 @@ (defmethod (setf medium-clipping-region) :after (region (medium clx-medium)) (declare (ignore region)) - (with-slots (gc) medium - (when gc (%set-gc-clipping-region medium gc)))) + (with-slots (#|gc|# clipping-region-dirty) medium + (setf clipping-region-dirty t) + #+NIL (when gc (%set-gc-clipping-region medium gc)))) (defgeneric medium-gcontext (medium ink)) @@ -155,7 +157,7 @@ (let* ((port (port medium)) (mirror (port-lookup-mirror port (medium-sheet medium))) (line-style (medium-line-style medium))) - (with-slots (gc) medium + (with-slots (gc clipping-region-dirty) medium (unless gc (setq gc (xlib:create-gcontext :drawable mirror)) ;; this is kind of false, since the :unit should be taken @@ -175,7 +177,9 @@ (let ((fn (text-style-to-X-font port (medium-text-style medium)))) (when (typep fn 'xlib:font) (setf (xlib:gcontext-font gc) fn))) - (%set-gc-clipping-region medium gc) + (when clipping-region-dirty + (%set-gc-clipping-region medium gc) + (setf clipping-region-dirty nil)) gc))) (defmethod medium-gcontext ((medium clx-medium) (ink (eql +transparent-ink+))) @@ -620,7 +624,7 @@ (ink (medium-ink ,medium)) (gc (medium-gcontext ,medium ink))) line-style ink - (unwind-protect + (unwind-protect (unless (eql ink +transparent-ink+) (progn ,@body)) #+ignore(xlib:free-gcontext gc))))))

1 0

[mcclim-cvs] CVS mcclim
by ahefner 21 Jan '08

21 Jan '08

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)))

1 0

[mcclim-cvs] CVS mcclim/Examples
by ahefner 21 Jan '08

21 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv21600 Modified Files: misc-tests.lisp Log Message: Goofy line width transformation test, functions to print tests using the Postscript backend. --- /project/mcclim/cvsroot/mcclim/Examples/misc-tests.lisp 2007/07/19 06:58:30 1.3 +++ /project/mcclim/cvsroot/mcclim/Examples/misc-tests.lisp 2008/01/21 01:10:07 1.4 @@ -70,6 +70,24 @@ (clim-extensions:lowering () (scrolling (:scroll-bar :vertical :height 200) description))))))))) +(defun misc-test-postscript (test &optional filename) + (let* ((test (if (stringp test) (gethash test *misc-tests*) test)) + (test-name (misc-test-name test)) + (filename (or filename (format nil "/tmp/~A.eps" + test-name)))) + (with-open-file (out filename :direction :output :if-exists :supersede) + (with-output-to-postscript-stream (stream out :device-type :eps) + #+NIL + (with-text-style (stream (make-text-style :sans-serif :roman :normal)) + (format stream "~&~A: ~A~%" test-name (misc-test-description test))) + (funcall (misc-test-drawer test) stream))))) + +(defun run-all-postscript-tests () + (loop for test being the hash-values of *misc-tests* do + (restart-case (misc-test-postscript test) + (:skip () + :report (lambda (stream) (format stream "Skip ~A" (misc-test-name test))))))) + (define-misc-test "Empty Records 1" (stream) "Tests the effect of empty output records on their parent's bounding rectangle. If successful, you will see a circle enclosed in a square. The square should tightly fit the circle. If the rectangle extends all the way to the top/left edges of the pane, McCLIM is not handling this correctly. This specifically exercises addition of empty children in recompute-extent-for-new-child." (surrounding-output-with-border (stream :shape :rectangle) @@ -134,7 +152,7 @@ (format stream "~&We all live in a yellow subroutine.~%"))) (define-misc-test "Transparent Ink Test" (stream) - "Drawing with transparent ink can be useful as a way of reserving space as padding around the visible part of a drawing. This test checks that the medium supports drawing in transparent ink, and that it is recorded with the expected bounding rectangle. It will draw two tables, which should format identically except for one square, which will be transparent in the first table and blue in the second. If the in absence of the blue square its row and column collapse to a small size, the bounding rectangle for the transparent squares is probably wrong. Light gray circles will be drawn in the backgroud, and should show through the empty row/column of the table." + "Drawing with transparent ink can be useful as a way of reserving space as padding around the visible part of a drawing. This test checks that the medium supports drawing in transparent ink, and that it is recorded with the expected bounding rectangle. It will draw two tables, which should format identically except for one square, which will be transparent in the first table and blue in the second. If the in absence of the blue square its row and column collapse to a small size, the bounding rectangle for the transparent squares is probably wrong. Light gray circles will be drawn in the background, and should show through the empty row/column of the table." (let ((table '((1 1 1 0 1) (1 1 1 0 1) (1 1 1 0 1) @@ -219,4 +237,25 @@ (if (listp obj) (rest obj) nil)) :stream stream))) +(define-misc-test "Line Widths" (stream) + "Hi there." + (formatting-table (stream) + (loop for scale-expt from 0 upto 2 + as scale = (expt 2 scale-expt) do + (with-scaling (stream scale) + (formatting-row (stream) + (loop for thickness from 1 upto 25 by 5 + with width = 40 + with width/2 = (/ width 2) do + (formatting-cell (stream) + (draw-rectangle* stream 0 (- width/2) width width/2 :line-thickness thickness :filled nil :ink +red+ :line-unit :coordinate) + (draw-circle* stream width/2 0 width/2 :line-thickness thickness :filled nil :ink +blue+ :line-unit :coordinate) + (draw-line* stream 0 0 width 0 + :line-thickness thickness + :line-cap-shape :round + :line-unit :coordinate) + #+NIL + (draw-rectangle* stream 0 (- width/2) width width/2 :filled nil :ink +white+)))))))) + +

1 0

[mcclim-cvs] CVS mcclim/Examples
by ahefner 21 Jan '08

21 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv21511 Modified Files: font-selector.lisp Log Message: Default to the current port. --- /project/mcclim/cvsroot/mcclim/Examples/font-selector.lisp 2006/12/24 14:27:48 1.1 +++ /project/mcclim/cvsroot/mcclim/Examples/font-selector.lisp 2008/01/21 01:08:58 1.2 @@ -38,6 +38,7 @@ (define-application-frame font-selector () ((font-selector-port :initarg :font-selector-port + :initform (find-port) :accessor font-selector-port) (font-selector-text-style :accessor font-selector-text-style)) (:menu-bar nil)

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by ahefner 21 Jan '08

21 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv21406 Modified Files: port.lisp Log Message: Patch from Nikodemus Siivola fixing warnings. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/01/17 07:11:15 1.132 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/01/21 01:07:49 1.133 @@ -111,6 +111,8 @@ :initarg :ascent :reader fontset-width))) +(defvar *fontset* nil) + (defmethod print-object ((object fontset) stream) (format stream "#<fontset ~A>" (fontset-name object))) @@ -681,6 +683,8 @@ ;; pointer-event-buttons slot to pointer events. -- moore ;; +(defvar *clx-port*) + (defun event-handler (&key display window event-key code state mode time type width height x y root-x root-y data override-redirect-p send-event-p hint-p @@ -688,7 +692,6 @@ request first-keycode count &allow-other-keys) (declare (ignore display request first-keycode count)) - (declare (special *clx-port*)) (let ((sheet (and window (port-lookup-sheet *clx-port* window)))) (when sheet (case event-key @@ -878,7 +881,6 @@ (declare (ignore wait-function)) (let* ((*clx-port* port) (display (clx-port-display port))) - (declare (special *clx-port*)) (unless (xlib:event-listen display) (xlib:display-finish-output (clx-port-display port))) ; temporary solution @@ -959,8 +961,6 @@ (xlib:open-font display (first fonts)) (xlib:open-font display "fixed")))) -(defvar *fontset* nil) - (defmethod text-style-mapping ((port clx-port) text-style &optional character-set) (declare (ignore character-set))

1 0

[mcclim-cvs] CVS mcclim/ESA
by thenriksen 20 Jan '08

20 Jan '08

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv12206/ESA Modified Files: esa.lisp packages.lisp Log Message: Improved support for nonbuffer views, including various bugfixes here and there, used that support to revamp Climacs' typeout panes, which in turn required some ESA changes. Stability not guaranteed, please test. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/01/14 20:50:11 1.14 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/01/20 19:50:21 1.15 @@ -1048,15 +1048,29 @@ ;;; ;;; Help -(defgeneric help-stream (frame title)) - -(defmethod help-stream (frame title) - (open-window-stream - :label title - :input-buffer (#+(or mcclim building-mcclim) climi::frame-event-queue - #-(or mcclim building-mcclim) silica:frame-input-buffer - *application-frame*) - :width 400)) +(defgeneric invoke-with-help-stream (esa title continuation) + (:documentation "Invoke `continuation' with a single argument - +a stream for writing on-line help for `esa' onto. The stream +should have the title, or name, `title' (a string), but the +specific meaning of this is left to the respective ESA.")) + +(defmethod invoke-with-help-stream (frame title continuation) + (funcall continuation + (open-window-stream + :label title + :input-buffer (#+(or mcclim building-mcclim) climi::frame-event-queue + #-(or mcclim building-mcclim) silica:frame-input-buffer + *application-frame*) + :width 400))) + +(defmacro with-help-stream ((stream title) &body body) + "Evaluate `body' with `stream' bound to a stream suitable for +writing help information on. `Title' must evaluate to a string, +and will be used for naming the resulting stream, if that makes +sense for the ESA." + `(invoke-with-help-stream *esa-instance* ,title + #'(lambda (,stream) + ,@body))) (defun read-gestures-for-help (command-table) (with-input-focus (t) @@ -1389,12 +1403,12 @@ ((sort-by-keystrokes 'boolean :prompt "Sort by keystrokes?")) "Show which keys invoke which commands. Without a numeric prefix, sorts the list by command name. With a numeric prefix, sorts by key." - (let ((stream (help-stream *application-frame* (format nil "Help: Describe Bindings"))) - (command-table (find-applicable-command-table *application-frame*))) - (describe-bindings stream command-table - (if sort-by-keystrokes - #'sort-by-keystrokes - #'sort-by-name)))) + (let ((command-table (find-applicable-command-table *application-frame*))) + (with-help-stream (stream (format nil "Help: Describe Bindings")) + (describe-bindings stream command-table + (if sort-by-keystrokes + #'sort-by-keystrokes + #'sort-by-name))))) (set-key `(com-describe-bindings ,*numeric-argument-marker*) 'help-table '((#\h :control) (#\b))) @@ -1412,12 +1426,10 @@ (let ((gesture-name (format nil "~{~A~#[~; ~; ~]~}" (mapcar #'gesture-name gestures)))) (if command - (let ((out-stream - (help-stream *application-frame* - (format nil "~10THelp: Describe Key for ~A" gesture-name)))) + (with-help-stream (out-stream (format nil "~10THelp: Describe Key for ~A" gesture-name)) (describe-command-binding-to-stream gesture-name command - :command-table command-table - :stream out-stream)) + :command-table command-table + :stream out-stream)) (display-message "Unbound gesture: ~A" gesture-name)))))) (set-key 'com-describe-key @@ -1427,15 +1439,14 @@ (define-command (com-describe-command :name t :command-table help-table) ((command 'command-name :prompt "Describe command")) "Display documentation for the given command." - (let* ((command-table (find-applicable-command-table *application-frame*)) - (out-stream (help-stream *application-frame* - (format nil "~10THelp: Describe Command for ~A" + (let ((command-table (find-applicable-command-table *application-frame*))) + (with-help-stream (out-stream (format nil "~10THelp: Describe Command for ~A" (command-line-name-for-command command command-table - :errorp nil))))) - (describe-command-to-stream command - :command-table command-table - :stream out-stream))) + :errorp nil))) + (describe-command-to-stream command + :command-table command-table + :stream out-stream)))) (set-key `(com-describe-command ,*unsupplied-argument-marker*) 'help-table @@ -1480,30 +1491,28 @@ collect (cons function keys)))) (if (null results) (display-message "No results for ~{~A~^, ~}" words) - (let ((out-stream (help-stream *application-frame* - (format nil "~10THelp: Apropos ~{~A~^, ~}" - words)))) - (loop for (command . keys) in results - for documentation = (or (documentation command 'function) - "Not documented.") - do (with-text-style (out-stream '(:sans-serif :bold nil)) - (present command - `(command-name :command-table ,command-table) - :stream out-stream)) - (with-drawing-options (out-stream :ink +dark-blue+ - :text-style '(:fix nil nil)) - (format out-stream "~30T~:[M-x ... RETURN~;~:*~{~A~^, ~}~]" - (mapcar (lambda (keystrokes) - (format nil "~{~A~^ ~}" - (mapcar #'gesture-name (reverse keystrokes)))) - (car keys)))) - (with-text-style (out-stream '(:sans-serif nil nil)) - (format out-stream "~&~2T~A~%" - (subseq documentation 0 (position #\Newline documentation)))) - count command into length - finally (change-space-requirements out-stream - :height (* length (stream-line-height out-stream))) - (scroll-extent out-stream 0 0))))))) + (with-help-stream (out-stream (format nil "~10THelp: Apropos ~{~A~^, ~}" words)) + (loop for (command . keys) in results + for documentation = (or (documentation command 'function) + "Not documented.") + do (with-text-style (out-stream '(:sans-serif :bold nil)) + (present command + `(command-name :command-table ,command-table) + :stream out-stream)) + (with-drawing-options (out-stream :ink +dark-blue+ + :text-style '(:fix nil nil)) + (format out-stream "~30T~:[M-x ... RETURN~;~:*~{~A~^, ~}~]" + (mapcar (lambda (keystrokes) + (format nil "~{~A~^ ~}" + (mapcar #'gesture-name (reverse keystrokes)))) + (car keys)))) + (with-text-style (out-stream '(:sans-serif nil nil)) + (format out-stream "~&~2T~A~%" + (subseq documentation 0 (position #\Newline documentation)))) + count command into length + finally (change-space-requirements out-stream + :height (* length (stream-line-height out-stream))) + (scroll-extent out-stream 0 0))))))) (set-key `(com-apropos-command ,*unsupplied-argument-marker*) 'help-table --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/13 22:22:06 1.12 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/20 19:50:21 1.13 @@ -82,7 +82,7 @@ #:convert-to-gesture #:gesture-name #:global-esa-table #:keyboard-macro-table #:help-table - #:help-stream + #:invoke-with-help-stream #:with-help-stream #:set-key #:find-applicable-command-table #:esa-command-parser

1 0

← Newer
1
...
6
7
8
9
10
11
12
...
26
Older →

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 January 2008