mcclim-devel

mcclim-devel@common-lisp.net

820 discussions

[mcclim-devel] Re: international text-style support
by Christophe Rhodes 02 Aug '05

02 Aug '05

[ a very long time ago, in the context of supporting complicated international scripts ] Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> writes: > Brian Spilsbury writes: > > I have implement (somewhat primitive) international text-style support. > > [...] > > This sounds like a somewhat reasonable design to me, although I would > very much prefer if we could move the fontset logic into the frontend > by coming up with a sort of font protocol. So, now, we (at Goldsmiths) have a need for a specific font. At the moment, we have hacked in support to our application using MAKE-DEVICE-FONT-TEXT-STYLE and some extreme hackiness in CLIM-CLX::TEXT-STYLE-TO-X-FONT; the device-font-text-style support in current CVS is ... not extensive, which is not really surprising given that the spec is approximately equally non-extensive. It tickled my memory, though, and I dug up this proposal: > Something like this: > > A font is a mapping from glyph names (indicies) to glyphs. Fonts > have additional attributes like name, weight, an encoding, a > language and so on. Glyphs have metrics and are drawable to > individual media. > > FONT protocol class > > FONT-NAME font method > FONT-WEIGHT font method > FONT-SLANT font method > FONT-... font method > > The individual typographical properties of the font. > > SCALE-FONT font size -> font method > > Scales the font to a new size. > [Q1: Unit for size?] > [Q2: Should this affect metrics?] > > FONT-SIZE font method > > Returns the size of the font. > > TRANSFORM-FONT font transformation -> font method > > Applies a affine transformation to the font. Each glyph drawn with > the returned font are then drawn under the transformation. This > does not affect the individual glyph metrics. > > FONT-TRANSFORMATION font -> transformation method > > Returns the transformation of the font font. > > FONT-GLYPH-METRICS font glyph method > -> width ascent descent left-bearing right-bearing > > Returns the fonts glyph metrics. To calculate the metrics of > glyphs as drawn my draw-glyph the transformation of the font has > to be applied to the returned values. > > [This is to keep the glyph-metrics as scalars instead of making > each metric into a vector]. > > width should not be negative in case of RTL script, since > typesetting from right to left is consided to be a property of a > text-style; likewise left-bearing bearing on the left hand side > as right bearing is bearing on the right hand size. > > Q4: Is there something like top-bearing, bottom-bearing for fonts > designed towards top-to-bottom scripts? > > > FONT-KERNING font glyph-1 glyph-2 method > > Returns the kerning to be applied when typesetting glyph-1 left of > glyph-2. > > DRAW-GLYPH medium font glyph x y method > > [Q3: Interaction with general designs? Ideally we would make glyphs > into designs itself]. > > A text-style is a mapping of chracter sequences to font, glyph, > position triples for drawing. A text-style then might refer to > multiple fonts thus forming a fontset. > > Each medium then knows its available fonts. These can be queried by > the frontend and combined into a text style. > > As you can see there are some questions and I am not entirely sure how > things should really look like. Nor am I. I don't suppose anyone else has had thoughts in the last three years? We need: a way of specifying that we want to draw text using a specific font (in our case, a FreeType font for tablature) at a specific size. If that's not a DEVICE-FONT-TEXT-STYLE, I don't know where else it should go, but it does imply that a DEVICE-FONT has size. I'm away from my workstation, but tomorrow I'll send patches showing what we're currently doing. Cheers, Christophe

1 1

[mcclim-devel] question about presentation method for pathnames
by rpgoldman＠real-time.com 30 Jul '05

30 Jul '05

The presentation method for pathnames is defined this way: (define-presentation-method present (object (type pathname) stream (view textual-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (princ object stream)) At least in one app I've been working on, when I make the default for accepting be a LISP pathname, the system displays the s-expression form, rather than a more intuitive "real" Unix pathname. So I was wondering if it mightn't be better to use namestring than princ. But this won't work in some situations, because the pathname might not be complete (e.g., it's a default, so it has only a directory and a type and no filename). I'm afraid I don't understand pathnames (I only know enough to know that they almost never do what I want!) well enough to understand what would be a good substitute for princ... Thanks, r

1 0

[mcclim-devel] Postscript partial ellipses
by Christophe Rhodes 29 Jul '05

29 Jul '05

Hi, I believe the Postscript backend needs this patch. Is anyone other than us using it at the moment who could check my reasoning? Cheers, Christophe Index: Backends/PostScript/graphics.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp,v retrieving revision 1.12 diff -u -r1.12 graphics.lisp --- Backends/PostScript/graphics.lisp 3 Dec 2004 11:42:43 -0000 1.12 +++ Backends/PostScript/graphics.lisp 29 Jul 2005 15:20:39 -0000 @@ -147,8 +147,11 @@ (cy (point-y center)) (tr (make-transformation ndx2 ndx1 ndy2 ndy1 cx cy)) (circle (untransform-region tr ellipse)) - (start-angle (or (ellipse-start-angle circle) 0)) - (end-angle (or (ellipse-end-angle circle) (* 2 pi)))) + ;; we need an extra minus sign because the rotation + ;; convention for Postscript differs in chirality from the + ;; abstract CLIM convention. -- CSR, 2005-07-29 + (start-angle (or (- (ellipse-end-angle circle)) 0)) + (end-angle (or (- (ellipse-start-angle circle)) (* 2 pi)))) (write-string (if filled "true " "false ") stream) (write-angle stream (if (< end-angle start-angle) (+ end-angle (* 2 pi))

1 0

[mcclim-devel] Re: [Sbcl-devel] Would McCLIM benefit from this pretty printer patch for CMUCL/SBCL?
by Matthias Koeppe 29 Jul '05

29 Jul '05

Raymond Toy <raymond.toy(a)ericsson.com> writes: >>>>>> "Matthias" == Matthias Koeppe <mkoeppe(a)merkur.math.uni-magdeburg.de> writes: > Matthias> Dear McCLIM list, > Matthias> I have worked on a patch for the pretty printer of CMUCL and SBCL that > Matthias> helps support the new presentation-like features of SLIME in > Matthias> conjunction with the pretty printer. > > I'm not familiar with slime's presentations, but I was going to look > into incorporating your patch. > > However, in light of Paolo's comments, I'm holding off until this is > resolved. I have now taken a look at Gilbert Baumann's pretty printer patch (http://bauhh.dyndns.org:8000/mcclim/pprint/) that Paolo pointed out. As far as I can see, the changes there could be easily re-implemented in terms of the more general "annotations" feature implemented in my patch. The only thing that is not covered by my patch is the hooks into START-LOGICAL-BLOCK, END-LOGICAL-BLOCK, PPRINT-LOGICAL-BLOCK. These changes are independent of my patch. (I am including below a new version of the patch for CMUCL that includes docstrings.) Cheers, -- Matthias Koeppe -- http://www.math.uni-magdeburg.de/~mkoeppe diff -u /home/mkoeppe/s/slime/cmucl/pprint.lisp.orig /home/mkoeppe/s/slime/cmucl/pprint.lisp --- /home/mkoeppe/s/slime/cmucl/pprint.lisp.orig 2005-07-21 22:30:50.000000000 +0200 +++ /home/mkoeppe/s/slime/cmucl/pprint.lisp 2005-07-29 00:11:19.000000000 +0200 @@ -109,6 +109,10 @@ ;; ;; Block-start queue entries in effect at the queue head. (pending-blocks nil :type list) + ;; + ;; Queue of annotations to the buffer + (annotations-tail nil :type list) + (annotations-head nil :type list) ) (defun %print-pretty-stream (pstream stream depth) @@ -381,6 +385,10 @@ (enqueue stream tab :sectionp sectionp :relativep relativep :colnum colnum :colinc colinc))) +(defstruct (annotation (:include queued-op)) + (handler (constantly nil) :type function) + (record)) + ;;;; Tab support. @@ -472,6 +480,91 @@ (replace new-buffer buffer :end1 end :end2 end)))))) +;;;; Annotations support. + +(defun enqueue-annotation (stream handler record) + "Insert an annotation into the pretty-printing stream STREAM. +HANDLER is a function, and RECORD is an arbitrary datum. The +pretty-printing stream conceptionally queues annotations in sequence +with the characters that are printed to the stream, until the stream +has decided on the concrete layout. When the characters are forwarded +to the target stream, annotations are invoked at the right position. +An annotation is invoked by calling the function HANDLER with the +three arguments RECORD, TARGET-STREAM, and TRUNCATEP. The argument +TRUNCATEP is true if the text surrounding the annotation is suppressed +due to line abbreviation (see *PRINT-LINES*). +If STREAM is not a pretty-printing stream, simply call HANDLER +with the arguments RECORD, STREAM and nil." + (enqueue stream annotation :handler handler + :record record)) + +(defun re-enqueue-annotation (stream annotation) + "Insert ANNOTATION into the queue of annotations in STREAM." + (let* ((annotation-cons (list annotation)) + (head (pretty-stream-annotations-head stream))) + (if head + (setf (cdr head) annotation-cons) + (setf (pretty-stream-annotations-tail stream) annotation-cons)) + (setf (pretty-stream-annotations-head stream) annotation-cons))) + +(defun re-enqueue-annotations (stream end) + "Insert all annotations in STREAM from the queue of pending +operations into the queue of annotations. When END is non-nil, +stop before reaching the queued-op END." + (loop for tail = (pretty-stream-queue-tail stream) then (cdr tail) + while (and tail (not (eql (car tail) end))) + when (annotation-p (car tail)) + do (re-enqueue-annotation stream (car tail)))) + +(defun dequeue-annotation (stream &key end-posn) + "Dequeue the next annotation from the queue of annotations of STREAM +and return it. Return nil if there are no more annotations. When +:END-POSN is given and the next annotation has a posn greater than +this, also return nil." + (let ((next-annotation (car (pretty-stream-annotations-tail stream)))) + (when next-annotation + (when (or (not end-posn) + (<= (annotation-posn next-annotation) end-posn)) + (pop (pretty-stream-annotations-tail stream)) + (unless (pretty-stream-annotations-tail stream) + (setf (pretty-stream-annotations-head stream) nil)) + next-annotation)))) + +(defun invoke-annotation (stream annotation truncatep) + (let ((target (pretty-stream-target stream))) + (funcall (annotation-handler annotation) + (annotation-record annotation) + target + truncatep))) + +(defun output-buffer-with-annotations (stream end) + "Output the buffer of STREAM up to (excluding) the buffer index END. +When annotations are present, invoke them at the right positions." + (let ((target (pretty-stream-target stream)) + (buffer (pretty-stream-buffer stream)) + (end-posn (index-posn end stream)) + (start 0)) + (loop + for annotation = (dequeue-annotation stream :end-posn end-posn) + while annotation + do + (let ((annotation-index (posn-index (annotation-posn annotation) + stream))) + (write-string buffer target :start start + :end annotation-index) + (invoke-annotation stream annotation nil) + (setf start annotation-index))) + (write-string buffer target :start start :end end))) + +(defun flush-annotations (stream end truncatep) + "Invoke all annotations in STREAM up to (including) the buffer index END." + (let ((end-posn (index-posn end stream))) + (loop + for annotation = (dequeue-annotation stream :end-posn end-posn) + while annotation + do (invoke-annotation stream annotation truncatep)))) + + ;;;; Stuff to do the actual outputting. (defun assure-space-in-buffer (stream want) @@ -541,9 +634,10 @@ force-newlines-p) ((t) ;; Just nuke the whole logical block and make it look like one - ;; nice long literal. + ;; nice long literal. (But don't nuke annotations.) (let ((end (block-start-block-end next))) (expand-tabs stream end) + (re-enqueue-annotations stream end) (setf tail (cdr (member end tail))))) ((nil) (really-start-logical-block @@ -556,7 +650,9 @@ (block-end (really-end-logical-block stream)) (tab - (expand-tabs stream next)))) + (expand-tabs stream next)) + (annotation + (re-enqueue-annotation stream next)))) (setf (pretty-stream-queue-tail stream) tail)) output-anything)) @@ -600,12 +696,16 @@ (if last-non-blank (1+ last-non-blank) 0))))) - (write-string buffer target :end amount-to-print) + (output-buffer-with-annotations stream amount-to-print) + (flush-annotations stream amount-to-consume nil) (let ((line-number (pretty-stream-line-number stream))) (incf line-number) (when (and (not *print-readably*) *print-lines* (>= line-number *print-lines*)) (write-string " .." target) + (flush-annotations stream + (pretty-stream-buffer-fill-pointer stream) + t) (let ((suffix-length (logical-block-suffix-length (car (pretty-stream-blocks stream))))) (unless (zerop suffix-length) @@ -657,8 +757,7 @@ (buffer (pretty-stream-buffer stream))) (when (zerop count) (error "Output-partial-line called when nothing can be output.")) - (write-string buffer (pretty-stream-target stream) - :start 0 :end count) + (output-buffer-with-annotations stream count) (incf (pretty-stream-buffer-start-column stream) count) (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr) (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) @@ -667,9 +766,9 @@ (defun force-pretty-output (stream) (maybe-output stream nil) (expand-tabs stream nil) - (write-string (pretty-stream-buffer stream) - (pretty-stream-target stream) - :end (pretty-stream-buffer-fill-pointer stream))) + (re-enqueue-annotations stream nil) + (output-buffer-with-annotations stream + (pretty-stream-buffer-fill-pointer stream))) ;;;; Utilities.

1 0

[mcclim-devel] Changing items list in list-pane/option-pane
by Paolo Amoroso 29 Jul '05

29 Jul '05

Is there a portable way of changing the list of items in a list-pane or option-pane after it has been created? I mean after it has given an initial value via the :items initarg. Paolo -- Lisp Propulsion Laboratory log - http://www.paoloamoroso.it/log

4 5

[mcclim-devel] postscript streams
by Christophe Rhodes 28 Jul '05

28 Jul '05

Hi, Does it make sense to consider a request to include updating-output-stream-mixin in the superclasses of postscript-stream (in Backends/Postscript/class.lisp)? We have an application which uses updating-output for incremental redisplay, but we would also like to be able to use the same drawing functions (and the same drawing logic, more importantly) without having to implement it twice, once for updating-output streams and once for postscript streams. The below makes sense in our use case. (The alternative of creating a graphical output record and then replaying it on the postscript stream is unattractive because we have a use case with no graphical output at all) Cheers, Christophe Index: Backends/PostScript/class.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/PostScript/class.lisp,v retrieving revision 1.6 diff -u -r1.6 class.lisp --- Backends/PostScript/class.lisp 4 Jul 2002 06:57:43 -0000 1.6 +++ Backends/PostScript/class.lisp 28 Jul 2005 11:31:01 -0000 @@ -60,6 +60,7 @@ permanent-medium-sheet-output-mixin sheet-mute-repainting-mixin mirrored-sheet-mixin ; ? + climi::updating-output-stream-mixin ; ?? standard-extended-output-stream standard-output-recording-stream) ((file-stream :initarg :file-stream :reader postscript-stream-file-stream)

1 1

[mcclim-devel] questions about CLIM interface paradigm
by rpgoldman＠real-time.com 26 Jul '05

26 Jul '05

1. This is a question about using the CLIM interface paradigm that I know should have an obvious answer, but I just don't understand where to find it. Consider that I have a command with some number of arguments > 1. Now, I specify a command with argument types. OK. Now where do I put the procedural information about the mechanics of choosing the arguments? I have done this in an existing application by the somewhat unpleasant expedient of having a command just have a single argument, for the "major" parameter, and then having procedural code that supplies the modifier arguments. E.g., there might be some boolean modifiers, and I provide code that tells CLIM to use a particular way of reading those modifiers. At the end of this UI code, we dispatch to the stuff that does the real work. But this seems wrong. Shouldn't I be able to specify the arguments and their types and have McCLIM Do the Right Thing about reading the additional arguments? E.g., know that a set of radiobuttons might be the right way to collect a multiple-choice modifier argument? 1.a) To get this behavior, should I be writing a bunch of accept methods? 1.b) If so, in an app that has an graphical application-pane and an interactor-pane, should I have one accept method that lets people click on the corresponding presentations (if any) and a separate one that will handle textual input? E.g., if I have objects with names, then the default accept method would allow users to supply an object of the right type by just clicking on it; could I add a second method, specialized for interactor panes, that would allow users to type the name and which would cause CLIM to somehow lookup the corresponding data strucure? And will a simple call to accept allow either form of input? Seems like it would, based on my experience, but I wasn't sure... Does CLIM just invoke ACCEPT on the application frame, and have that call to accept simply invoke ACCEPT on the associated panes? [P.S. shouldn't there be a default method for reading yes or no and returning T or NIL, as with y-or-n-p?] 2. Is it good style to use the Enabled method? Is there a standard for how CLIM should graphically present disablement? My understanding of the current UI dogma is that users should be presented with *all* the alternatives, both enabled and disabled, and that the disabled ones should be presented in some form that makes it clear they are disabled (e.g., pulldown menus with greyed-out alternatives). Not showing the disabled ones leaves the user confused about the facilities offered by the application, and showing the disabled ones w/o cues, leaves the user frustrated. Previously I had a lot of code that would handle inappropriate methods and produce a helpful string or two, but this is repetitive, a blemish on the design, and can be very large if there is a relatively complex condition for enablement.... 3. Is there any reasonable way to handle CERROR in code running inside a CLIM UI? Seems like there should be, but I don't really know how one would go about doing it.... Many thanks, Robert

4 5

[mcclim-devel] drawing a transformed-design using draw-rectangle* says not yet implemented
by Jeremy Rayman 26 Jul '05

26 Jul '05

Hi there. I'm trying to resize an image and show it to the screen. The image loads OK, and before the image is transformed I can use (draw-rectangle* pane 0 0 50 50 :ink image) to show it fine (just clips off the rest). After scaling it, when I try to change the :ink to the new transformed-design, it gives an error "Sorry, not yet implemented". Here's what I'm doing: ;; xpm.lisp is loaded by clim-listener.asd (let* ((image (clim-internals::xpm-parse-file #p"image.xpm")) (transformed-bg (transform-region (make-scaling-transformation 5 5) image))) (draw-rectangle* pane 0 0 50 50 :ink transformed-bg)) ;; if it's :ink image, it shows, just not scaled Sorry, not yet implemented. [Condition of type SIMPLE-ERROR] That error is coming from clim-clx::medium-gcontext (backtrace below). >From mcclim/Backends/CLX/medium.lisp, that func is set up for translation-transformations, but not scaling-transformations. If it's anything but a translation-transformation, it gives an error saying not yet implemented. Here's that function, only the first 5 lines matter: (defmethod medium-gcontext ((medium clx-medium) (ink climi::transformed-design)) (let ((transformation (climi::transformed-design-transformation ink)) (design (climi::transformed-design-design ink))) (unless (translation-transformation-p transformation) (error "Sorry, not yet implemented.")) ;; Bah! (typecase design ((or climi::indexed-pattern climi::rectangular-tile) (multiple-value-bind (tx ty) (transform-position transformation 0 0) (let ((gc-x (round-coordinate tx)) (gc-y (round-coordinate ty)) (gc (design-gcontext medium design))) (setf (xlib:gcontext-ts-x gc) gc-x (xlib:gcontext-ts-y gc) gc-y (xlib:gcontext-clip-x gc) gc-x (xlib:gcontext-clip-y gc) gc-y) gc))) (t (error "You lost, we not yet implemented transforming an ~S." (type-of ink)))))) Since I don't know how to make it handle scaling-transformations, I guess this ends up being a feature request. I asked on irc about it and was told to mail here. If there's a better way to draw my scaled image, I'd love to know. Thanks guys! - Jeremy Rayman jeremy.rayman(a)gmail.com ----------- if anyone needs it: Backtrace: 0: ((SB-PCL::FAST-METHOD CLIM-CLX::MEDIUM-GCONTEXT (CLIM-CLX::CLX-MEDIUM CLIM-INTERNALS::TRANSFORMED-DESIGN)) #<unavailable argument> #<unavailable argument> #<CLIM-CLX::CLX-MEDIUM {4AB116E9}> #<CLIM-INTERNALS::TRANSFORMED-DESIGN {485EC701}>) 1: ((LAMBDA (SB-PCL::.PV-CELL. SB-PCL::.NEXT-METHOD-CALL. SB-PCL::.ARG0. SB-PCL::.ARG1.)) #<unavailable argument> #<unavailable argument> #<CLIM-CLX::CLX-MEDIUM {4AB116E9}> #<CLIM-INTERNALS::TRANSFORMED-DESIGN {485EC701}>) 2: ((SB-PCL::FAST-METHOD CLIM-CLX::MEDIUM-DRAW-RECTANGLE-USING-INK* (CLIM-CLX::CLX-MEDIUM T T T T T T)) #<unavailable argument> #<unavailable argument> #<CLIM-CLX::CLX-MEDIUM {4AB116E9}> #<unavailable argument> 0 0 40 40 T) 3: ((SB-PCL::FAST-METHOD CLIM-INTERNALS::DO-GRAPHICS-WITH-OPTIONS-INTERNAL (MEDIUM T T)) #<unavailable argument> #<unavailable argument> #<CLIM-CLX::CLX-MEDIUM {4AB116E9}> #<CLIM-INTERNALS::SPRITE-PUSH-BUTTON-PANE CLIM-DEMO::CE {4AB008A1}> #<CLOSURE (FLET CLIM-INTERNALS::GRAPHICS-OP) {485EC785}> (:INK #<CLIM-INTERNALS::TRANSFORMED-DESIGN {485EC701}>)) 4: ((FLET #:FN21) #<CLIM-INTERNALS::SPRITE-PUSH-BUTTON-PANE CLIM-DEMO::CE {4AB008A1}>) 5: ((LAMBDA (SB-PCL::.PV-CELL. SB-PCL::.NEXT-METHOD-CALL. SB-PCL::.ARG0. SB-PCL::.ARG1. SB-PCL::.ARG2.)) #<unavailable argument> #<unavailable argument> #<CLIM-INTERNALS::SPRITE-PUSH-BUTTON-PANE CLIM-DEMO::CE {4AB008A1}> #<CLIM-DEMO::CALCULATOR {4AA7CD19}> #:GADGET10920) 6: ((LAMBDA (SB-PCL::.PV-CELL. SB-PCL::.NEXT-METHOD-CALL. SB-PCL::.ARG0. SB-PCL::.ARG1.)) #<unavailable argument> #<unavailable argument> #<CLIM-INTERNALS::SPRITE-PUSH-BUTTON-PANE CLIM-DEMO::CE {4AB008A1}> #<POINTER-ENTER-EVENT {485EC211}>) ...

1 0

[mcclim-devel] New version of :dag graph-formatting patch
by Robert P. Goldman 26 Jul '05

26 Jul '05

This new version provides a layout-graph-nodes method for the :dag graph type. It also makes the code conform better to the specification of :duplicate-test and :duplicate-key argument handling in the CLIM spec. I would be very grateful if people would play with my dag formatting, but realize that it's a long shot if anyone else needs it right now[1], since it only handles merge-duplicates for the acyclic case. Maybe I'll tackle :digraph if I can get this working and accepted! But even if you don't need the :dag graph type, I'd be grateful if you were to test the code to make sure it doesn't break any of your existing uses of the tree type, and I know there must be SOME people using that... Cheers, R Footnotes: [1] Although I think if you were to browse a CLOS inheritance hierarchy, you might want to be able to merge duplicates, and I think that would have to be acyclic... Index: graph-formatting.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/graph-formatting.lisp,v retrieving revision 1.15 diff -u -F^(def -r1.15 graph-formatting.lisp --- graph-formatting.lisp 13 May 2005 03:00:25 -0000 1.15 +++ graph-formatting.lisp 26 Jul 2005 02:34:20 -0000 @@ -163,8 +163,10 @@ (defun format-graph-from-roots (root-obj #'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 +184,40 @@ (defun format-graph-from-root (root &res (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 + (error "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) ()) @@ -242,41 +249,57 @@ (defmethod generate-graph-nodes ((graph- 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 +323,8 @@ (defmethod layout-graph-nodes ((graph-ou (: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 +334,9 @@ (defmethod layout-graph-nodes ((graph-ou (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 +395,121 @@ (defmethod layout-graph-nodes ((graph-ou (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-devel] question about implementation detail in format-graph-from-roots
by rpgoldman＠real-time.com 26 Jul '05

26 Jul '05

Some questions about the implementation details: 1. I was just noticing that the hash-table that is used for duplicate detection is only used in the generate-graph-nodes method, but is kept as a slot in standard-graph-output-record. Is there any reason I shouldn't turn this into a local variable in generate-graph-nodes? I'm concerned that, for large graphs, this could end up being a pretty large piece of uncollectable garbage. It might be even worse if the duplicate-test argument forces us to have a node list instead of a hash-table. I suppose if I do this, then we might get away with not keeping duplicate-test and duplicate-key in the graph-output-record objects, either... 2. Can anyone explain to me why :duplicate-test and :duplicate-key are keyword arguments to generate-graph-nodes but :merge-duplicates is not? Seems odd... 3. The existing code has the following lambda list for FORMAT-GRAPH-FROM ROOTS: (root-objects object-printer inferior-producer &rest graph-options &key stream orientation cutoff-depth merge-duplicates duplicate-key duplicate-test generation-separation within-generation-separation center-nodes (arc-drawer #'clim-internals::standard-arc-drawer) arc-drawing-options graph-type (move-cursor t) &allow-other-keys) then has the following immediately below: (setf stream (or stream *standard-output*) graph-type (or graph-type (if merge-duplicates :digraph :tree)) duplicate-key (or duplicate-key #'identity) duplicate-test (or duplicate-test #'eql) ) Could we have duplicate-key and duplicate-test simply get their defaults in the lambda-list? Or is this not feasible because of the GRAPH-OPTIONS &rest argument? Thanks, Robert

1 0

← Newer
1
...
60
61
62
63
64
65
66
...
82
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-devel