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

[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

[mcclim-cvs] CVS update: mcclim/recording.lisp mcclim/stream-output.lisp
by crhodes＠common-lisp.net 13 Aug '05

13 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv4334 Modified Files: recording.lisp stream-output.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:21 2005 Author: crhodes Index: mcclim/recording.lisp diff -u mcclim/recording.lisp:1.118 mcclim/recording.lisp:1.119 --- mcclim/recording.lisp:1.118 Tue Feb 15 12:28:11 2005 +++ mcclim/recording.lisp Sat Aug 13 16:28:19 2005 @@ -1644,7 +1644,7 @@ (def-grecording draw-text ((gs-text-style-mixin) string point-x point-y start end align-x align-y toward-x toward-y transform-glyphs) () ;; FIXME!!! Text direction. - ;; Multiple lines? + ;; FIXME: Multiple lines. (let* ((text-style (graphics-state-text-style graphic)) (width (if (characterp string) (stream-character-width stream string :text-style text-style) @@ -1654,27 +1654,26 @@ (ascent (text-style-ascent text-style (sheet-medium stream))) (descent (text-style-descent text-style (sheet-medium stream))) (height (+ ascent descent)) - (transform (medium-transformation medium)) - left top right bottom) + (transform (medium-transformation medium))) (setf (values point-x point-y) (transform-position transform point-x point-y)) - (ecase align-x - (:left (setq left point-x - right (+ point-x width))) - (:right (setq left (- point-x width) - right point-x)) - (:center (setq left (- point-x (round width 2)) - right (+ point-x (round width 2))))) - (ecase align-y - (:baseline (setq top (- point-y ascent) - bottom (+ point-y descent))) - (:top (setq top point-y - bottom (+ point-y height))) - (:bottom (setq top (- point-y height) - bottom point-y)) - (:center (setq top (- point-y (floor height 2)) - bottom (+ point-y (ceiling height 2))))) - (values left top right bottom))) + (multiple-value-bind (left top right bottom) + (text-bounding-rectangle* medium string + :start start :end end :text-style text-style) + (ecase align-x + (:left (incf left point-x) (incf right point-x)) + (:right (incf left (- point-x width)) (incf right (- point-x width))) + (:center (incf left (- point-x (round width 2))) + (incf right (- point-x (round width 2))))) + (ecase align-y + (:baseline (incf top point-y) (incf bottom point-y)) + (:top (incf top (+ point-y ascent)) + (incf bottom (+ point-y ascent))) + (: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))))) + (values left top right bottom)))) (defmethod* (setf output-record-position) :around (nx ny (record draw-text-output-record)) @@ -1736,6 +1735,15 @@ (baseline :initform 0) (width :initform 0) (max-height :initform 0) + ;; FIXME (or rework this comment): CLIM does not separate the + ;; notions of the text width and the bounding box; however, we need + ;; to, because some fonts will render outside the logical + ;; coordinates defined by the start position and the width. LEFT + ;; and RIGHT here (and below) deal with this in a manner completely + ;; hidden from the user. (should we export + ;; TEXT-BOUNDING-RECTANGLE*?) + (left :initarg :start-x) + (right :initarg :start-x) (start-x :initarg :start-x) (start-y :initarg :start-y) (end-x :initarg :start-x) @@ -1757,12 +1765,14 @@ ((record standard-text-displayed-output-record) (record2 standard-text-displayed-output-record)) (with-slots - (initial-x1 initial-y1 start-x start-y end-x end-y wrapped strings) + (initial-x1 initial-y1 start-x start-y left right end-x end-y wrapped strings) record2 (and (coordinate= (slot-value record 'initial-x1) initial-x1) (coordinate= (slot-value record 'initial-y1) initial-y1) (coordinate= (slot-value record 'start-x) start-x) (coordinate= (slot-value record 'start-y) start-y) + (coordinate= (slot-value record 'left) left) + (coordinate= (slot-value record 'right) right) (coordinate= (slot-value record 'end-x) end-x) (coordinate= (slot-value record 'end-y) end-y) (eq (slot-value record 'wrapped) wrapped) @@ -1835,20 +1845,21 @@ (defmethod tree-recompute-extent ((text-record standard-text-displayed-output-record)) - (with-standard-rectangle* (:x1 x1 :y1 y1) + (with-standard-rectangle* (:y1 y1) text-record - (with-slots (width max-height) + (with-slots (max-height left right) text-record (setf (rectangle-edges* text-record) - (values x1 y1 - (coordinate (+ x1 width)) - (coordinate (+ y1 max-height)))))) + (values (coordinate left) + y1 + (coordinate right) + (coordinate (+ y1 max-height)))))) text-record) (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-... ((text-record standard-text-displayed-output-record) character text-style char-width height new-baseline) - (with-slots (strings baseline width max-height start-y end-x end-y medium) + (with-slots (strings baseline width max-height left right start-y end-x end-y medium) text-record (if (and strings (let ((string (last1 strings))) @@ -1868,11 +1879,18 @@ :element-type 'character :adjustable t :fill-pointer t))))) - (setq baseline (max baseline new-baseline) - end-x (+ end-x char-width) - max-height (max max-height height) - end-y (max end-y (+ start-y max-height)) - width (+ width char-width))) + (multiple-value-bind (minx miny maxx maxy) + (text-bounding-rectangle* medium character :text-style text-style) + (declare (ignore miny maxy)) + (setq baseline (max baseline new-baseline) + ;; KLUDGE: note END-X here is really START-X of the new + ;; string + left (min left (+ end-x minx)) + end-x (+ end-x char-width) + right (+ end-x (max 0 (- maxx char-width))) + max-height (max max-height height) + end-y (max end-y (+ start-y max-height)) + width (+ width char-width)))) (tree-recompute-extent text-record)) (defmethod add-string-output-to-text-record @@ -1886,7 +1904,7 @@ (aref string start) text-style string-width height new-baseline)) - (t (with-slots (strings baseline width max-height start-y end-x end-y + (t (with-slots (strings baseline width max-height left right start-y end-x end-y medium) text-record (let ((styled-string (make-instance @@ -1901,12 +1919,21 @@ (nconcf strings (list styled-string)) (replace (styled-string-string styled-string) string :start2 start :end2 end)) - (setq baseline (max baseline new-baseline) - end-x (+ end-x string-width) - max-height (max max-height height) - end-y (max end-y (+ start-y max-height)) - width (+ width string-width))) - (tree-recompute-extent text-record))))) + (multiple-value-bind (minx miny maxx maxy) + (text-bounding-rectangle* medium string + :text-style text-style + :start start :end end) + (declare (ignore miny maxy)) + (setq baseline (max baseline new-baseline) + ;; KLUDGE: note that END-X here really means + ;; START-X of the new string. + left (min left (+ end-x minx)) + end-x (+ end-x string-width) + right (+ end-x (max 0 (- maxx string-width))) + max-height (max max-height height) + end-y (max end-y (+ start-y max-height)) + width (+ width string-width)))) + (tree-recompute-extent text-record))))) (defmethod text-displayed-output-record-string ((record standard-text-displayed-output-record)) Index: mcclim/stream-output.lisp diff -u mcclim/stream-output.lisp:1.55 mcclim/stream-output.lisp:1.56 --- mcclim/stream-output.lisp:1.55 Thu Apr 21 04:43:19 2005 +++ mcclim/stream-output.lisp Sat Aug 13 16:28:20 2005 @@ -358,9 +358,7 @@ (unless (= start split) (stream-write-output stream string - (if (eql end split) - width - nil) + nil start split) (setq cx (+ cx width)) (with-slots (x y) (stream-text-cursor stream)

1 0

[mcclim-cvs] CVS update: mcclim/package.lisp
by rgoldman＠common-lisp.net 12 Aug '05

12 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv20358 Modified Files: package.lisp Log Message: FORMAT-GRAPH-FROM-ROOT was not exported from CLIM package. Date: Fri Aug 12 04:26:00 2005 Author: rgoldman Index: mcclim/package.lisp diff -u mcclim/package.lisp:1.49 mcclim/package.lisp:1.50 --- mcclim/package.lisp:1.49 Tue Mar 22 13:31:18 2005 +++ mcclim/package.lisp Fri Aug 12 04:26:00 2005 @@ -709,6 +709,7 @@ #:float ;presentation type #:form ;presentation type #:format-graph-from-roots ;function + #:format-graph-from-root ;function #:format-items ;function #:format-textual-list ;function #:formatting-cell ;macro

1 0

[mcclim-cvs] CVS update: mcclim/graph-formatting.lisp
by rgoldman＠common-lisp.net 12 Aug '05

12 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv20270 Modified Files: graph-formatting.lisp Log Message: Modified layout-graph-nodes so that it permits duplicate-test arguments that are not compatible with hash-tables. Added a (not very good) layout method for DAGS. Arbitrary DIGRAPHs still not supported. Date: Fri Aug 12 04:18:03 2005 Author: rgoldman Index: mcclim/graph-formatting.lisp diff -u mcclim/graph-formatting.lisp:1.15 mcclim/graph-formatting.lisp:1.16 --- mcclim/graph-formatting.lisp:1.15 Fri May 13 05:00:25 2005 +++ mcclim/graph-formatting.lisp Fri Aug 12 04:18:03 2005 @@ -3,10 +3,11 @@ ;;; Title: Graph Formatting ;;; Created: 2002-08-13 ;;; License: LGPL (See file COPYING for details). -;;; $Id: graph-formatting.lisp,v 1.15 2005/05/13 03:00:25 ahefner Exp $ +;;; $Id: graph-formatting.lisp,v 1.16 2005/08/12 02:18:03 rgoldman Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann +;;; (c) copyright 2005 by Robert P. Goldman ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -138,6 +139,15 @@ graph-type (or graph-type (if merge-duplicates :digraph :tree)) duplicate-key (or duplicate-key #'identity) duplicate-test (or duplicate-test #'eql) ) + + ;; I'm not sure what to do here. Saying you want a tree, but want + ;; duplicates merged seems wrong. OTOH, if you go out of your way + ;; to do it, at your own risk, is it our place to say "no"? + ;; [2005/08/11:rpg] +;;; (when (and (eq graph-type :tree) merge-duplicates) +;;; (cerror "Substitute NIL for merge-duplicates" +;;; "Merge duplicates specified to be true when using :tree layout.") +;;; (setf merge-duplicates nil)) ;; clean the options (remf graph-options :stream) @@ -163,8 +173,10 @@ #'cont (find-graph-type graph-type) nil - :hash-table (make-hash-table :test duplicate-test) - graph-options)))) + ;; moved to local variable... [2005/07/25:rpg] + ;; :hash-table (make-hash-table :test duplicate-test) + graph-options + )))) (setf (output-record-position graph-output-record) (values cursor-old-x cursor-old-y)) (with-output-recording-options (stream :draw t :record nil) @@ -182,35 +194,40 @@ (defclass standard-graph-output-record (graph-output-record standard-sequence-output-record) - ((orientation - :initarg :orientation - :initform :horizontal) - (center-nodes - :initarg :center-nodes - :initform nil) - (cutoff-depth - :initarg :cutoff-depth - :initform nil) - (merge-duplicates - :initarg :merge-duplicates - :initform nil) - (generation-separation - :initarg :generation-separation - :initform '(4 :character)) - (within-generation-separation - :initarg :within-generation-separation - :initform '(1/2 :line)) - (hash-table - :initarg :hash-table - :initform nil) - (root-nodes - :accessor graph-root-nodes) )) + ((orientation + :initarg :orientation + :initform :horizontal) + (center-nodes + :initarg :center-nodes + :initform nil) + (cutoff-depth + :initarg :cutoff-depth + :initform nil) + (merge-duplicates + :initarg :merge-duplicates + :initform nil) + (generation-separation + :initarg :generation-separation + :initform '(4 :character)) + (within-generation-separation + :initarg :within-generation-separation + :initform '(1/2 :line)) + ;; removed HASH-TABLE slot and stuffed it into + ;; GENERATE-GRAPH-NODES method definition [2005/07/25:rpg] + (root-nodes + :accessor graph-root-nodes) + )) (defclass tree-graph-output-record (standard-graph-output-record) - ()) + ()) + +;;;(defmethod initialize-instance :after ((obj tree-graph-output-record) &key merge-duplicates) +;;; (when merge-duplicates +;;; (warn "Cannot use a TREE layout for graphs while merging duplicates."))) (defclass dag-graph-output-record (standard-graph-output-record) - ()) + ( + )) (defclass digraph-graph-output-record (standard-graph-output-record) ()) @@ -238,45 +255,64 @@ ;;;; +;;; Modified to make this obey the spec better by using a hash-table +;;; for detecting previous nodes only when the duplicate-test argument +;;; permits it. [2005/08/10:rpg] (defmethod generate-graph-nodes ((graph-output-record standard-graph-output-record) stream root-objects object-printer inferior-producer &key duplicate-key duplicate-test) - (declare (ignore duplicate-test)) - (with-slots (cutoff-depth merge-duplicates hash-table) graph-output-record - (labels - ((traverse-objects (node objects depth) - (unless (and cutoff-depth (>= depth cutoff-depth)) - (remove nil - (map 'list - (lambda (child) - (let* ((key (funcall duplicate-key child)) - (child-node (and merge-duplicates - (gethash key hash-table)))) - (cond (child-node - (when node - (push node (graph-node-parents child-node))) - child-node) - (t - (let ((child-node - (with-output-to-output-record - (stream 'standard-graph-node-output-record new-node - :object child) - (funcall object-printer child stream)))) - (when merge-duplicates - (setf (gethash key hash-table) child-node)) - (when node - (push node (graph-node-parents child-node))) - (setf (graph-node-children child-node) - (traverse-objects child-node - (funcall inferior-producer child) - (+ depth 1))) - child-node))))) - objects))))) - ;; - (setf (graph-root-nodes graph-output-record) - (traverse-objects nil root-objects 0)) - (values)))) + (with-slots (cutoff-depth merge-duplicates) graph-output-record + (let* ((hash-table (when (and merge-duplicates (member duplicate-test (list #'eq #'eql #'equal #'equalp))) + (make-hash-table :test duplicate-test))) + node-list + (hashed hash-table)) + (labels + ((previous-node (obj) + ;; is there a previous node for obj? if so, return it. + (when merge-duplicates + (if hashed + (locally (declare (type hash-table hash-table)) + (gethash obj hash-table)) + (cdr (assoc obj node-list :test duplicate-test))))) + ((setf previous-node) (val obj) + (if hashed + (locally (declare (type hash-table hash-table)) + (setf (gethash obj hash-table) val)) + (setf node-list (push (cons obj val) node-list)))) + (traverse-objects (node objects depth) + (unless (and cutoff-depth (>= depth cutoff-depth)) + (remove nil + (map 'list + (lambda (child) + (let* ((key (funcall duplicate-key child)) + (child-node (previous-node key))) + (cond (child-node + (when node + (push node (graph-node-parents child-node))) + child-node) + (t + (let ((child-node + (with-output-to-output-record + (stream 'standard-graph-node-output-record new-node + :object child) + (funcall object-printer child stream)))) + (when merge-duplicates + (setf (previous-node key) child-node) + ;; (setf (gethash key hash-table) child-node) + ) + (when node + (push node (graph-node-parents child-node))) + (setf (graph-node-children child-node) + (traverse-objects child-node + (funcall inferior-producer child) + (+ depth 1))) + child-node))))) + objects))))) + ;; + (setf (graph-root-nodes graph-output-record) + (traverse-objects nil root-objects 0)) + (values))))) (defun traverse-graph-nodes (graph continuation) ;; continuation: node x children x cont -> some value @@ -300,6 +336,8 @@ (:horizontal :vertical) (:vertical :horizontal)))) (generation-separation (parse-space stream generation-separation orientation))) + ;; generation sizes is an adjustable array that tracks the major + ;; dimension of each of the generations [2005/07/18:rpg] (let ((generation-sizes (make-array 10 :adjustable t :initial-element 0))) (labels ((node-major-dimension (node) (if (eq orientation :vertical) @@ -309,6 +347,9 @@ (if (eq orientation :vertical) (bounding-rectangle-width node) (bounding-rectangle-height node))) + ;; WALK returns a node minor dimension for the node, + ;; AFAICT, allowing space for that node's children + ;; along the minor dimension. [2005/07/18:rpg] (walk (node depth) (unless (graph-node-minor-size node) (when (>= depth (length generation-sizes)) @@ -367,6 +408,121 @@ (unless (null rest) (incf v within-generation-separation))) (graph-root-nodes graph-output-record))))))))))) + + +(defmethod layout-graph-nodes ((graph-output-record dag-graph-output-record) + stream arc-drawer arc-drawing-options) + "This is a first shot at a DAG layout. First does a TOPO sort that associates +each node with a depth, then lays out by depth. Tries to reuse a maximum of the +tree graph layout code. +PRECONDITION: This code assumes that we have generated only nodes up to the +cutoff-depth. GENERATE-GRAPH-NODES seems to obey this precondition." + (declare (ignore arc-drawer arc-drawing-options)) + (with-slots (orientation center-nodes generation-separation within-generation-separation root-nodes + merge-duplicates) graph-output-record + ;; this code is snarly enough, handling merge-duplicates. If + ;; you're not merging duplicates, you're out of luck, at least for + ;; now... [2005/07/18:rpg] + (unless merge-duplicates + (cerror "Set to T and continue?" "DAG graph-layout type only supports merge-duplicates to be T") + (setf merge-duplicates t)) + + (check-type orientation (member :horizontal :vertical)) ;xxx move to init.-inst. + + ;; here major dimension is the dimension in which we grow the + ;; tree. + (let ((within-generation-separation (parse-space stream within-generation-separation + (case orientation + (:horizontal :vertical) + (:vertical :horizontal)))) + (generation-separation (parse-space stream generation-separation orientation))) + ;; generation sizes is an adjustable array that tracks the major + ;; dimension of each of the generations [2005/07/18:rpg] + (let ((generation-sizes (make-array 10 :adjustable t :initial-element 0)) + (visited (make-hash-table :test #'eq)) + (parent-hash (make-hash-table :test #'eq))) + (labels ((node-major-dimension (node) + (if (eq orientation :vertical) + (bounding-rectangle-height node) + (bounding-rectangle-width node))) + (node-minor-dimension (node) + (if (eq orientation :vertical) + (bounding-rectangle-width node) + (bounding-rectangle-height node))) + ;; WALK returns a node minor dimension for the node, + ;; AFAICT, allowing space for that node's children + ;; along the minor dimension. [2005/07/18:rpg] + (walk (node depth &optional parent) + (unless (gethash node visited) + (setf (gethash node visited) depth) + (when parent + (setf (gethash node parent-hash) parent)) + (unless (graph-node-minor-size node) + (when (>= depth (length generation-sizes)) + (setf generation-sizes (adjust-array generation-sizes (ceiling (* depth 1.2)) + :initial-element 0))) + (setf (aref generation-sizes depth) + (max (aref generation-sizes depth) (node-major-dimension node))) + (setf (graph-node-minor-size node) 0) + (max (node-minor-dimension node) + (setf (graph-node-minor-size node) + (let ((sum 0) (n 0)) + (map nil (lambda (child) + (let ((x (walk child (+ depth 1) node))) + (when x + (incf sum x) + (incf n)))) + (graph-node-children node)) + (+ sum + (* (max 0 (- n 1)) within-generation-separation))))))))) + (map nil #'(lambda (x) (walk x 0)) root-nodes) + (let ((hash (make-hash-table :test #'eq))) + (labels ((foo (node majors u0 v0) + (cond ((gethash node hash) + v0) + (t + (setf (gethash node hash) t) + (let ((d (- (node-minor-dimension node) + (graph-node-minor-size node)))) + (let ((v (+ v0 (/ (min 0 d) -2)))) + (setf (output-record-position node) + (if (eq orientation :vertical) + (transform-position (medium-transformation stream) v u0) + (transform-position (medium-transformation stream) u0 v))) + (add-output-record node graph-output-record)) + ;; + (let ((u (+ u0 (car majors))) + (v (+ v0 (max 0 (/ d 2)))) + (firstp t)) + (map nil (lambda (q) + (unless (gethash q hash) + (if firstp + (setf firstp nil) + (incf v within-generation-separation)) + (setf v (foo q (cdr majors) + u v)))) + ;; when computing the sizes, to + ;; make the tree-style layout + ;; work, we have to have each + ;; node have a unique + ;; parent. [2005/07/18:rpg] + (remove-if-not #'(lambda (x) (eq (gethash x parent-hash) node)) + (graph-node-children node)))) + ;; + (+ v0 (max (node-minor-dimension node) + (graph-node-minor-size node)))))))) + ;; + (let ((majors (mapcar (lambda (x) (+ x generation-separation)) + (coerce generation-sizes 'list)))) + (let ((u (+ 0 (car majors))) + (v 0)) + (maplist (lambda (rest) + (setf v (foo (car rest) majors u v)) + (unless (null rest) + (incf v within-generation-separation))) + (graph-root-nodes graph-output-record))))))))))) + + #+ignore (defmethod layout-graph-edges ((graph-output-record standard-graph-output-record)

1 0

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

09 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv27570 Modified Files: incremental-redisplay.lisp Log Message: Implement a generic output-record-hash which doesn't depend on the coordinates slot of standard-rectangle Date: Tue Aug 9 22:30:13 2005 Author: tmoore Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.48 mcclim/incremental-redisplay.lisp:1.49 --- mcclim/incremental-redisplay.lisp:1.48 Sun May 8 20:15:44 2005 +++ mcclim/incremental-redisplay.lisp Tue Aug 9 22:30:12 2005 @@ -711,9 +711,41 @@ (defvar *existing-output-records* nil) ;;; +(defgeneric output-record-hash (record) + (:documentation "Produce a value that can be used to hash the output record +in an equalp hash table")) -(defmethod output-record-hash (record) +(defmethod output-record-hash ((record basic-output-record)) (slot-value record 'coordinates)) + +(defconstant +fixnum-bits+ (integer-length most-positive-fixnum)) + +(declaim (inline hash-coords)) +(defun hash-coords (x1 y1 x2 y2) + (declare (type real x1 y1 x2 y2)) ;XXX Someday this should be float + (let ((hash-val 0)) + (declare (type fixnum hash-val)) + (labels ((rot4 (val) + (dpb (ldb (byte 4 0) val) + (byte 4 (- +fixnum-bits+ 4 1)) + (ash val -4))) + (mix-it-in (val) + (let ((xval (sxhash val))) + (declare (type fixnum xval)) + (when (minusp val) + (setq xval (rot4 xval))) + (setq hash-val (logxor (rot4 hash-val) xval))))) + (declare (inline rot4 mix-it-in)) + (mix-it-in x1) + (mix-it-in y1) + (mix-it-in x2) + (mix-it-in y2) + hash-val))) + +(defmethod output-record-hash ((record output-record)) + (with-bounding-rectangle* (x1 y1 x2 y2) + record + (hash-coords x1 y1 x2 y2))) (defmethod compute-difference-set ((record standard-updating-output-record) &optional (check-overlapping t)

1 0

[mcclim-cvs] CVS update: mcclim/presentation-defs.lisp
by crhodes＠common-lisp.net 08 Aug '05

08 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv13631 Modified Files: presentation-defs.lisp Log Message: One-line patch to presentation-single-box handling, from Dave Murray (27th July 2005, mcclim-devel) Date: Mon Aug 8 19:15:08 2005 Author: crhodes Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.44 mcclim/presentation-defs.lisp:1.45 --- mcclim/presentation-defs.lisp:1.44 Wed Jun 22 11:49:15 2005 +++ mcclim/presentation-defs.lisp Mon Aug 8 19:15:07 2005 @@ -993,7 +993,7 @@ (multiple-value-bind (min-x min-y max-x max-y) (output-record-hit-detection-rectangle* record) (if (and (<= min-x x max-x) (<= min-y y max-y)) - (if (or (null single-box) (eq single-box :higlighting)) + (if (or (null single-box) (eq single-box :highlighting)) (funcall-presentation-generic-function presentation-refined-position-test (presentation-type record) record x y)

1 0