;;; -*- Mode: LISP; Syntax: Common-lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*-
;;;>*********************************************************************
;;;>
;;;> Written by John Aspinall (jga@harlequin.com),
;;;> first at Symbolics, and later at Harlequin.
;;;>
;;;> Symbolics hereby grants permission to customer to incorporate
;;;> the examples in this file in any work belonging to customer.
;;;>
;;;> Harlequin hereby grants permission to customer to incorporate
;;;> the examples in this file in any work belonging to customer.
;;;>
;;;>*********************************************************************
;;; A toy graph editor.
;;; Updated for McCLIM and slightly enhanced and bugfixed by Troels
;;; Henriksen (athas@sigkill.dk) in 2006/12.
(cl:defpackage :simple-grapheditor
(:use :clim-lisp :clim)
(:export #:simple-grapheditor))
(in-package :simple-grapheditor)
(defgeneric draw-self (graph-object stream)
(:documentation "Draw the graph-object to `stream'."))
;;; nodes
(defclass basic-graph-node ()
((x :accessor node-x :initarg :x)
(y :accessor node-y :initarg :y)
(edges :accessor node-edges :initform nil)))
(defun make-node (x y)
(make-instance 'basic-graph-node :x x :y y))
(defgeneric valence (node)
(:method ((node basic-graph-node))
(with-slots (edges) node
(length edges))))
(defun draw-node (x y stream &optional (ink +flipping-ink+))
"Draw the visual representation of a node to `stream' centered
at the given coordinates."
(draw-circle* stream x y 4 :ink ink))
(define-presentation-type node ())
(defmethod draw-self ((node basic-graph-node) stream)
(with-slots (x y) node
(with-output-as-presentation (stream node 'node)
(draw-node x y stream))))
(define-presentation-method highlight-presentation ((type node) record stream state)
(flet ((drawer (record)
(when (graphics-displayed-output-record-p record)
(with-bounding-rectangle* (x1 y1 x2 y2) record
(let ((x (+ (/ (- x2 x1) 2) x1))
(y (+ (/ (- y2 y1) 2) y1)))
(draw-node x y stream (if (eql state :highlight) +red+ +foreground-ink+)))))))
(map-over-output-records #'drawer record)))
;;; edges
(defclass basic-graph-edge ()
((node1 :accessor edge-node1 :initarg :node1)
(node2 :accessor edge-node2 :initarg :node2)))
(defun make-edge (node1 node2)
(let ((e (make-instance 'basic-graph-edge :node1 node1 :node2 node2)))
(push e (node-edges node1))
(push e (node-edges node2))
e))
(defgeneric other-node (edge node)
(:method ((edge basic-graph-edge) node)
(with-slots (node1 node2) edge
(if (eql node1 node) node2 node1))))
(defun draw-edge (x1 y1 x2 y2 stream &optional (ink +flipping-ink+))
(draw-line* stream x1 y1 x2 y2 :ink ink))
(define-presentation-type edge ())
(defmethod draw-self ((edge basic-graph-edge) stream)
(with-slots (node1 node2) edge
(with-output-as-presentation (stream edge 'edge)
(draw-edge (node-x node1) (node-y node1)
(node-x node2) (node-y node2) stream))))
(define-presentation-method highlight-presentation ((type edge) record stream state)
(let ((edge (presentation-object record)))
(flet ((drawer (record)
(when (displayed-output-record-p record)
(with-accessors ((node1 edge-node1)
(node2 edge-node2)) edge
(with-accessors ((x1 node-x) (y1 node-y)) node1
(with-accessors ((x2 node-x) (y2 node-y)) node2
(draw-edge x2 y2 x1 y1 stream (if (eql state :highlight)
+green+
+foreground-ink+))))))))
(map-over-output-records #'drawer record))))
;;; graphs
(defclass graph ()
((nodes :accessor graph-nodes :initarg :nodes)
(edges :accessor graph-edges :initarg :edges)))
(defun make-graph (&optional nodes edges)
(make-instance 'graph :nodes nodes :edges edges))
(defgeneric clear-graph (graph)
(:method ((graph graph))
(with-slots (nodes edges) graph
(setf nodes nil edges nil))))
(defgeneric number-of-nodes (graph)
(:method ((graph graph))
(with-slots (nodes) graph (length nodes))))
(defgeneric number-of-edges (graph)
(:method ((graph graph))
(with-slots (edges) graph (length edges))))
(defgeneric copy-graph (graph)
(:method ((graph graph))
(let ((nodes
(loop for onode in (graph-nodes graph)
collect (make-node (node-x onode) (node-y onode)))))
(flet ((findnode (onode)
(do ((onodes (graph-nodes graph) (cdr onodes))
(nnodes nodes (cdr nnodes)))
((eql onode (car onodes))
(car nnodes)))))
(make-graph nodes
(loop for oedge in (graph-edges graph)
collect (make-edge (findnode (edge-node1 oedge))
(findnode (edge-node2 oedge)))))))))
(defun draw-graph (graph stream)
(with-slots (nodes edges) graph
(dolist (edge edges)
(let ((n1 (edge-node1 edge))
(n2 (edge-node2 edge)))
(draw-edge (node-x n1) (node-y n1) (node-x n2) (node-y n2) stream)))
(dolist (node nodes)
(draw-node (node-x node) (node-y node) stream))))
(defmethod draw-self ((graph graph) stream)
(with-slots (nodes edges) graph
(dolist (edge edges) (draw-self edge stream))
(dolist (node nodes) (draw-self node stream))))
(defgeneric add-node (graph node)
(:method ((graph graph) node)
(with-slots (nodes edges) graph
(pushnew node nodes))))
(defgeneric delete-node (graph node)
(:method ((graph graph) node)
(with-slots (nodes edges) graph
(dolist (edge (node-edges node))
(delete-edge graph edge))
(setf nodes (delete node nodes)))))
(defgeneric add-edge (graph edge)
(:method ((graph graph) edge)
(with-slots (nodes edges) graph
(pushnew edge edges))))
(defgeneric delete-edge (graph edge)
(:method ((graph graph) edge)
(with-slots (edges) graph
(setf (node-edges (edge-node1 edge)) (delete edge (node-edges (edge-node1 edge))))
(setf (node-edges (edge-node2 edge)) (delete edge (node-edges (edge-node2 edge))))
(setf edges (delete edge edges)))))
(defmethod bounding-rectangle* ((graph graph))
(macrolet ((minmaxf (minplace maxplace val)
`(let ((val ,val))
(cond ((< val ,minplace)
(setf ,minplace val))
((> val ,maxplace)
(setf ,maxplace val))))))
(with-slots (nodes) graph
(let* ((node1 (first nodes))
(left (node-x node1))
(right left)
(top (node-y node1))
(bot top))
(dolist (node (rest (graph-nodes graph)))
(minmaxf left right (node-x node))
(minmaxf top bot (node-y node)))
(values left top right bot)))))
(defgeneric identify-nodes (graph node1 node2)
(:method ((graph graph) node1 node2)
(unless (eql node1 node2)
(with-slots (nodes edges) graph
(loop for edge in (node-edges node2)
for onode = (other-node edge node2) do
(cond ((eql onode node1)
(setf (node-edges node1) (delete edge (node-edges node1)))
(setf edges (delete edge edges)))
((find-if #'(lambda (edge3)
(eql (other-node edge3 onode) node1))
(node-edges onode))
(setf (node-edges onode) (delete edge (node-edges onode)))
(setf edges (delete edge edges)))
(t
(push edge (node-edges node1))
(if (eql node2 (edge-node2 edge))
(setf (edge-node2 edge) node1)
(setf (edge-node1 edge) node1)))))
(setf nodes (delete node2 nodes))))))
(defgeneric combine-graphs (graph1 graph2)
(:method ((graph1 graph) (graph2 graph))
(with-slots (nodes edges) graph1
(setf nodes (nconc (slot-value graph2 'nodes) nodes))
(setf edges (nconc (slot-value graph2 'edges) edges)))
graph1))
(defgeneric node-subset (graph predicate)
(:method ((graph graph) predicate)
(with-slots (nodes) graph
(let ((subset nil))
(dolist (node nodes)
(when (funcall predicate node)
(push node subset)))
subset))))
(defun get-nodes-within-rectangle (graph left top right bottom)
(flet ((predicate (node)
(let ((x (node-x node)) (y (node-y node)))
(and (or (null left) (>= x left))
(or (null right) (<= x right))
(or (null top) (>= y top))
(or (null bottom) (<= y bottom))))))
(declare (dynamic-extent #'predicate))
(node-subset graph #'predicate)))
;;; interesting graph creation
(defun make-ring-graph (n &key (radius 100) (center-x 0) (center-y 0))
(let* ((delta-angle (/ (* 2.0 (coerce pi 'single-float)) (float n)))
(sd (sin delta-angle))
(cd (cos delta-angle))
(s 0.0) (c -1.0)
(nodes (loop repeat n
collect (make-node (+ (* radius s) center-x)
(+ (* radius c) center-y))
do (psetq s (+ (* s cd) (* c sd))
c (- (* c cd) (* s sd)))))
(edges (loop with first-node = (first nodes)
for (node1 node2) on nodes
until (null node2)
collect (make-edge node1 node2) into edges
finally (push (make-edge node1 first-node) edges)
(return edges))))
(make-graph nodes edges)))
(defun make-tree-graph (span valence &key (radius 100) (center-x 0) (center-y 0))
(assert (and (integerp span) (plusp span) (integerp valence) (> valence 1)))
(let ((nodes nil) (edges nil) (spi (coerce pi 'single-float)) (branch-depth (floor span 2)))
(labels ((create-node (radius angle)
(let ((node (make-node (+ center-x (round (* radius (sin angle))))
(+ center-y (round (* radius (cos angle)))))))
(push node nodes)
node))
(make-subtree-in-pie-slice (root-node start end split start-depth)
(do* ((delta (/ (- end start) (float split)))
(start start end)
(end (+ start delta) (+ end delta))
(i 0 (1+ i)))
((= i split))
(let ((sub-root (create-node (round (* start-depth radius) branch-depth)
(* (+ start end) 0.5))))
(push (make-edge root-node sub-root) edges)
(when (< start-depth branch-depth)
(make-subtree-in-pie-slice sub-root start end (- valence 1) (+ start-depth 1)))))))
(if (evenp span)
(let ((center-node (create-node 0.0 0.0)))
(make-subtree-in-pie-slice center-node 0.0 (* 2.0 spi) valence 1))
(let* ((c-delta (/ radius branch-depth 2))
(center-node1 (create-node c-delta (* 0.5 spi)))
(center-node2 (create-node c-delta (* 1.5 spi))))
(push (make-edge center-node1 center-node2) edges)
(make-subtree-in-pie-slice center-node1 0.0 spi (- valence 1) 1)
(make-subtree-in-pie-slice center-node2 spi (* 2.0 spi) (- valence 1) 1))))
(make-graph nodes edges)))
;;; interacting with graphs
(defun get-point-while-tracking (pointer-motion-continuation stream)
(declare (dynamic-extent pointer-motion-continuation))
(let ((ox nil) (oy nil))
(with-output-recording-options (stream :draw t :record nil)
(tracking-pointer (stream :context-type nil)
(:pointer-motion (window x y)
(when (eql window stream)
(when ox (funcall pointer-motion-continuation ox oy stream t))
(funcall pointer-motion-continuation x y stream nil)
(setq ox x oy y)))
(:pointer-button-press (event)
(when (eql (event-sheet event) stream)
(funcall pointer-motion-continuation ox oy stream t)
(return-from get-point-while-tracking
(values (pointer-event-x event)
(pointer-event-y event)
(pointer-event-button event)))))))))
(defun get-point-or-object-while-tracking (pointer-motion-continuation stream
&optional (context-type t))
(declare (dynamic-extent pointer-motion-continuation))
(let ((ox nil) (oy nil))
(with-output-recording-options (stream :draw t :record nil)
(tracking-pointer (stream :context-type context-type :highlight t)
(:pointer-motion (window x y)
(when (eql window stream)
(when ox (funcall pointer-motion-continuation ox oy stream t))
(funcall pointer-motion-continuation x y stream nil)
(setq ox x oy y)))
(:presentation (window x y)
(when (eql window stream)
(when ox (funcall pointer-motion-continuation ox oy stream t))
(funcall pointer-motion-continuation x y stream nil)
(setq ox x oy y)))
(:presentation-button-press (presentation event)
(when ox (funcall pointer-motion-continuation ox oy stream t))
(return-from get-point-or-object-while-tracking
(values :object
(pointer-event-x event)
(pointer-event-y event)
(presentation-object presentation)
(pointer-event-button event))))
(:pointer-button-press (event)
(when (eql (event-sheet event) stream)
(when ox (funcall pointer-motion-continuation ox oy stream t))
(return-from get-point-or-object-while-tracking
(values :point
(pointer-event-x event)
(pointer-event-y event)
nil
(pointer-event-button event)))))))))
(defun tracking-add-to-graph (graph start-node stream)
(let ((sx (node-x start-node)) (sy (node-y start-node)))
(flet ((drawer (x y stream erase)
(declare (ignore erase))
(with-drawing-options (stream :ink +flipping-ink+)
(draw-edge x y sx sy stream))))
(declare (dynamic-extent #'drawer))
(let (type nx ny object button node)
(loop
do (multiple-value-setq (type nx ny object button)
(get-point-or-object-while-tracking #'drawer stream 'node))
until (= button +pointer-right-button+)
do (cond ((eql type :point)
(setq node (make-node nx ny))
(add-node graph node)
(draw-self node stream))
(t
(setq node object)))
(let* ((new-edge (make-edge start-node node)))
(add-edge graph new-edge)
(draw-self new-edge stream)
(setq start-node node
sx (node-x node)
sy (node-y node))))))))
(defun tracking-move-node (graph node stream)
(let ((edges (node-edges node)))
(flet ((drawer (x y stream erase)
(declare (ignore erase))
(with-drawing-options (stream :ink +flipping-ink+)
(draw-node x y stream)
(dolist (edge edges)
(let ((onode (other-node edge node)))
(draw-edge x y (node-x onode) (node-y onode) stream))))))
(declare (dynamic-extent #'drawer))
(with-drawing-options (stream :ink +flipping-ink+)
(drawer (node-x node) (node-y node) stream nil))
(multiple-value-bind (type nx ny object)
(get-point-or-object-while-tracking #'drawer stream 'node)
(if (eql type :point)
(setf (node-x node) nx (node-y node) ny)
(identify-nodes graph object node))))))
(defun tracking-move-nodes (graph nodes stream ref-point-x ref-point-y)
graph
(let (moving-edges edges-pinned-at-node1 edges-pinned-at-node2)
(dolist (node nodes)
(dolist (edge (node-edges node))
(let ((onode (other-node edge node)))
(if (member onode nodes)
(pushnew edge moving-edges)
(if (eql onode (edge-node1 edge))
(push edge edges-pinned-at-node1)
(push edge edges-pinned-at-node2))))))
(flet ((drawer (x y stream erase)
(declare (ignore erase))
(let ((xx (- x ref-point-x)) (yy (- y ref-point-y)))
(dolist (node nodes)
(draw-node (+ xx (node-x node)) (+ yy (node-y node)) stream))
(dolist (edge moving-edges)
(let ((node1 (edge-node1 edge))
(node2 (edge-node2 edge)))
(draw-edge (+ xx (node-x node1))
(+ yy (node-y node1))
(+ xx (node-x node2))
(+ yy (node-y node2))
stream)))
(dolist (edge edges-pinned-at-node1)
(let ((node1 (edge-node1 edge))
(node2 (edge-node2 edge)))
(draw-edge (node-x node1)
(node-y node1)
(+ xx (node-x node2))
(+ yy (node-y node2))
stream)))
(dolist (edge edges-pinned-at-node2)
(let ((node1 (edge-node1 edge))
(node2 (edge-node2 edge)))
(draw-edge (+ xx (node-x node1))
(+ yy (node-y node1))
(node-x node2)
(node-y node2)
stream))))))
(declare (dynamic-extent #'drawer))
(with-drawing-options (stream :ink +flipping-ink+)
(drawer ref-point-x ref-point-y stream nil)
(multiple-value-bind (type nx ny)
(get-point-or-object-while-tracking #'drawer stream nil)
(declare (ignore type))
(let ((dx (- nx ref-point-x)) (dy (- ny ref-point-y)))
(dolist (node nodes)
(incf (node-x node) dx)
(incf (node-y node) dy))))))))
;;; the editor
(define-application-frame graphedit ()
((current-graph :initform (make-graph))
(all-graphs :initform nil)
(edges-sensitive-to-add :initform nil))
(:menu-bar nil)
(:panes
(display :application
:display-function 'draw-the-current-graph
:display-after-commands t
:scroll-bars nil)
(menu :command-menu)
(interactor :interactor))
(:layouts
(default-layout
(vertically ()
(9/10 display)
(1/10 (horizontally ()
(3/4 interactor)
(1/4 menu)))))))
(defun draw-the-current-graph (frame stream)
(with-slots (current-graph) frame
(draw-self current-graph stream)))
;;; commands
;;; move things
(define-graphedit-command (com-move-node) ((node 'node :gesture :describe))
(let ((frame *application-frame*))
(with-slots (current-graph) frame
(tracking-move-node current-graph node
(get-frame-pane frame 'display)))))
(define-graphedit-command (com-move-nodes) ((x 'integer) (y 'integer))
(let ((frame *application-frame*))
(with-slots (current-graph) frame
(let* ((display-pane (get-frame-pane frame 'display))
(nodes-to-move
(multiple-value-bind (ll tt rr bb)
(pointer-input-rectangle* :stream display-pane
:left (- x 40) :top (- y 40) :right x :bottom y)
(get-nodes-within-rectangle current-graph ll tt rr bb))))
(if (null nodes-to-move)
(format *standard-input* "~&No nodes selected~%")
(multiple-value-bind (refx refy) (stream-pointer-position display-pane)
(tracking-move-nodes current-graph nodes-to-move display-pane refx refy)))))))
(define-presentation-to-command-translator pick-some-nodes-to-move
(blank-area com-move-nodes graphedit :gesture :describe)
(x y)
`(,x ,y))
;;; create things
(define-graphedit-command (com-create-node) ((x 'integer) (y 'integer))
(let ((frame *application-frame*))
(with-slots (current-graph) frame
(let ((display (get-frame-pane frame 'display))
(new-node (make-node x y)))
(add-node current-graph new-node)
(draw-self new-node display)
(tracking-add-to-graph current-graph new-node display)))))
(define-presentation-to-command-translator pick-a-place-for-a-new-node
(blank-area com-create-node graphedit :gesture :select)
(x y)
`(,x ,y))
(define-graphedit-command (com-create-edge) ((start-node 'node :gesture :select))
(let ((frame *application-frame*))
(with-slots (current-graph) frame
(let ((display (get-frame-pane frame 'display)))
(tracking-add-to-graph current-graph start-node display)))))
;;; delete things
(define-graphedit-command (com-kill-node) ((node 'node :gesture :delete))
(with-slots (current-graph) *application-frame*
(delete-node current-graph node)))
(define-graphedit-command (com-kill-edge) ((edge 'edge :gesture :delete))
(with-slots (current-graph) *application-frame*
(delete-edge current-graph edge)))
(define-graphedit-command (com-clear :menu t) ()
(with-slots (current-graph) *application-frame*
(clear-graph current-graph)))
;;; add interesting graphs
(defun find-open-region-to-insert-graph (frame)
(with-slots (current-graph) frame
(multiple-value-bind (l0 t0 r0 b0)
(bounding-rectangle* (window-viewport (get-frame-pane frame 'display)))
(if (and current-graph (graph-nodes current-graph))
(multiple-value-bind (l1 t1 r1 b1)
(bounding-rectangle* current-graph)
(multiple-value-bind (l2 r2)
(if (> (- l1 l0) (- r0 r1))
(values l0 l1)
(values r1 r0))
(multiple-value-bind (t2 b2)
(if (> (- t1 t0) (- b0 b1))
(values t0 t1)
(values b1 b0))
(values l2 t2 r2 b2))))
(values l0 t0 r0 b0)))))
(defun add-to-current-graph (frame new-graph)
(with-slots (current-graph) frame
(setf current-graph (combine-graphs current-graph new-graph))))
(defun build-ring (frame)
(let (size)
(accepting-values (t :own-window nil)
(setf size (accept '(integer 2) :prompt "Size")))
(multiple-value-bind (le to ri bo)
(find-open-region-to-insert-graph frame)
(add-to-current-graph
frame
(make-ring-graph size
:center-x (floor (+ le ri) 2)
:center-y (floor (+ to bo) 2)
:radius (min (floor (- ri le) 3)
(floor (- bo to) 3)))))))
(defun build-tree (frame)
(let (span valence)
(accepting-values (t :own-window nil)
(setq span (accept '(integer 2) :prompt "Span"))
(terpri)
(setq valence (accept '(integer 2) :prompt "Valence")))
(multiple-value-bind (le to ri bo)
(find-open-region-to-insert-graph frame)
(add-to-current-graph
frame
(make-tree-graph span valence
:center-x (floor (+ le ri) 2)
:center-y (floor (+ to bo) 2)
:radius (min (floor (- ri le) 3)
(floor (- bo to) 3)))))))
(defvar *special-graph-alist*
'(("Tree" :value build-tree)
("Ring" :value build-ring)))
(define-graphedit-command (com-create-special-graph :name "Create" :menu "Create") ()
(let ((frame *application-frame*))
(funcall
(menu-choose *special-graph-alist*)
frame)))
;;; misc
(define-graphedit-command (com-exit-graphedit :name "Exit" :menu "Exit") ()
(frame-exit *application-frame*))
(define-graphedit-command (com-set-options :name "Set Options" :menu "Options") ()
(set-options *application-frame*))
(defun set-options (frame)
(let ((edges-sens (slot-value frame 'edges-sensitive-to-add))
(s *query-io*))
(accepting-values (s :own-window nil :label "Set GraphEdit Options")
(setq edges-sens
(accept 'boolean :stream s :prompt "Edges may be split"
:default edges-sens))
(terpri s))
(setf (slot-value frame 'edges-sensitive-to-add) edges-sens)
(if edges-sens
(setf (command-enabled 'com-split-edge frame) t)
(setf (command-enabled 'com-split-edge frame) nil))))
(defun simple-grapheditor (&key new-process (process-name "Simple Grapheditor")
(width 900) (height 400))
"Creates and runs a Simple Grapheditor frame."
(let ((frame (make-application-frame 'graphedit :width width :height height)))
(flet ((run ()
(run-frame-top-level frame)))
(if new-process
(clim-sys:make-process #'run :name process-name)
(run)))))