Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv20167/Examples Modified Files: demodemo.lisp Added Files: draggable-graph.lisp Log Message: Andy Hefner's code for keeping track of graph edges, and demo code for draggable graphs. I've been running with this for about a year now, and I'm bored of having to snip it out of diffs all the time. (Also add the drag-and-drop-translator demo to demodemo) --- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/03/29 10:43:43 1.8 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/04/10 09:48:40 1.9 @@ -63,7 +63,9 @@ (make-demo-button "Gadget Test" 'gadget-test) (make-demo-button "Drag and Drop" 'dragndrop) (make-demo-button "Colorslider" 'colorslider) - (make-demo-button "Goatee Test" 'goatee::goatee-test))) + (make-demo-button "Goatee Test" 'goatee::goatee-test) + (make-demo-button "D&D Translator" 'drag-test) + (make-demo-button "Draggable Graph" 'draggable-graph-demo))) (labelling (:label "Tests") (vertically (:equalize-width t) (make-demo-button "Label Test" 'label-test) --- /project/mcclim/cvsroot/mcclim/Examples/draggable-graph.lisp 2006/04/10 09:48:41 NONE +++ /project/mcclim/cvsroot/mcclim/Examples/draggable-graph.lisp 2006/04/10 09:48:41 1.1 ;;; -*- Mode: Lisp; Package: CLIM-DEMO -*- ;;; (c) copyright 2005 by ;;; Andy Hefner (ahefner@gmail.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) ;;; Demo of draggable graph nodes (define-application-frame draggable-graph-demo () () (:pane (make-pane 'application-pane :width :compute :height :compute :display-function 'generate-graph :display-time t))) (defun generate-graph (frame pane) (format-graph-from-roots (list (find-class 'number)) (lambda (object stream) (present (clim-mop:class-name object) (presentation-type-of object) :stream stream)) #'clim-mop:class-direct-subclasses :stream pane)) (defun record-parent-chain (record) (and record (cons record (record-parent-chain (output-record-parent record))))) (defun find-graph-node (record) "Searches upward until a graph node parent of the supplied output record is found." (find-if #'graph-node-output-record-p (record-parent-chain record))) (defun node-edges (node) (let (edges) (maphash (lambda (child edge) (declare (ignore child)) (push edge edges)) (slot-value node 'climi::edges-from)) (maphash (lambda (parent edge) (declare (ignore parent)) (push edge edges)) (slot-value node 'climi::edges-to)) edges)) (defun redisplay-edges (graph edges) (dolist (edge edges) (with-slots (climi::from-node climi::to-node) edge (climi::layout-edge-1 graph climi::from-node climi::to-node)))) ;;; (AH) McCLIM bug of the day: ;;; ;;; (I haven't looked in detail at the spec or McCLIM to confirm my ;;; assumptions here, but as I understand things..) CLIM regions are ;;; immutable. Output records ARE mutable. A McCLIM output record can ;;; be used as a rectangular region corresponding to its bounding ;;; rectangle. But this bounding rectangle is not immutable! So, ;;; region operations such as region-union may build a rectangle-set ;;; capturing the mutable output-record object, violating the ;;; immutability of regions and causing widespread panic and ;;; confusion. (defun stupid-copy-rectangle (region) (with-bounding-rectangle* (x0 y0 x1 y1) region (make-rectangle* x0 y0 x1 y1))) (define-draggable-graph-demo-command (com-drag-node) ((record t) (x 'real) (y 'real)) (let* ((graph-node (find-graph-node record)) (edges (node-edges graph-node)) (erase-region (stupid-copy-rectangle (reduce (lambda (x &optional y) (if y (region-union x y) x)) edges)))) (multiple-value-bind (px py) (output-record-position graph-node) (let ((graph (output-record-parent graph-node)) (x-offset (- x px)) (y-offset (- y py))) (assert (typep graph 'graph-output-record)) (erase-output-record graph-node *standard-output*) (dolist (edge edges) (clear-output-record edge)) (when edges (repaint-sheet *standard-output* erase-region)) (multiple-value-bind (final-x final-y) (drag-output-record *standard-output* graph-node :erase-final t :finish-on-release t) (setf (output-record-position graph-node) (values (- final-x x-offset) (- final-y y-offset))) (add-output-record graph-node graph) (redisplay-edges graph edges) (repaint-sheet *standard-output* graph-node)))))) (define-presentation-to-command-translator record-dragging-translator (t com-drag-node draggable-graph-demo :tester ((presentation) (find-graph-node presentation))) (presentation x y) (list presentation x y)) ;;; (CSR) This demo code is quite cool; visually, it's a little ;;; disconcerting to have the edges disappear when dragging, but ;;; that's acceptable, though I think it might be possible to preserve ;;; them by having a feedback function for the call to ;;; DRAG-OUTPUT-RECORD.