#|From - Fri Aug 02 08:20:09 2002
From: Ken Cheetham <cheetham@franz.com>


  Where do I put :default-initargs ??   For example,

They go after the list of slots, as in (untested):

(defclass graph-widget-pane (lisp-widget-window lisp-widget-top-window)
  ((foo :initarg nil)
   (bar :initarg 3))
  (:default-initargs
   :scrollbars t))

  I tried this and got mysterious errors about
  "Error: No methods applicable for generic function
          #<standard-generic-function (setf groupstart)> with args
          (t #<graph-window :graph-window in Listener 1 @ #x211169aa>) of 
    classes (symbol graph-window)"

  So I am obviously not making the proper translation out of widget-land
  and into regular frame  land.

Lots of widget-oriented code in the example would have to come out if
you convert to using "regular" windows.

Since other people have requested similar functionality before, and we
don't have any examples for this sort of thing, and it is generally
useful and extensible, and it demonstrates lots of different CG
features, I decided that there should be a Navigator example for this
type of application.  I've hacked one up tonight and included it
below.  It uses a subclass of a bitmap-window.  It seems to work fine
now, though I'll probably spruce it up a bit more next week at the new
building.  So here is my last creative effort at Berkeley-based Franz.
To try it out, just call (doit), and see the comments at the top.  You
may be able to base your app on this code.

Ken Cheetham                          cheetham@franz.com
Franz Inc.                            Voice: (510) 548-3600 x124
1995 University Avenue, Suite 275     Fax:   (510) 548-8253
Berkeley, CA  94704                   Web:   http://www.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))