#|From - Fri Aug 02 08:20:09 2002
From: Ken Cheetham <cheetham@franz.com>
---------------------------------------------------------------------------
|#
(in-package :cg-user)

;;; Features:
;;; * Right-click the background and select "Add Node" to add a node.
;;; * Left-click a node or link to select it.
;;; * Left-click a node and drag to move it around.
;;; * Left-click a link and drag to reconnect one of its ends.
;;; * Right-click a node for a pop-up that allows you to:
;;;     * Change the node's label or background color.
;;;     * Resize the node.
;;;     * Stretch a new link from that node to another node.
;;;     * Delete the node.
;;; * Right-click a link for a pop that allows you to:
;;;     * Change the thickness or color of the link.
;;;     * Delete the link.

(defun doit ()
  (let* ((window (make-window :node-example
                   :class 'node-window
                   :resizable t
                   :title "Node Example")))
    (add-common-status-bar-to-window window)
    (setf (transparent-character-background (frame-child window)) t)
    window))

(defclass node ()
  ((name :initform nil :initarg :name :accessor name)
   (label :initform nil :initarg :label :accessor label)
   (links :initform nil :accessor links)
   (color :initform nil :initarg :color :accessor color)
   (box :initform nil :initarg :box :accessor node-box)
   (label-margin :initform 3 :initarg :label-margin
                 :accessor label-margin)))

(defclass link ()
  ((name :initform nil :initarg :name :accessor name)
   (node1 :initform nil :initarg :node1 :accessor node1)
   (node2 :initform nil :initarg :node2 :accessor node2)
   (color :initform nil :initarg :color :accessor color)
   (thickness :initform 2 :initarg :thickness :accessor thickness)))

(defclass node-window (bitmap-window)
  ((nodes :initform nil :accessor nodes)
   (links :initform nil :accessor links)
   (selected-node :initform nil :accessor selected-node)
   (selected-link :initform nil :accessor selected-link)))

(defclass node-pane (bitmap-pane)())

(defmethod default-pane-class ((window node-window))
  'node-pane)

(defmethod (setf selected-node) :around (value (window node-window))
  (let* ((old-value (selected-node window)))
    (call-next-method)
    (unless (eq value old-value)
      (when old-value
        (redisplay-node old-value (frame-child window)))
      (when value
        (redisplay-node value (frame-child window))))))

(defmethod (setf selected-link) :around (value (window node-window))
  (let* ((old-value (selected-link window)))
    (call-next-method)
    (unless (eq value old-value)
      (when old-value
        (redisplay-link old-value (frame-child window)))
      (when value
        (redisplay-link value (frame-child window))))))

(defun redisplay-node (node pane)
  (update-node-pane pane (node-box node) t))

(defun redisplay-link (link pane)
  (update-node-pane pane (link-box link)))

(defun link-box (link &optional box)
  "The box containing a link line."
  (unless box (setq box (make-box 0 0 0 0)))
  (with-positions (pos1 pos2)
    (nbox-center (node-box (node1 link)) pos1)
    (nbox-center (node-box (node2 link)) pos2)
    (nmake-box box
      (min (position-x pos1)
           (position-x pos2))
      (min (position-y pos1)
           (position-y pos2))
      (max (position-x pos1)
           (position-x pos2))
      (max (position-y pos1)
           (position-y pos2)))))

(defun node-with-links-box (node)
  "The box containing a node plus all of its link lines."
  (apply 'box-union (node-box node)
         (mapcar 'link-box (links node))))

(defun thing-at-position (node-window position)
  #.(format nil "Returns the node or line (if any) at POSITION ~
                 in the child pane of NODE-WINDOW.")
  (or (dolist (node (nodes node-window))
        (when (inside-box-p position (node-box node))
          (return node)))
      (dolist (link (links node-window))
        (when (on-link-p position link)
          (return link)))))

(defun on-link-p (position link)
  "Returns whether POSITION is on the line of LINK."
  (with-positions (pos1 pos2)
    (on-line-segment-p position
                       (nbox-center (node-box (node1 link)) pos1)
                       (nbox-center (node-box (node2 link)) pos2)
                       :margin 4)))

;;; Hmmm, this non-consing version is missing from CG.
(defun nbox-center (box position)
  "Modifies POSITION to contain the center of BOX."
  (nmake-position position
    (floor (+ (box-left box)(box-right box)) 2)
    (floor (+ (box-top box)(box-bottom box)) 2)))

(defun drag-node (node pane click-pos)
  (let* ((node-box (node-box node))
         (offset-x (- (position-x click-pos)
                      (box-left node-box)))
         (offset-y (- (position-y click-pos)
                      (box-top node-box)))
         (node-width (box-width node-box))
         (node-height (box-height node-box))
         (previous-mouse-pos (copy-position click-pos))
         (previous-region (node-with-links-box node))
         (mouse-pos (make-position 0 0))
         region)
    (loop
      (unless (logtest left-mouse-button (mouse-button-state))
        (return))
      (process-pending-events)
      (unless (position= (ncursor-position pane mouse-pos)
                         previous-mouse-pos)
        (nmake-box-relative (node-box node)
          (- (position-x mouse-pos) offset-x)
          (- (position-y mouse-pos) offset-y)
          node-width node-height)
        (setq region (node-with-links-box node))
        (update-node-pane pane (box-union previous-region region))
        (ncopy-position previous-mouse-pos mouse-pos)
        (ncopy-box previous-region region)))))

(defmethod mouse-left-down ((pane node-pane) buttons position)
  (declare (ignore buttons))
  (let* ((window (parent pane))
         (object (thing-at-position window position)))
    (typecase object
      (node (if* (wait-for-drag)
               then (drag-node object pane position)
               else (setf (selected-node window) object)))
      (link (if* (wait-for-drag)
               then (drag-link object pane position)
               else (setf (selected-link window) object)))
      (t (setf (selected-node window) nil)
         (setf (selected-link window) nil)))))

(defun drag-link (link pane position)
  (let* ((window (parent pane))
         (node1 (node1 link))
         (node2 (node2 link))
         (pos1 (box-center (node-box node1)))
         (pos2 (box-center (node-box node2)))
         (drag2 (< (+ (abs (- (position-x pos2)
                              (position-x position)))
                      (abs (- (position-y pos2)
                              (position-y position))))
                   (+ (abs (- (position-x pos1)
                              (position-x position)))
                      (abs (- (position-y pos1)
                              (position-y position))))))
         (new-pos (get-line pane (if drag2 pos1 pos2)))
         new-node)
    (when new-pos
      (setq new-node (thing-at-position window new-pos))
      (when new-node
        (cond ((eq new-node (if drag2 node1 node2))
               (window-message window
                   "You can't connect a node to itself."))
              ((eq new-node (if drag2 node2 node1))
               (window-message window
                   "You put it back where it was already, dude."))
              ((let* ((old-node (if drag2 node1 node2)))
                 (dolist (link (links new-node))
                   (when (or (eq (node1 link) old-node)
                             (eq (node2 link) old-node))
                     (return t))))
               (window-message window "Those nodes are already connected."))
              (t (delete-link pane link)
                 (add-link window new-node (if drag2 node1 node2)
                           :thickness (thickness link)
                           :color (color link))))))))
    
(defun menu-printer (symbol)
  (nsubstitute
   #\space #\-
   (capitalize-object symbol)))

(defmethod mouse-right-down ((pane node-pane) buttons position)
  (declare (ignore buttons))
  (let* ((window (parent pane))
         (object (thing-at-position window position)))
    (typecase object
      (node (case (pop-up-lettered-menu
                   '(:change-label :change-color :resize-node
                                   :connect-to-node :delete-node)
                   :sortp nil
                   :on-print 'menu-printer)
              (:change-label (change-label pane object))
              (:change-color (change-color pane object))
              (:resize-node (resize-node pane object))
              (:delete-node (delete-node pane object))
              (:connect-to-node (connect-to-node pane object))))
      (link (case (pop-up-lettered-menu
                   '(:change-thickness :change-color :delete-link)
                   :sortp nil
                   :on-print 'menu-printer)
              (:change-thickness (change-thickness pane object))
              (:change-color (change-color pane object))
              (:delete-link (delete-link pane object))))
      (t (case (pop-up-lettered-menu
                '(:add-node)
                :sortp nil
                :on-print 'menu-printer)
           (:add-node (add-node pane position)))))))

(defun change-label (pane node)
  (with-boxes (box1)
    (let* ((margin (label-margin node))
           (label (edit-in-place
                   pane
                   :box (inflate-box (ncopy-box box1 (node-box node))
                                     (- margin)(- margin))
                   :string (or (label node) "")
                   :justification :center
                   :background-color (color node))))
      (when label
        (setf (label node) label)
        (update-node-pane pane (node-box node) t)))))
    
(defun add-node (pane position)
  (let* ((half-width 40)
         (half-height 25)
         (x (position-x position))
         (y (position-y position))
         (node (make-instance 'node
                 :name (gensym-sequential-name :node)
                 :box (make-box (- x half-width)
                                (- y half-height)z
                                (+ x half-width)
                                (+ y half-height)))))
    (push node (nodes (parent pane)))
    (update-node-pane pane (node-box node))))

(defun resize-node (pane node)
  (let* ((old-box (node-box node))
         (old-box-with-links (node-with-links-box node))
         (new-box (progn (erase-contents-box pane old-box)
                    (get-box pane nil nil
                             (box-top-left old-box)))))
    (when new-box
      (setf (node-box node) new-box)
      (update-node-pane
       pane (box-union old-box-with-links
                       (node-with-links-box node))))))
  
(defun delete-node (pane node)
  (let* ((window (parent pane)))
    (when (eq node (selected-node window))
      (setf (selected-node window) nil))
    (dolist (link (links node))
      (delete-link pane link))
    (setf (nodes window)(delete node (nodes window)))
    (update-node-pane pane (node-box node))))

(defun connect-to-node (pane node)
  (let* ((window (parent pane))
         (new-pos (get-line pane (box-center (node-box node))))
         new-node)
    (when new-pos
      (setq new-node (thing-at-position window new-pos))
      (when new-node
        (cond ((eq new-node node)
               (window-message pane
                   "You can't connect a node to itself."))
              ((dolist (link (links node))
                 (when (or (eq (node1 link) new-node)
                           (eq (node2 link) new-node))
                   (return t)))
               (window-message pane
                   "Those two nodes are already connected."))
              (t
               (add-link window node new-node)))))))

(defun add-link (window node1 node2 &key thickness color)
  (let* ((link (make-instance 'link
                 :name (gensym-sequential-name :link)
                 :node1 node1
                 :node2 node2)))
    (when thickness (setf (thickness link) thickness))
    (when color (setf (color link) color))
    (push link (links node1))
    (push link (links node2))
    (push link (links window))
    (update-node-pane (frame-child window)
                      (link-box link))
    ))

(defun delete-link (pane link)
  (let* ((update-region (link-box link))
         (window (parent pane))
         (node1 (node1 link))
         (node2 (node2 link)))
    (when (eq link (selected-link window))
      (setf (selected-link window) nil))
    (setf (links node1)(delete link (links node1)))
    (setf (links node2)(delete link (links node2)))
    (setf (links window)(delete link (links window)))
    (update-node-pane pane update-region)))

(defun change-thickness (pane link)
  (let* ((new (ask-user-for-choice
               "Select a new line thickness."
               :~1 :~2 :~3 :~5 "Link Thickness" (parent pane))))
    (when new
      (setf (thickness link)
        (case new (:~1 1)(:~2 2)(:~3 3)(:~5 5)))
      (update-node-pane pane (link-box link)))))

(defmethod change-color (pane (node node))
  (let* ((new (pop-up-menu
               (open-menu
                (list
                 (make-instance 'menu-item
                   :title "Green"
                   :value (make-rgb :red 128 :green 255 :blue 128))
                 (make-instance 'menu-item
                   :title "Yellow"
                   :value yellow)
                 (make-instance 'menu-item
                   :title "White"
                   :value white))
                'pop-up-menu (screen *system*)))))
    (when new
      (setf (color node) new)
      (update-node-pane pane (node-box node) t))))

(defmethod change-color (pane (link link))
  (let* ((new (pop-up-menu
               (open-menu
                (list
                 (make-instance 'menu-item
                   :title "Blue"
                   :value (make-rgb :blue 200))
                 (make-instance 'menu-item
                   :title "Green"
                   :value (make-rgb :green 170))
                 (make-instance 'menu-item
                   :title "Black"
                   :value black))
                'pop-up-menu (screen *system*)))))
    (when new
      (setf (color link) new)
      (update-node-pane pane (link-box link)))))

(defun update-node-pane (pane &optional box no-links)
  (unless box (setq box (visible-box pane)))
  (let* ((window (parent pane)))
    
    ;; Draw only on the unseen backing store, for
    ;; a non-flashing refresh from there to the pane.
    (with-delayed-redraw (pane :invalidate nil)
      
      ;; Clear the background.
      (erase-contents-box pane box)
      
      ;; Draw links first so that will be drawn "under" any nodes
      ;; that they happen to cross.
      (with-clipping-box (pane box)
        (unless no-links
          (with-boxes (box1)
            (dolist (link (links window))
              
              ;; For efficiency, draw only the links that intersect
              ;; the region that needs to be refreshed.
              (when (box-intersect-p (link-box link box1) box)
                (draw-link link pane)))))
        
        ;; Draw the nodes that intersect the refresh region.
        (draw-nodes-recursively (nodes window) pane box)))
    (invalidate pane :box box)))
  
(defun draw-nodes-recursively (nodes pane update-box)
  ;; This is supplied to draw the nodes from last to first
  ;; without consing, so that the last-drawn node (which
  ;; will appear on top) will be the first one that a
  ;; mouse click sees.
  (when nodes
    (draw-nodes-recursively (rest nodes) pane update-box)
    (when (box-intersect-p (node-box (first nodes)) update-box)
      (draw-node (first nodes) pane))))

(defun draw-link (link pane)
  (let* ((window (parent pane)))
    (with-foreground-color
        (pane (if (eq link (selected-link window))
                  red ;; selection color
                (or (color link) black)))
      (with-line-width (pane (thickness link))
        (with-positions (pos1 pos2)
          (draw-line
           pane
           (nbox-center (node-box (node1 link)) pos1)
           (nbox-center (node-box (node2 link)) pos2)))))))

(defun draw-node (node pane)
  (let* ((window (parent pane))
         (box (node-box node))
         (label (label node))
         (name (name node))
         (margin (label-margin node)))
    (with-foreground-color
        (pane (if (eq node (selected-node window))
                  #.(make-rgb :red 255 :green 128 :blue 128)
                (or (color node) white)))
      (fill-box pane box))
    
    ;; Draw the node's label, defaulting to its name.
    (when (or label name)
      (with-boxes (box1)
        (draw-string-in-box
         pane (or label (symbol-name name)) nil nil
         (inflate-box (ncopy-box box1 box)
                      (- margin)(- margin))
         :center :top nil t)))
    
    ;; Move the right and bottom edges in by one pixel
    ;; so that the box border will be drawn completely
    ;; "inside" its node-box.
    (with-boxes (box1)
      (ncopy-box box1 box)
      (decf (box-right box1))
      (decf (box-bottom box1))
      
      (draw-box pane box1))))

(defvar *thing-in-status-bar* nil)

(defmethod mouse-moved ((pane node-pane) buttons position)
  (declare (ignore buttons))
  (call-next-method) ;; Allow the cursor to be set
  (let* ((window (parent pane))
         (object (thing-at-position window position)))
    (unless (eq object *thing-in-status-bar*)
      (setq *thing-in-status-bar* object)
      (window-message window "~a" (or object "")))))

(defmethod print-object ((object node) stream)
  (print-unreadable-object (object stream :type nil
                                   :identity *print-escape*) ;; bug11786
    (format stream "~a ~a at ~a" 
      (type-of object)
      (name object)
      (node-box object))))

(defmethod print-object ((object link) stream)
  (print-unreadable-object (object stream :type nil
                                   :identity *print-escape*) ;; bug11786
    (format stream "~a ~a from ~a to ~a" 
      (type-of object)
      (name object)
      (name (node1 object))
      (name (node2 object)))))

(defun on-line-segment-p (position end1 end2 &key (margin 2))
  
  ;; Returns whether POSITION is "on" the line segment from
  ;; position END1 to position END2, within a MARGIN of error
  ;; of a few pixels.  The default mousing-margin of 2
  ;; provides a 5-pixel range in the horizontal direction for
  ;; a more-nearly-vertical line, or in the vertical direction
  ;; for a more-nearly-horizontal line.
  (when (position= end1 end2)
    (error "The two endpoint arguments were equivalent in a ~
            call to on-line-segment-p.  This is not allowed."))
  (let* ((xp (position-x position))(yp (position-y position))
         (x1 (position-x end1))(y1 (position-y end1))
         (x2 (position-x end2))(y2 (position-y end2))
         (xmin (min x1 x2))(ymin (min y1 y2))
         (xmax (max x1 x2))(ymax (max y1 y2)))
    (and (<= xmin xp xmax)
         (<= ymin yp ymax)
         (if* (> (- xmax xmin)(- ymax ymin))
            then (<= (abs (- yp (+ y1 (round (* (- xp x1)(- y2 y1))
                                             (- x2 x1)))))
                     margin)
            else (<= (abs (- xp (+ x1 (round (* (- yp y1)(- x2 x1))
                                             (- y2 y1)))))
                     margin)))))




;;;-*- mode: common-lisp; -*-
;;  Defining a simple dialog item widget in lisp.
;; edit a graph by moving nodes.  

;; Operation:  set up a graph in the global variables
;; *nodes*  and *edges*  
;; See circular-graph for example on setting up nodes.
;; See make-all-edges for example on setting up edges.

;; Then call (run-graph) to display the graph.

;; To move a node and at the same time change the *nodes* and *edges*
;; variables,
;; (a)  press and hold down left mouse button. 
;;      The cursor will fly to the nearest node. OR Bezier control point
;; (b) move the mouse cursor to the new location.
;;     The graph will be redrawn with the new node location.

;; When you are through, click in the [x] box.

;; Extra parameters you can change
;; *shownodelabels* (default t) will display labels near each node. nil= don't show
;; *gwide*  is the width of the line for edge display
;; *gpointradius* is the size of the circle used for a node.

;; I have made the edges blue, the nodes red, and the labels on nodes black.
;; These too could be made parameters.


(in-package :cg-user)

;; The graph widget class.
(defclass graph-widget (lisp-widget)
  ())

(defclass graph-widget-pane (lisp-widget-window lisp-widget-top-window)
  ;; Using dialog-item as the initarg will set this slot.
  ((item :accessor pane-item :initform nil :initarg :dialog-item 
	 )))

;;needed
(defmethod widget-device ((item graph-widget) dialog)
  (declare (ignore dialog))
  ;; Tell the dialog-item class which widget-window class it
  ;; should instantiate.
  'graph-widget-pane)

#+ignore ;;;
(defmethod device-open ((widget-window graph-widget-pane) options)
  ;; Call this function to actually create the widget's window.
  ;; Additional code could be added here to perform other
  ;; desired side effects when creating the window.
;;  (open-lisp-widget-window widget-window '(:scrollbars t))
   (open-lisp-widget-window widget-window options)

  ;; Return the widget-window.
  widget-window)

(eval-when (compile load)(declaim (special *edges* *nodes* *selected-node*)))
(defvar *nodecount* 0)
(defvar *edgecount* 0)
(defstruct graph (nodes (make-hash-table)) (edges  nil)
	   (name (format nil "~a~a" "g" (incf *graphcount*))))

(defstruct node  
  (name (format nil "~a~a" "n" (incf *nodecount*)))
  (loc nil)) ;; loc will be a position in common-graphics terms
  
(defstruct edge  
  (name (format nil "~a~a" "e" (incf *edgecount*)))
  (control nil);; list of ALL control points for Bezier curve including start/end
  (start nil) ;; optional: start node LABEL
  (end nil) ;; optional: end node LABEL
 )

(defparameter *gwide* 2) ;; width of a line
(defparameter *gpointradius* 2)
(defparameter *shownodelabels* t)
(defparameter *showbezier* t)
(defparameter *selected-node* nil)
(defparameter *hilite* t) ;if t, highlight last selected node/edges
(defparameter *polyline* nil) ;; if *polyline* is t then use line segments for edges

(defmethod redisplay-window ((window graph-widget-pane) &optional box)
  (declare (ignore box)
	   (special *edges* *nodes* *shownodelabels*))
  (call-next-method) ;; Draw the blank background
  (seb window *edges*)
  (show-nodes-labels window *nodes* *shownodelabels*)
  t)

;; we need some design to do some of this:
;; (a) create a new node and join it to other nodes.
;; (b) rubber-band lines for new edges?  
;; (c) signal completion of the graph, send it back for other processing
;; (d) delete a line
;; (e) delete a (disconnected) node
;; (f) move a node and the connecting lines
;; (g) bend a line 
;; either use the representation for GML used by graphlet (probably not)
;; or record all the same information but in a lispish form, wiht easy
;; translation.  e.g.
#| ;; gml version.  something like this
graph [
version 2
directed 1
node_style [ name "default_node_style" style [ graphics [ w 16.0 h 16.0]]]...
node[ id 23 label "1" graphics [x 322 y 430 w 14 h 15] ...
edge [source 26 target 32 graphics [arrow "last"]  ...

;; lisp version something like this??
;; need to have a text version that maxima etc can show
;; as well as the displayed version.

(graph :version 2 :directed 1 :node_style ...
       :nodes ' ( (node :id 23 :label "1" :graphics '(box :x 322 :y 430 :w :h))
		  )
       :edges '((edge :source 26 :target :32 :graphics '(arrow "last")) ...))
|#

;; (h)  what else?

(defmethod mouse-left-down ((window graph-widget-pane) buttons data)
  (declare (ignore buttons)(special *nodes* *edges* *selected-node*))
  ;; jump the mouse cursor to the nearest control point
  (let ((mindist 1.0e10)
	(minnode data)
	(newdist 0.0))
    ;;; look through the control points
    (dolist (q *edges*)
      (dolist (p (edge-control q)) ;for each control point
      (setf newdist (d2 data p)); see if is closer to mouse
      (if (< newdist mindist)
	  (setf mindist newdist minnode p))))
    ;; This next line jumps the mouse location to the nearest node
    (setf (cursor-position window) minnode)
    (setf *selected-node* minnode)))



(defmethod mouse-left-up ((window graph-widget-pane) buttons data)
  (declare (ignore buttons data))
  ;(move-node *selected-node* (position-x data)(position-y data))
  (invalidate window)
  (update-window window)
  ;;(format t "~% mouse left up, buttons=~s, data=~s" buttons data)
 
)

(defmethod resize-window :after ((window graph-widget-pane) position)
   ;; If the user resizes the graph widget, invalidate it so that it
   ;; will be completely redrawn at the new window size.
   (declare (ignore position))
   (invalidate window))







;; This is the on-initialization function.  As such, it returns a window
;; such that when the window is closed, the example is considered to
;; be terminated.
;;
(defun run-graph (&key graph)
   
   (if (and graph (parent graph))
      (remove-component graph (parent graph))
      ;; else create graph widget
      ;;
      (setq graph (make-instance 'graph-widget
                     :name :graph-widget
                     :value 0
                     :left 0 :top 0 :width 800 :height 600
                     :right-attachment :right
                     :bottom-attachment :bottom
		     :scrollbars t  ;; does nothing??
                     )))
   
   
   ;; return the window.
   (make-window :graph-widget-test
     :widgets (list graph)
     :class 'dialog 
     :owner (development-main-window *system*)
     :interior (make-box 50 50 500 500)
     :scrollbars t
     :title "Line graphing Test"))


(defun distance-pl(p l)
  ;; distance from a point to a line (ie. edge)
  ;; assumes STRAIGHT LINE.
  (let* ((s (car(edge-control l)))		;start of line
	 (e (cadr(edge-control l)))		;end of line
	 (x0 (position-x p))
	 (y0 (position-y p))
	 (x2 (position-x s))
	 (y2 (position-y s))
	 (x1 (position-x e))
	 (y1 (position-y e))
	 (mx21 (- x2 x1))
	 (my21 (- y2 y1))
	 (denom (float(sqrt (+ (* mx21 mx21)(* my21 my21)))))
	 (sp (d4 x0 y0 x2 y2))		;start to p
	 (se (d4 x0 y0 x1 y1))		;end to p
	 (mind (min sp se)))		; min dist to start or end
    (declare (fixnum x0 y0 x1 y1 x2 y2 my21 my21))
    (if (= denom 0.0) mind		; perp distance
      (min mind
	   (/ (abs (- (* my21 (- x0 x1)) (* mx21 (- y0 y1))))
		  denom)))
 ))
;;http://mathworld.wolfram.com/Point-LineDistance2-Dimensional.html
;; distance.

(defun d2(p1 p2) ;distance between points.
  (let ((z1 (- (position-x p1)(position-x p2)))
	(z2 (- (position-y p1)(position-y p2))))
    (sqrt (+ (* z1 z1)(* z2 z2)))))

(defun d4(a b c d) ;faster?
  (let ((z1 (- a c))
	(z2 (- b d)))
    (declare (fixnum a b c d z1 z2))
    (sqrt (+ (* z1 z1)(* z2 z2)))))  
    


#+run-example
(run-graph)

;; draw a string x in a box at position pos in window pw.
;; pos will be at upper left corner. Useful for labeling a graph

(defun ds(pw x pos )(let* ((lh (line-height pw))
			   (lwidth (position-x(stream-string-size pw x)))
			   (low (+ 2(position-y pos) lh))
			   (right(+ 2(position-x pos) lwidth))
			   (box (make-box (position-x pos)
					  (position-y pos)
					  right low)))
		      (with-foreground-color (pw black)
			(with-background-color (pw yellow)
			(setf (line-width pw )1)
			(draw-string-in-box pw x 0 (length x) box :center :center)
			(draw-box pw box)))))



#| a design idea.  Have each widget do something very specific.
Forget the menu stuff.

rearrange(graph1);

spews out the graph into a window. It is not possible to
create or delete nodes.  Just move them around. Select a
node by left down.  move it until left up.  When you
are done, close the window with the [X] box in upper right
of window. the result
will be returned to lisp, with the new locations remembered.

addnodes(graph1); 

left-down creates a node. drag to another node. Let go.
How to name them?  perhaps just number them? Ask the
user for names?  Rename labels later??
keep doing it until [X]

deleteedges(graph1); 
click on node, node  to delete an edge.

|#


(defvar *graphcount* 0)

;; the next two programs are undefined because I don't know what kind
;; of representation as lisp lists or maxima objects would be useful.
;;

;;(defun graph-to-list(g)	)		; make a lisp list version of graph g
  
;;(defun list-to-graph(l))			;make a graph structure from a lisp list of data


;; make the points for a circular graph of count items with center/radius
;; The jth point is at exp(2*pi*i*j/count) in complex plane.
;; scale it and center it.

(defun circular-graph(count &key (center (make-position 200  200))
				 (radius 150))
  (let ((ctr (complex (position-x center) (position-y center)))
	(twopi (* 2 pi))
	(result nil))
  (dotimes (j count result)
    (let ((loc (+ ctr (* radius (exp (complex 0 (/ (* twopi j) count)))))))
      (push  (make-node :loc (make-position (round (realpart loc)) (round (imagpart loc))))
	     result)))))

;; show-nodes displays each node in xlist in the window.
;; the nodes are small red circles, as written.
;; the circles are of radius *gpointradius*.
;; labels for the points may also be displayed by calling
;; show-nodes-labels

(defun show-nodes-labels(window xlist &optional (shownodelabels t)) ;; show labels too
  (with-foreground-color (window red)
    (with-positions (p1)
      (dolist (p xlist)
	(draw-circle window (node-loc p) *gpointradius*))
      (if shownodelabels
	  (dolist (p xlist)
		  (ds window (node-name p)(node-loc p))))))
    xlist)

;; given a list of nodes, make a list of edges consisting
;; of all possible connections (undirected)
(defun make-all-edges(xlist)		; xlist is a list of nodes
  (let ((result nil))
  (do ((j xlist (cdr j)))
      ((null j) result)
    (do ((k (cdr j)(cdr k)))
	((null k) )
      (push (make-edge :control 
		       (list(node-loc (car j))(node-loc (car k)))
		       :start (node-name (car j))
		       :end (node-name (car k))
		       ) result)))))


(defun make-all-edges-bez(xlist)		; xlist is a list of nodes
  (let ((result nil))
  (do ((j xlist (cdr j)))
      ((null j) result)
    (do ((k (cdr j)(cdr k)))
	((null k) )
;      (print (list (node-name (car j))(node-name (car k))))
      (push (make-edge
	     :start (node-name (car j))
		       :end (node-name (car k))

		       :control (make-bezier (car j)(car k) 2)) result)))))

(defun draw-edge(win points)
  (if (and (not *polyline*) (cddr points))			; more than 2
      (draw-curve win points)		; bezier
    (draw-polyline win points)))

;; display on window each of the edges in elist.
;; this program display all edges in blue.

(defun seb(window elist);; show-edges-bezier
  (setf (line-width window) *gwide*)
  (with-foreground-color
   (window blue)
   (dolist (e elist);; for each of the edges e in the list
       (draw-edge window (edge-control e))
       (cond (*showbezier* 
	    ;;  (show-bezier-points window (edge-control e))
	      (setf (foreground-color window) green) ;why not with-f..?
	      (with-foreground-color (window green)
		(dolist (q (edge-control e)) ;a list of positions
		  (draw-circle window q *gpointradius* )))
	   ;   (format t "~%window color is ~s"(foreground-color window))
	      (setf (foreground-color window) blue)
	      ))
     
     (cond (*hilite*
	    (setf (foreground-color window) red) ;change color
	      (dolist (e elist)
		(if ;; selected node in edge, then redisplay it
		    (member *selected-node* (edge-control e))
		    (progn 
		      (draw-edge window (edge-control e))
		      (dolist (q (edge-control e)) ;a list of positions
		      (draw-circle window q *gpointradius* )))))
	      (setf (foreground-color window) blue))))))

;; oddly sets foreground color to black?
(defun show-bezier-points(window pointlist)
  (with-foreground-color (window green)
      (dolist (q pointlist) ; for each edge, look for bezier points
	(draw-circle window q *gpointradius*))))

(defun make-bezier(p1 p2 &optional (n 1)) 
  ;; draw 3*n+1 total control pts
  ;; these are all on a straight line.
  (let* ((startx (position-x(node-loc p1)))
	 (starty (position-y(node-loc p1)))
	 (endx (position-x(node-loc p2)))
	 (endy (position-y(node-loc p2)))
	 (divnum (* 3 n))
	 (deltax (/(float (- endx startx)) divnum))
	 (deltay (/(float (- endy starty))divnum))
	 (curve nil)
	 (x endx)
	 (y endy))
    (push (node-loc p2) curve);identical node for end
    (dotimes (j (1- divnum))
      (setf x (round (- x deltax)))
      (setf y (round (- y deltay)))
      (push (make-position x y) curve))
    (push (node-loc p1) curve) ;identical node for start
    curve))
    
;; just rewrite x,y coords of a point to move it, and all refs to it!
(defun move-node (old newx newy)(nmake-position old newx newy))

;; while moving the mouse with the left button down, repeatedly reformat the
;; graph and redisplay. THIS IS THE RUBBER-BAND METHOD

(defmethod mouse-moved ((window graph-widget-pane) buttons data)
  (declare (special *selected-node*))
  (cond ((logtest left-mouse-button buttons)
	 (setf *selected-node*
	   (move-node *selected-node* (position-x data)(position-y data)))
	 (invalidate window))
	(t (call-next-method)) ;; change cursor, do other things..
	))

(defparameter *nodes* (circular-graph 8))
(defparameter *edges* (make-all-edges-bez *nodes*))
;; or just straight lines
;(defparameter *edges* (make-all-edges *nodes*))

;; put nodes in a rectangular mesh, connect to nearest neighbors.
(defun nodearray(n m &optional (space 75)(offset 20)); n rows each of m items
  (let ((nodes nil)(edges nil)
	(arr (make-array (list  m n))))
    (dotimes (i m)
      (dotimes (j n) 
	(setf (aref arr i j	)
	      (make-node :name (format nil "a~s,~s" j i)
			 :loc (make-position (+ offset (* i space))
					     (+ offset (* j space)))))))

    (dotimes (i m)(dotimes (j n)(push (aref arr i j) nodes)))
    
    (dotimes (i  m)
      (dotimes(j(1- n))
	(push (make-edge :start (aref arr i j)
			 :end (aref arr i (1+ j))
			 :control 
			 ;; for straight lines, uncomment line below
			 ;;(list (node-loc (aref arr i j))(node-loc(aref arr i (1+ j))))
			 ;; and comment out next line. Also same for next loop
			 
			 (make-bezier (aref arr i j)(aref arr i (1+ j)))
			 ) edges)))
    (dotimes (i (1- m))
      (dotimes(j n)
	(push (make-edge :start (aref arr i j)
			 :end (aref arr (1+ i) j)
			 :control 
			 ;;(list (node-loc (aref arr i j)) (node-loc(aref arr (1+ i) j)))
			 (make-bezier (aref arr i j)(aref arr (1+ i)  j))
			 ) edges)))
    (values nodes edges)))

;; to use this, try
;;    (multiple-value-setq (*nodes* *edges*)(nodearray 3 4))