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

[mcclim-cvs] CVS update: mcclim/commands.lisp
by rstrandh＠common-lisp.net 18 Aug '05

18 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv28655 Modified Files: commands.lisp Log Message: Patch from Max-Gerd Retzlaff Date: Thu Aug 18 06:30:11 2005 Author: rstrandh Index: mcclim/commands.lisp diff -u mcclim/commands.lisp:1.53 mcclim/commands.lisp:1.54 --- mcclim/commands.lisp:1.53 Wed Jun 22 13:41:35 2005 +++ mcclim/commands.lisp Thu Aug 18 06:30:09 2005 @@ -746,30 +746,36 @@ ;; We don't need fresh gensyms of these variables for each accept form. (with-gensyms (value ptype changedp) `(defun ,name (,command-table ,stream ,partial-command) - (destructuring-bind (,command-name ,@original-args) - ,partial-command - (let ((,command-line-name (command-line-name-for-command - ,command-name - ,command-table - :errorp nil)) - ,@(mapcar #'list required-arg-names original-args)) - (accepting-values (,stream) - (format ,stream - "You are being prompted for arguments to ~S~%" - ,command-line-name) - ,@(loop - for var in required-arg-names - for original-var in original-args - for parameter in required-args - append `((multiple-value-bind (,value ,ptype ,changedp) - ,(accept-form-for-argument-partial - stream parameter var original-var) - (declare (ignore ,ptype)) - (terpri ,stream) - (when ,changedp - (setq ,var ,value)))))) - (list ,command-name ,@required-arg-names)))))))) - + (do ((still-missing nil t)) + (nil) + (destructuring-bind (,command-name ,@original-args) + ,partial-command + (let ((,command-line-name (command-line-name-for-command + ,command-name + ,command-table + :errorp nil)) + ,@(mapcar #'list required-arg-names original-args)) + (accepting-values (,stream) + (format ,stream + "You are being prompted for arguments to ~S~%~%" + ,command-line-name) + ,@(loop + for var in required-arg-names + for original-var in original-args + for parameter in required-args + append `((multiple-value-bind (,value ,ptype ,changedp) + ,(accept-form-for-argument-partial + stream parameter var original-var) + (declare (ignore ,ptype)) + (terpri ,stream) + (when ,changedp + (setq ,var ,value))))) + (when still-missing + (format ,stream + "~&Please supply all arguments."))) + (setf ,partial-command (list ,command-name ,@required-arg-names)) + (unless (partial-command-p ,partial-command) + (return ,partial-command)))))))))) ;;; XXX What do to about :acceptably? Probably need to wait for Goatee "buffer ;;; streams" so we can insert an accept-result-extent in the buffer for @@ -1079,7 +1085,6 @@ stream (view textual-view) &key) - (declare (ignore acceptably for-context-type)) (let ((command-line-name (command-line-name-for-command object command-table :errorp nil))) (if command-line-name

1 0

[mcclim-cvs] CVS update: mcclim/Examples/town-example.lisp
by rstrandh＠common-lisp.net 18 Aug '05

18 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv24274 Added Files: town-example.lisp Log Message: Another example of the use of CLIM. (thanks to Max-Gerd Retzlaff) It tries to demonstrate the following topics: custom view classes, different present presentation methods for different views, completion for accept presentation methods, accepting-values dialogues, presentation to command translators, partial commands in menus, automatically generated menus, and keystroke gestures for commands. Date: Thu Aug 18 05:25:31 2005 Author: rstrandh

1 0

[mcclim-cvs] CVS update: mcclim/frames.lisp mcclim/incremental-redisplay.lisp
by rstrandh＠common-lisp.net 18 Aug '05

18 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv24177 Modified Files: frames.lisp incremental-redisplay.lisp Log Message: Initial cleanups to incremental redisplay. Date: Thu Aug 18 05:17:22 2005 Author: rstrandh Index: mcclim/frames.lisp diff -u mcclim/frames.lisp:1.107 mcclim/frames.lisp:1.108 --- mcclim/frames.lisp:1.107 Sun Apr 17 20:46:26 2005 +++ mcclim/frames.lisp Thu Aug 18 05:17:21 2005 @@ -484,25 +484,6 @@ (:disowned (disown-frame fm frame))))))) -;;; Defined in incremental-redisplay.lisp -(defvar *enable-updating-output*) - -#+nil -(defun redisplay-changed-panes (frame) - (map-over-sheets #'(lambda (pane) - (multiple-value-bind (redisplayp clearp) - (pane-needs-redisplay pane) - (when redisplayp - (when (and clearp - (or (not (pane-incremental-redisplay - pane)) - (not *enable-updating-output*))) - (window-clear pane)) - (redisplay-frame-pane frame pane) - (unless (eq redisplayp :command-loop) - (setf (pane-needs-redisplay pane) nil))))) - (frame-top-level-sheet frame))) - (defparameter +default-prompt-style+ (make-text-style :fix :italic :normal)) (defmethod default-frame-top-level Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.51 mcclim/incremental-redisplay.lisp:1.52 --- mcclim/incremental-redisplay.lisp:1.51 Tue Aug 16 06:30:37 2005 +++ mcclim/incremental-redisplay.lisp Thu Aug 18 05:17:21 2005 @@ -245,8 +245,7 @@ (defmethod pane-needs-redisplay :around ((pane updating-output-stream-mixin)) (let ((redisplayp (call-next-method))) (values redisplayp (and (not (eq redisplayp :no-clear)) - (or (not (pane-incremental-redisplay pane)) - (not *enable-updating-output*)))))) + (not (pane-incremental-redisplay pane)))))) (defmethod window-clear :after ((pane updating-output-stream-mixin)) "Get rid of any updating output records stored in the stream; they're gone @@ -850,9 +849,6 @@ ;; move overlapping nil))))) -(defparameter *enable-updating-output* t - "Switch to turn on incremental redisplay") - (defvar *trace-updating-output* nil) (defvar *no-unique-id* (cons nil nil)) @@ -874,8 +870,6 @@ unique-id id-test cache-value cache-test &key (fixed-position nil) (all-new nil) (parent-cache nil)) - (unless *enable-updating-output* - (return-from invoke-updating-output (funcall continuation stream))) (finish-output stream) (let ((parent-cache (or parent-cache *current-updating-output* stream))) (when (eq unique-id *no-unique-id*) @@ -991,16 +985,6 @@ (defvar *dump-updating-output* nil) -;;; Protocol for notifying that records have been added or deleted, -;;; for real, during redisplay. - -(defgeneric redisplay-add-output-record (record stream) - (:documentation "Process an output record that has been added (i.e., - was not in the output history of the stream) during redisplay. The - record has not been displayed yet.")) - -(defgeneric redisplay-delete-output-record (record bounding-rectangle stream)) - (defgeneric redisplay-output-record (record stream &optional check-overlapping)) @@ -1032,30 +1016,6 @@ (delete-stale-updating-output record)) (set-medium-graphics-state current-graphics-state stream))))) -(defmethod redisplay-add-output-record (record - (stream updating-output-stream-mixin)) - (with-bounding-rectangle* (x1 y1 x2 y2) - record - (draw-rectangle* stream x1 y1 x2 y2 - :ink +background-ink+))) - -(defmethod redisplay-add-output-record :after - (record (stream updating-output-stream-mixin)) - (note-output-record-got-sheet record stream)) - -(defmethod redisplay-delete-output-record - (record bounding-rectangle (stream updating-output-stream-mixin)) - (declare (ignore record)) - (with-bounding-rectangle* (x1 y1 x2 y2) - bounding-rectangle - (draw-rectangle* stream x1 y1 x2 y2 - :ink +background-ink+))) - -(defmethod redisplay-delete-output-record :after - (record bounding-rectangle (stream updating-output-stream-mixin)) - (declare (ignore bounding-rectangle)) - (note-output-record-lost-sheet record stream)) - (defun erase-rectangle (stream bounding) (with-bounding-rectangle* (x1 y1 x2 y2) bounding @@ -1244,7 +1204,7 @@ ((frame application-frame) (pane updating-output-stream-mixin) &key force-p) (setf (id-counter pane) 0) (let ((incremental-redisplay (pane-incremental-redisplay pane))) - (cond ((or (not incremental-redisplay) (not *enable-updating-output*)) + (cond ((not incremental-redisplay) (call-next-method)) ((or (null (updating-record pane)) force-p)

1 0

[mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp
by rstrandh＠common-lisp.net 16 Aug '05

16 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv26736 Modified Files: incremental-redisplay.lisp Log Message: Fixed a bug in function-matches-p. It should use symbol-function and not symbol-value. Date: Tue Aug 16 06:30:37 2005 Author: rstrandh Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.50 mcclim/incremental-redisplay.lisp:1.51 --- mcclim/incremental-redisplay.lisp:1.50 Mon Aug 15 02:41:38 2005 +++ mcclim/incremental-redisplay.lisp Tue Aug 16 06:30:37 2005 @@ -124,9 +124,9 @@ ((and (symbolp map-test-func) (symbolp func)) ; not eq nil) ((and (symbolp map-test-func) (fboundp map-test-func)) - (eq (symbol-value map-test-func) func)) + (eq (symbol-function map-test-func) func)) ((and (symbolp func) (fboundp func)) - (eq map-test-func (symbol-value func))) + (eq map-test-func (symbol-function func))) (t nil)))) (defun ensure-test (map test)

1 0

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

15 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv9635 Modified Files: incremental-redisplay.lisp Log Message: Change specialized output-record-hash method to specialize on standard-bounding-rectangle, as noted by Taylor Campbell Date: Mon Aug 15 02:41:38 2005 Author: tmoore Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.49 mcclim/incremental-redisplay.lisp:1.50 --- mcclim/incremental-redisplay.lisp:1.49 Tue Aug 9 22:30:12 2005 +++ mcclim/incremental-redisplay.lisp Mon Aug 15 02:41:38 2005 @@ -715,7 +715,7 @@ (:documentation "Produce a value that can be used to hash the output record in an equalp hash table")) -(defmethod output-record-hash ((record basic-output-record)) +(defmethod output-record-hash ((record standard-bounding-rectangle)) (slot-value record 'coordinates)) (defconstant +fixnum-bits+ (integer-length most-positive-fixnum))

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/medium.lisp
by crhodes＠common-lisp.net 14 Aug '05

14 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv27374/Backends/CLX Modified Files: medium.lisp Log Message: Whoops. Forgot to commit this one. (Thanks to Peter Mechlenborg) Date: Sun Aug 14 14:47:42 2005 Author: crhodes Index: mcclim/Backends/CLX/medium.lisp diff -u mcclim/Backends/CLX/medium.lisp:1.66 mcclim/Backends/CLX/medium.lisp:1.67 --- mcclim/Backends/CLX/medium.lisp:1.66 Thu Feb 17 22:23:29 2005 +++ mcclim/Backends/CLX/medium.lisp Sun Aug 14 14:47:42 2005 @@ -827,6 +827,47 @@ direction first-not-done)) (values width (+ ascent descent) width 0 ascent)) )))))) ) +#-unicode +(defmethod climi::text-bounding-rectangle* + ((medium clx-medium) string &key text-style (start 0) end) + (when (characterp string) + (setf string (make-string 1 :initial-element string))) + (unless end (setf end (length string))) + (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)) + (t + (let ((position-newline (position #\newline string :start start))) + (cond ((not (null position-newline)) + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (xlib:text-extents xfont string + :start start :end position-newline + :translate #'translate) + (declare (ignorable left right + font-ascent font-descent + direction first-not-done)) + (multiple-value-bind (minx miny maxx maxy) + (text-bounding-rectangle* + medium string :text-style text-style + :start (1+ position-newline) :end end) + (values (min minx left) (- ascent) + (max maxx right) (+ descent maxy))))) + (t + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (xlib:text-extents xfont string + :start start :end end + :translate #'translate) + (declare (ignore width direction first-not-done)) + ;; FIXME: Potential style points: + ;; * (min 0 left), (max width right) + ;; * font-ascent / ascent + (values left (- font-ascent) right font-descent))))))))) + #+unicode (defmethod text-size ((medium clx-medium) string &key text-style (start 0) end) (when (characterp string)

1 0

[mcclim-cvs] CVS update: mcclim/Doc/ex2c.lisp mcclim/Doc/manual.tex
by rstrandh＠common-lisp.net 14 Aug '05

14 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Doc In directory common-lisp.net:/tmp/cvs-serv1335 Modified Files: manual.tex Added Files: ex2c.lisp Log Message: Added example using incremental redisplay. Date: Sun Aug 14 08:20:13 2005 Author: rstrandh Index: mcclim/Doc/manual.tex diff -u mcclim/Doc/manual.tex:1.29 mcclim/Doc/manual.tex:1.30 --- mcclim/Doc/manual.tex:1.29 Sun Aug 14 06:32:38 2005 +++ mcclim/Doc/manual.tex Sun Aug 14 08:20:12 2005 @@ -403,6 +403,25 @@ must have an option of \texttt{:name t}. The reason is that some commands will be available only from menus or by some other mechanism. +You may notice that if the output of the application is hidden (say by +the window of some other application) and then re-exposed, the output +reappears normally, without any intervention necessary on the part of +the programmer. This effect is accomplished by a CLIM mechanism +called \emph{output recording}. Essentially, every piece of output is +not only displayed in the pane, but also captured in an \emph{output + record} associated with the pane. When a pane is re-exposed, its +output records are consulted and if any of them overlap the +re-exposed region, they are redisplayed. In fact, some others may be +redisplayed as well, because CLIM guarantees that the effect will be +the same as when the initial output was created. It does that by +making sure that the order between (partially) overlapping output +records is respected. + +Not all panes support output recording, but certainly application +panes do, so it is good to use some subclass of +\texttt{application-pane} to display application-specific object, +because output recording is then automatic. + \section{An application displaying a data structure} Many applications use a central data structure that is to be on @@ -448,6 +467,73 @@ the value of a single number (or \texttt{NIL}), but you could think of this as displaying all the objects that have been drawn in some figure drawing program or displaying all the entries in an address book. + +\section{Incremental redisplay} + +While the example in the previous section is a very simple way of +structuring an application (let commands arbitrarily modify the data +structure, and simply erase the pane and redisplay the structure after +each iteration of the command loop), the visual result is not so great +when many objects are to be displayed. There is most often a +noticeable flicker between the moment when the pane is cleared and the +objects are drawn. Sometimes this is inevitable (as when nearly all +objects change), but most of the time, only an incremental +modification has been made, and most of the objects are still in the +same place as before. + +In simple toolkits, the application programmer would have to figure +out what has changed since the previous display, and only display the +differences. CLIM offers a mechanism called \emph{incremental + redisplay} that automates a large part of this task. As we +mentioned earlier, CLIM captures output in the form of \emph{output + records}. The same mechanism is used to obtain incremental +redisplay. + +To use incremental redisplay, Client code remains structured in the +simple way that was mention above: after each iteration of the command +loop, the display function output the entire data structure as usual, +except that it helps the incremental redisplay mechanism by telling +CLIM which piece of output corresponds to which piece of output during +the previous iteration of the command loop. It does this by giving +some kind of \emph{unique identity} to some piece of output, and some +means of indicating whether the contents of this output is \emph{the + same} as it was last time. With this information, the CLIM +incremental redisplay mechanism can figure out whether some output is +new, has disappeared, or has been moved, compared to the previous +iteration of the command loop. As with re-exposure, CLIM guarantees +that the result is identical to that which would have been obtained, +had all the output records been output in order to a blank pane. + +The next example illustrates this idea. It is a simple application +that displays a fixed number (here 20) of lines, each line being a +number. Here is the code: + +\verbatimtabinput{ex2c.lisp} + +We store the numbers in a slot called \texttt{numbers} of the +application frame. However, we store each number in its own list. +This is a simple way to provide a unique identity for each number. We +could not use the number itself, because two numbers could be the same +and the identities would not be unique. Instead, we use the cons cell +that store the number as the unique identity. By using +\texttt{:id-test \#'eq} we inform CLIM that it can figure out whether +an output record is the same as one that was issued previous time by +using the function \texttt{eq} to compare them. But there is a second +test that has to be verified, namely whether an output record that was +issued last time has to be redisplayed or not. That is the purpose of +the cache-value. Here we use the number itself as the cache value and +\texttt{eql} as the test to determine whether the output is going to +be the same as last time. + +For convenience, we display a \texttt{*} at the beginning of the +current line, and we provide two commands \texttt{next} and +\texttt{previous} to navigate between the lines. + +Notice that in the declaration of the pane in the application frame, +we have given the option \texttt{:incremental-redisplay t}. This +informs CLIM not to clear the pane after each command-loop iteration, +but to keep the output records around and compare them to the new ones +that are produced during the new iteration. \chapter{Using presentation types}

1 0

[mcclim-cvs] CVS update: mcclim/Doc/ex2b.lisp mcclim/Doc/manual.tex
by rstrandh＠common-lisp.net 14 Aug '05

14 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Doc In directory common-lisp.net:/tmp/cvs-serv26982 Modified Files: manual.tex Added Files: ex2b.lisp Log Message: Another simple example with explanations. Date: Sun Aug 14 06:32:39 2005 Author: rstrandh Index: mcclim/Doc/manual.tex diff -u mcclim/Doc/manual.tex:1.28 mcclim/Doc/manual.tex:1.29 --- mcclim/Doc/manual.tex:1.28 Sun Aug 14 06:01:19 2005 +++ mcclim/Doc/manual.tex Sun Aug 14 06:32:38 2005 @@ -403,6 +403,52 @@ must have an option of \texttt{:name t}. The reason is that some commands will be available only from menus or by some other mechanism. +\section{An application displaying a data structure} + +Many applications use a central data structure that is to be on +display at all times, and that is modified by the commands of the +application. CLIM allows for a very easy way to write such an +application. The main idea is to store the data structure in slots of +the application frame, and to use a \emph{display function} that after +each iteration of the command loop displays the entire data structure +to the application pane. + +Here is a variation of the previous application that shows this +possibility: + +\verbatimtabinput{ex2b.lisp} + +Here, we have added a slot that is called \texttt{current-number} to +the application frame. It is initialized to \texttt{NIL} and it has +an accessor function that allow us to query and to modify the value. + +Observe that in this example, we no longer have the option +\texttt{:display-time nil} set in the application pane. By default, +then, the \texttt{:display-time} is \texttt{:command-loop} which means +that the pane is erased after each iteration of the command loop. +Also observe the option \texttt{:display-function} which takes a +symbol that names a function to be called to display the pane after it +has been cleared. In this case, the name is \texttt{display-app}, the +name of the function defined immediately after the application frame. + +Instead of immediately displaying information about its argument, the +command \texttt{com-parity} instead modifies the new slot of the +application frame. Think of this function as being more general, for +instance a command to add a new object to a set of graphical objects +in a figure drawing program, or as a command to add a new name to an +address book. Notice how this function accesses the current +application frame by means of the special variable +\texttt{*application-frame*}. + +A display function is called with the frame and the pane as +arguments. It is good style to use the pane as the stream in calls to +functions that will result in output. This makes it possible for the +same function to be used by several different frames, should that be +called for. In our simple example, the display function only displays +the value of a single number (or \texttt{NIL}), but you could think of +this as displaying all the objects that have been drawn in some figure +drawing program or displaying all the entries in an address book. + \chapter{Using presentation types} \section{What is a presentation type}

1 0

[mcclim-cvs] CVS update: mcclim/Doc/manual.tex mcclim/Doc/ex2.lisp
by rstrandh＠common-lisp.net 14 Aug '05

14 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Doc In directory common-lisp.net:/tmp/cvs-serv23985 Modified Files: manual.tex ex2.lisp Log Message: Added :display-time nil to example 2 so that it will run correctly. Added a paragraph to the manual explaining what that means. Date: Sun Aug 14 06:01:23 2005 Author: rstrandh Index: mcclim/Doc/manual.tex diff -u mcclim/Doc/manual.tex:1.27 mcclim/Doc/manual.tex:1.28 --- mcclim/Doc/manual.tex:1.27 Thu Apr 7 09:54:59 2005 +++ mcclim/Doc/manual.tex Sun Aug 14 06:01:19 2005 @@ -1,6 +1,7 @@ % -*- coding: latin-1; -*- \documentclass{book} +\usepackage[T1]{fontenc} \usepackage[latin1]{inputenc} \usepackage{color} \usepackage{epsfig} @@ -350,6 +351,22 @@ such as \texttt{format} and \texttt{read} and to CLIM-specific functions such as \texttt{draw-line}. +In this example we have such an application pane, the name of which is +\texttt{app}. As you can see, we have defined it with an option +\texttt{:display-time nil}. The default value for this option for an +application pane is \texttt{:command-loop}, which means that the pane +is cleared after each iteration in the command loop, and then +redisplayed using a client-supplied \emph{display function}. The +default display function does nothing, and we have not supplied any, +so if we had omitted the \texttt{:display-time nil} option, the +\texttt{parity} command would have written to the pane. Then, at the +end of the command loop, the pane would have been cleared, and nothing +else would have been displayed. The net result is that we would have +seen no visible output. With the option \texttt{:display-time nil}, +the pane is never cleared, and output is accumulated every time we +execute the \texttt{parity} command. + + For this example, let us also add a few \emph{commands}. Such commands are defined by the use of a macro called \texttt{define-}\textit{name}\texttt{-command}, where \textit{name} is @@ -648,9 +665,8 @@ c. Mirrors are outlined with dotted rectangles. \begin{figure} - \begin{center} - \input native.pstex_t -%\inputfig{native.pstex_t} +\begin{center} +\inputfig{native.pstex_t} \end{center} \caption{\label{fignative} A sheet with a nontrivial transformation} \end{figure} Index: mcclim/Doc/ex2.lisp diff -u mcclim/Doc/ex2.lisp:1.2 mcclim/Doc/ex2.lisp:1.3 --- mcclim/Doc/ex2.lisp:1.2 Thu Jul 22 14:04:55 2004 +++ mcclim/Doc/ex2.lisp Sun Aug 14 06:01:21 2005 @@ -10,7 +10,7 @@ () (:pointer-documentation t) (:panes - (app :application :height 600 :width 600) + (app :application :display-time nil :height 400 :width 600) (int :interactor :height 200 :width 600)) (:layouts (default (vertically () app int))))

1 0

[mcclim-cvs] CVS update: mcclim/Experimental/freetype/freetype-fonts.lisp
by crhodes＠common-lisp.net 13 Aug '05

13 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory common-lisp.net:/tmp/cvs-serv4334/Experimental/freetype Modified Files: freetype-fonts.lisp Log Message: Commit working version of text-bounding-rectangle* stuff, as trailed on mcclim-devel 2005-08-12. Basically, this is needed because the drawn area for left-to-right text need not lie between (x,y-ascent) and (x+width,y+descent). (No doubt other text drawing directions suffer from the same problem, but they're not yet implemented in McCLIM). New per-medium function TEXT-BOUNDING-RECTANGLE* which actually returns the bounding-rectangle* of what is drawn (cf. TEXT-WIDTH, which doesn't do anything of the sort). Use it in DEF-GRECORDING DRAW-TEXT, and in add-{string,character}-to-output-record, to properly adjust the output record coordinates. While we're at it, fix the bounding box for :y-align :center DRAW-TEXT. Implement this per-medium function for the CLX backend, for the experimental freetype text handling, and for postscript (tested using Climacs, Tabcode and clim-demo::postscript-text). This patch was mostly motivated by the observation that incremental redisplay in climacs windows using the freetype backend caused graphical artifacts to appear over time, thanks to glyphs drawing outside the output record bounding rectangles. Breaks: * CLX backend with #+unicode (clisp?) * Beagle backend * OpenGL backend (please fix!) Date: Sat Aug 13 16:28:34 2005 Author: crhodes Index: mcclim/Experimental/freetype/freetype-fonts.lisp diff -u mcclim/Experimental/freetype/freetype-fonts.lisp:1.10 mcclim/Experimental/freetype/freetype-fonts.lisp:1.11 --- mcclim/Experimental/freetype/freetype-fonts.lisp:1.10 Fri Jul 29 08:50:20 2005 +++ mcclim/Experimental/freetype/freetype-fonts.lisp Sat Aug 13 16:28:33 2005 @@ -160,7 +160,8 @@ :y-origin top :x-advance dx :y-advance dy) - (list glyph-id dx dy)))) + (let ((right (+ left (array-dimension arr 1)))) + (list glyph-id dx dy left right top))))) ;;;;;;; mcclim interface @@ -182,22 +183,32 @@ (defmethod clim-clx::font-glyph-width ((font freetype-face) char) (with-slots (display font matrix) font (nth 1 (display-get-glyph display font matrix char)))) +(defmethod clim-clx::font-glyph-left ((font freetype-face) char) + (with-slots (display font matrix) font + (nth 3 (display-get-glyph display font matrix char)))) +(defmethod clim-clx::font-glyph-right ((font freetype-face) char) + (with-slots (display font matrix) font + (nth 4 (display-get-glyph display font matrix char)))) +;;; this is a hacky copy of XLIB:TEXT-EXTENTS (defmethod clim-clx::font-text-extents ((font freetype-face) string &key (start 0) (end (length string)) translate) ;; -> (width ascent descent left right ;; font-ascent font-descent direction ;; first-not-done) translate - (values - (loop for i from start below end - sum (clim-clx::font-glyph-width font (char-code (aref string i)))) - (clim-clx::font-ascent font) - (clim-clx::font-descent font) - 0 0 - (clim-clx::font-ascent font) - (clim-clx::font-descent font) - 0 end)) + (let ((width (loop for i from start below end + sum (clim-clx::font-glyph-width font (char-code (aref string i)))))) + (values + width + (clim-clx::font-ascent font) + (clim-clx::font-descent font) + (clim-clx::font-glyph-left font (char-code (char string start))) + (- width (- (clim-clx::font-glyph-width font (char-code (char string (1- end)))) + (clim-clx::font-glyph-right font (char-code (char string (1- end)))))) + (clim-clx::font-ascent font) + (clim-clx::font-descent font) + 0 end))) (defun drawable-picture (drawable) (or (getf (xlib:drawable-plist drawable) 'picture) @@ -373,6 +384,47 @@ font-ascent font-descent direction first-not-done)) (values width (+ ascent descent) width 0 ascent)) )))))) ) + +(defmethod climi::text-bounding-rectangle* + ((medium clx-medium) string &key text-style (start 0) end) + (when (characterp string) + (setf string (make-string 1 :initial-element string))) + (unless end (setf end (length string))) + (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)) + (t + (let ((position-newline (position #\newline string :start start))) + (cond ((not (null position-newline)) + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (font-text-extents xfont string + :start start :end position-newline + :translate #'translate) + (declare (ignorable left right + font-ascent font-descent + direction first-not-done)) + (multiple-value-bind (minx miny maxx maxy) + (climi::text-bounding-rectangle* + medium string :text-style text-style + :start (1+ position-newline) :end end) + (values (min minx left) (- ascent) + (max maxx right) (+ descent maxy))))) + (t + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (font-text-extents xfont string + :start start :end end + :translate #'translate) + (declare (ignore width direction first-not-done)) + ;; FIXME: Potential style points: + ;; * (min 0 left), (max width right) + ;; * font-ascent / ascent + (values left (- font-ascent) right font-descent))))))))) + (defmethod make-medium-gcontext* (medium foreground background line-style text-style (ink color) clipping-region) (let* ((drawable (sheet-mirror (medium-sheet medium)))

1 0