mcclim-devel July 2005

mcclim-devel@common-lisp.net

19 participants
28 discussions

[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

[mcclim-devel] question about CLIM spec [format-graph-from-roots]
by rpgoldman＠real-time.com 26 Jul '05

26 Jul '05

AFAICT, the CLIM spec doesn't say anything about what are the acceptable values for the DUPLICATE-TEST argument to FORMAT-GRAPH-FROM-ROOTS (although it does specify that the default value is EQL). This seems very unfortunate. If we were to be limited to the conventional equality test values, then we would be able to use a hash-table to store the graph nodes. However, if the spec permits arbitrary functions of two arguments, that seems to make use of hash-tables impossible. Am I overlooking something? Is this a deficiency in the spec? thanks, R

4 5

[mcclim-devel] Layers and packages
by Duncan Rose 24 Jul '05

24 Jul '05

> More as an exercise to improve my understanding of CLIM than anything > else, I've drawn an overview of the different CLIM layers with the > general groupings for functionality found in the specification. > > I thought I'd post it here because > > a) others might find it interesting / useful > b) I have a couple of questions about it ;-) > > In the diagram the stone coloured part contains 'system' level > functionality. Things that aren't part of CL, but aren't really part > of CLIM either. > > The blue parts are areas that the back ends need to worry about. > The orange parts are things that I'm not sure are in the right layer. > The layers go from most specific / closest to the hardware at the top > to the most abstract at the bottom. > The 'arrows' (does anybody know how to draw real arrows in > Appleworks?) show the relationships between the packages; more > abstract packages use functionality defined in less abstract packages. > > Questions: > > 1. Can anybody think of instances where less abstract layers (in the > diagram) have dependencies on 'more' abstract layers? Specifically I'm > thinking that input editing might have a dependency on command > processing. > > 2. Which layers should the orange bits be in? I'm particularly unhappy > with the position of the menu, dialog and pane functionality. I'm > think that the first two should perhaps be in the ADAPTIVE layer, and > the last one maybe should be in the 'McSILICA' layer. > > -Duncan

2 1

[mcclim-devel] Poor man's CLIM text style selection dialog
by Paolo Amoroso 24 Jul '05

24 Jul '05

As a CLIM learning exercise, and as a way of finally contributing back something even remotely useful to the CLIM community, I have written the attached text style selection dialog. I have tested it with McCLIM and CMUCL under Linux, but it should work with little or no modification with other CLIM implementations. The dialog provides the same features of the CLIM text style model. See for example make-text-style in the specification. To invoke the dialog, just compile the file and evaluate: (clim-user::select-text-style) from a listener, or call it from your own code. When you click on "OK", the function returns a CLIM text style object, nil otherwise. The usage of the dialog should be straightforward, except for a couple of issues. When you enter a numeric text size in the appropriate field (try 2 or 60 for fun), hit ENTER to update the sample text. The family/face/size gadgets are not updated. See the code for additional information or issues. The main problem is that I shouldn't have written it in the first place: CLIM provides the powerful accepting-values macro for creating dialogs. McCLIM, however, supports only part of its functionality and can be used in simple cases. The bottom line is that my code is an example of how to fake a value-returning modal dialog, provides an interim solution, and gives an appreciation of the power and complexity of accepting-values. Paolo -- Lisp Propulsion Laboratory log - http://www.paoloamoroso.it/log

1 0

[mcclim-devel] (no subject)
by Robert P. Goldman 23 Jul '05

23 Jul '05

1 0

[mcclim-devel] Poor man's print dialog
by Paolo Amoroso 22 Jul '05

22 Jul '05

The KDE Linux desktop environment provides a standard dialog for printing a document to a printer, faxing it, generating a PDF/PostScript file or emailing a PDF file. This functionality is accessible from the shell via the `kprinter' command, which accepts a PostScript file from stdin. I tried to use kprinter with McCLIM's PostScript backend and CMUCL Snapshot 2005-07 (19B) under Slackware Linux 10.0 with code like this: ;;; Requires CMUCL and KDE (in-package :clim-user) (define-application-frame kprinter () () (:panes (display :application :scroll-bars t :display-function 'display-graphics)) (:layouts (default display))) (defun display-graphics (frame stream) (declare (ignore frame)) (draw-rectangle* stream 20 50 120 100 :filled t :ink +red+) (draw-circle* stream 220 150 30 :filled t :ink +green+) (draw-text* stream "CLIMz rulez" 320 250 :text-size :huge :ink +blue+)) (define-kprinter-command (com-quit :menu t :name t) () (frame-exit *application-frame*)) (define-kprinter-command (com-print :menu t :name t) () (let* ((process (ext:run-program "kprinter" nil :input :stream :wait nil)) (process-stream (ext:process-input process))) (unwind-protect (with-output-to-postscript-stream (stream process-stream) (display-graphics *application-frame* stream)) (finish-output process-stream) (ext:process-close process) (ext:process-wait process t)))) (defun print-dialog () (run-frame-top-level (make-application-frame 'kprinter :width 550 :height 350))) This doesn't work as expected. If I confirm the dialog with the "Print" button, the print jobs is correctly generated, but the McCLIM application freezes and I have to abort the session. If I dismiss the dialog with "Cancel", I get this error: * (clim-user::print-dialog) Error in function UNIX::SIGPIPE-HANDLER: SIGPIPE at #x4011EC58. [Condition of type SIMPLE-ERROR] Restarts: 0: [ABORT] Return to application command loop 1: Return to Top-Level. Debug (type H for help) (UNIX::SIGPIPE-HANDLER #<unused-arg> #<unused-arg> #.(SYSTEM:INT-SAP #x3FFFC5A0)) Source: Error finding source: Error in function DEBUG::GET-FILE-TOP-LEVEL-FORM: Source file no longer exists: target:code/signal.lisp. 0] backtrace 0: (UNIX::SIGPIPE-HANDLER #<unused-arg> #<unused-arg> #.(SYSTEM:INT-SAP #x3FFFC5A0)) 1: (UNIX::SIGPIPE-HANDLER 3 #<unused-arg> #<unused-arg> #.(SYSTEM:INT-SAP #x3FFFC5A0))[:EXTERNAL] 2: ("call_into_lisp+#x8C [#x805529C] cmucl") 3: ("funcall3+#x29 [#x805508D] cmucl") 4: ("interrupt_handle_now+#xFF [#x8050A03] cmucl") 5: ("NIL+#x8050E1B [#x8050E1B] cmucl") 6: ("NIL+#x4007A0A8 [#x4007A0A8] /lib/libc.so.6") 7: (LISP::DO-OUTPUT #<Stream for descriptor 7> #.(SYSTEM:INT-SAP #x4030C000) 0 3972 ...) 8: (LISP::FLUSH-OUTPUT-BUFFER #<Stream for descriptor 7>) 9: (LISP::FD-STREAM-MISC-ROUTINE #<Stream for descriptor 7> :FINISH-OUTPUT NIL #<unused-arg>) 10: (FINISH-OUTPUT #<Stream for descriptor 7>) 11: ((FLET #:G0 CLIM-POSTSCRIPT::INVOKE-WITH-OUTPUT-TO-POSTSCRIPT-STREAM))[:CLEANUP] 12: (CLIM-POSTSCRIPT::INVOKE-WITH-OUTPUT-TO-POSTSCRIPT-STREAM #<Function (FLET #:G26 CLIM-USER::COM-PRINT) {58D0D9B1}> #<Stream for descriptor 7> :DEVICE-TYPE NIL ...) 13: (CLIM-USER::COM-PRINT) 14: ((METHOD CLIM:DEFAULT-FRAME-TOP-LEVEL NIL (CLIM:APPLICATION-FRAME)) (#() . #(# # # # # ...)) #<unused-arg> #<CLIM-USER::KPRINTER {58143915}> NIL) 15: ("LAMBDA (.KEYARGS-START. .VALID-KEYS. G5411)" #<unused-arg> #<unused-arg> #<CLIM-USER::KPRINTER {58143915}> NIL) 16: ((METHOD CLIM:RUN-FRAME-TOP-LEVEL NIL (CLIM:APPLICATION-FRAME)) (#(20) . #()) #<unused-arg> #<CLIM-USER::KPRINTER {58143915}> #<unused-arg>) 17: ((METHOD CLIM:RUN-FRAME-TOP-LEVEL (:AROUND) (CLIM:APPLICATION-FRAME)) (#(16 15) . #(#)) #S(PCL::FAST-METHOD-CALL :FUNCTION #<Function # {116ABFF9}> :PV-CELL (# . #) :NEXT-METHOD-CALL NIL :ARG-INFO (1 . T)) #<CLIM-USER::KPRINTER {58143915}> NIL) 18: (INTERACTIVE-EVAL (CLIM-USER::PRINT-DIALOG)) 19: (LISP::%TOP-LEVEL) 20: ((LABELS LISP::RESTART-LISP SAVE-LISP)) 0] Is there any way of returning control back to the McCLIM application after printing? There's probably something fundamental about spawning external processes and their I/O streams I don't understand. Paolo -- Lisp Propulsion Laboratory log - http://www.paoloamoroso.it/log

1 0

[mcclim-devel] little patch when using clx+MacOSX
by Nicolas Sceaux 20 Jul '05

20 Jul '05

Hi there I'm running SBCL 0.9, with telent clx 0.7, on Mac OS X.4, with Apple's X11, mcclim from CVS. In order to run the demos, I had to make the attached change. When $DISPLAY is not set, (get-environment-variable "DISPLAY") returns NIL, and thus a condition is raised when calling (POSITION #\/ NIL) in the next form. nicolas

1 0

[mcclim-devel] LAYOUT-GRAPH-NODES patch for DAG graph type...
by rpgoldman＠real-time.com 19 Jul '05

19 Jul '05

META DISCUSSION: Are the maintainers of McCLIM OK with me rooting around in the code for graph formatting? I readily confess I'm not a serious graphics hacker, but I need to debug a lot of code that uses DAGs, and I'd like to see this pushed along... Does anyone have the time and patience to give patches like this a cursory once-over and either hurl abuse or commit them? NOTES ON CODE: I have had a first shot at making a graph layout method for DAGs. This is a little brittle, but since if you try to format-graph-from-roots with :dag as the :graph-type, it will just crash McCLIM, maybe that's not too bad ;-) Rather than trying to build a new graph layout method ab initio, I have simply adapted Gilbert's original code. As far as I could tell, when laying out one level of the graph, Gilbert's code would look ahead, and try to allocate space for the next layer. My code keeps that structure, but just lets nodes go to the first place where the fit, rather than thinking hard about who their "tree parent" should be. Ugliness: 1. Interested code readers will see some ugliness in the handling of the DUPLICATE-TEST and DUPLICATE-KEY arguments to FORMAT-GRAPH-FROM-ROOTS. For some reason, these are pulled out of the argument list and thrown away rather than being given as initargs to the GRAPH-OUTPUT-RECORD that's created by FORMAT-GRAPH-FROM-ROOTS. I'm not sure why this was done. Since I'm ignorant about this code, instead of arrogating it to myself to add them to the STANDARD-GRAPH-OUTPUT-RECORD, I simply added DUPLICATE-TEST and DUPLICATE-KEY slots to the DAG-GRAPH-OUTPUT-RECORD type. Unless someone can see a reason why not, though, I would argue for pushing them up to STANDARD-GRAPH-OUTPUT-RECORD. (Or possibly doing a minor refactoring that would split STANDARD-GRAPH-OUTPUT-RECORD into TREE-GRAPH-OUTPUT-RECORD and NON-TREE-GRAPH-OUTPUT record, only the latter being allowed to have DUPLICATE-TEST and DUPLICATE-KEY.) Because I didn't want to muck with the current graph-output-record classes, I ended up with some ugliness in FORMAT-GRAPH-FROM-ROOTS argument handling. This could easily be removed, if the above change is accepted. 2. Per my earlier email, I arrogated it to myself to limit the set of permissible values for the duplicate-test keyword arg of FORMAT-GRAPH-FROM-ROOTS. I think that this is reasonable, but it arguably violates the CLIM spec. On the other hand, I think that McCLIM already does this --- there are some comments by GB to that effect at the head of hte file... 3. There's a little oddity in Gilbert's code where he seems to take a vector data structure and wham it into a list in order to be able to use MAP over it. I'm inclined to whack it into an array loop, but if someone thinks that would be really wrong, I'd like to hear. Cheers, Robert Patch file: 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 18 Jul 2005 22:41:54 -0000 @@ -164,7 +164,11 @@ (defun format-graph-from-roots (root-obj (find-graph-type graph-type) nil :hash-table (make-hash-table :test duplicate-test) - graph-options)))) + (append + (when (and (eq graph-type :dag) merge-duplicates) + (list :duplicate-test duplicate-test + :duplicate-key duplicate-key)) + 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) @@ -210,7 +214,17 @@ (defclass tree-graph-output-record (stan ()) (defclass dag-graph-output-record (standard-graph-output-record) - ()) + ((duplicate-key + :initarg :duplicate-key + :reader duplicate-key + ) + (duplicate-test + :initarg :duplicate-test + :reader duplicate-test + :documentation "The DUPLICATE-TEST of a DAG-GRAPH-OUTPUT-RECORD +should be one of the :TEST values acceptable to MAKE-HASH-TABLE." + ) + )) (defclass digraph-graph-output-record (standard-graph-output-record) ()) @@ -300,6 +314,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 +325,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 +386,126 @@ (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 + duplicate-key + 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 (duplicate-test graph-output-record))) + (parent-hash (make-hash-table :test (duplicate-test graph-output-record)))) + (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) + ;; the following is possibly unnecessary --- it + ;; would only be a win if the key-value is + ;; expensive to compute. [2005/07/18:rpg] + (let ((key-value (funcall duplicate-key node))) + (unless (gethash key-value visited) + (setf (gethash key-value visited) depth) + (when parent + (setf (gethash key-value 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] with-output-as-gadget
by Christophe Rhodes 14 Jul '05

14 Jul '05

Hello, What's the status of with-output-as-gadget? At the listener, (clim:with-output-as-gadget (*standard-output*) (clim:with-look-and-feel-realization ((clim:frame-manager clim:*application-frame*) clim:*application-frame*) (clim:labelling (:label "Hello")))) gets me (interestingly) /half/ a label -- the top half, to be precise. Meanwhile, attempts to do something a bit more interesting, such as (clim:with-output-as-gadget (*standard-output*) (clim:with-look-and-feel-realization ((clim:frame-manager clim:*application-frame*) clim:*application-frame*) (clim:labelling (:label "Hello") (clim:make-pane 'clim:text-field :activate-callback (lambda (g) (princ (clim:gadget-value g))))))) give me NO-APPLICABLE-METHOD on sheet-native-transformation when called with an argument of NIL, so presumably something's not getting initialized properly (whose fault is that? Mine or McCLIM's? :) (This question is motivated by the potential for implementing UI elements of forms in the closure web browser -- see <http://common-lisp.net/project/closure/> -- with clim gadgets; as far as I can tell, this is a theoretical perfect match, but if there's a reason that this is a bad idea, that would be good to know too.) Cheers, Christophe

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-devel July 2005