;; Copyright (C) 1996 DIMACS Center, Rutgers, The State University of New Jersey
;; Author(s): Jonathan Berry
;; This software is copyrighted by the DIMACS Center at Rutgers, The State
;; University of New Jersey.  IT IS PROVIDED AS IS, AND THE AUTHORS, DIMACS, AND
;; RUTGERS, THE STATE UNIVERSITY OF NEW JERSEY  DISCLAIM
;; ALL LIABILITY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL
;; DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
;; DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
;; POSSIBILITY OF SUCH DAMAGE.
;; THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
;; IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
;; NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
;; MODIFICATIONS.
;; The authors hereby grant permission to use, copy, modify, distribute,
;; and license this software and its documentation for any purpose, provided
;; that existing copyright notices are retained in all copies and that this
;; notice is included verbatim in any distributions. No written agreement,
;; license, or royalty fee is required for any of the authorized uses.
;; Modifications to this software may be copyrighted by their authors
;; and need not follow the licensing terms described here, provided that
;; the new terms are clearly indicated on the first page of each file where
;; they apply.
;; Last File Update: 7-Aug-1997
;; 
(require "Tk-classes")
(require "Entry")
(require "Scrollbar")
(require "Listbox")

(define *link:newly-loaded-graph* #f)
(define *link:file-listbox-toplevel* #f)	; these are a hack - don't allow
(define *link:file-listbox* #f)		; multiple graph-views their own
(define *link:file-entry-toplevel* #f)	; file listboxes
(define *link:file-listbox-label* #f)
(define *link:file-entry* #f)
(define *link:file-listbox-label2* #f)
(define *link:file-entry2* #f)
(define *link:file-listbox-label3* #f)
(define *link:file-entry3* #f)
(define (reset-file-listbox)
   (set! *link:file-listbox-toplevel* #f)	; these are a hack - don't allow
   (set! *link:file-listbox* #f)		; multiple graph-views their own
   (set! *link:file-entry-toplevel* #f)	; file listboxes
   (set! *link:file-listbox-label* #f)
   (set! *link:file-entry* #f)
   (set! *link:file-listbox-label2* #f)
   (set! *link:file-entry2* #f)
   (set! *link:file-listbox-label3* #f)
   (set! *link:file-entry3* #f))
(define *link:double-entry* 0)
(define *link:double-entry2* 0)
(define *link:double-entry3* 0)
(define *link:integer-entry* 0)
(define *link:integer-entry2* 0)
(define *link:integer-entry3* 0)
(define *link:string-entry* 0)
(define *link:string-entry2* 0)
(define *link:string-entry3* 0)
(define *link:msg-window-toplevel* #f); information window with 'ok' button
(define *link:msg-window-label* "")
(define (reset-msg-window)
   (set! *link:msg-window-toplevel* #f); information window with 'ok' button
   (set! *link:msg-window-label* ""))
(define *link:ans-window-toplevel* #f) ; window used to give answers to 
(define *link:ans-window-label* "")    ; predicates
(define (reset-ans-window)
   (set! *link:ans-window-toplevel* #f) 
   (set! *link:ans-window-label* ""))
(define *link:ftype* "helvetica")
(define *link:fstyle* "r")
(define *link:vertex-size* "r")
(define *link:fwgt* "medium")
(define *link:point-size* "18")
(define *link:default-vertex-color* "blue")
(define *link:default-edge-color* "black")
(define *link:default-vertex-size* 10)
(define *link:default-edge-width* 2)
(define (msg-window-ok-button msg-window)
    (catch (destroy msg-window))
    (reset-msg-window))
(define (link-msg msg-text msg-window msg-label)
	(catch (destroy msg-label))
	(set! msg-label (make <label> :parent msg-window
						:side 'bottom
						:text msg-text))
	(pack msg-label))
(define (msg-window msg func)
	(catch (destroy *link:msg-window-toplevel*))
	(set! *link:msg-window-toplevel*
			(make <toplevel> :title "LINK Message Window"))
	(link-msg msg *link:msg-window-toplevel* *link:msg-window-label*)
	(pack (make <button> :parent *link:msg-window-toplevel*
		 :text "ok" 
		 :command 
		  (lambda ()
			(if func (func))
			(msg-window-ok-button *link:msg-window-toplevel*))))
)
(define (ans-window msg func)
	(catch (destroy *link:ans-window-toplevel*))
	(set! *link:ans-window-toplevel*
			(make <toplevel> :title "LINK Answer Window"))
	(link-msg msg *link:ans-window-toplevel* *link:ans-window-label*)
	(pack (make <button> :parent *link:ans-window-toplevel*
		 :text "ok" 
		 :command 
		  (lambda ()
			(if func (func))
			(msg-window-ok-button *link:ans-window-toplevel*))))
)


(define (update-vertex-label new-v old-v)
        (slot-set! (vertex-item new-v) 'vertex-label
                   (find-string-attribute 'label old-v)))

(define (update-edge-label new-e old-e)
        (slot-set! (edge-item new-e) 'edge-label
                   (find-string-attribute 'label old-e)))

(define (update-labels gv old-g)
        (let* ((new-g (graph gv))
               (old-edges (mset-edge->list (edges old-g)))
               (new-edges (mset-edge->list (edges new-g)))
               (new-vertices (set-vertex->list (vertices new-g)))
               (old-vertices (set-vertex->list (vertices old-g))))
           (map update-edge-label new-edges old-edges)
           (map update-vertex-label new-vertices old-vertices)))

(define (graph-load-file-listbox gv)
	  (let*((fn (make-file-box "Load graph" "*.g"))
	        (g (if fn (load-graph fn) #f)))
	    (if g (begin (replace-graph g gv) 
			 (update-labels gv g)
                         (update-visible-attributes gv))
		  #f)))

;(define (graph-file-listbox gv)
;	(set! *link:file-listbox-toplevel*  
;				(make <toplevel> :title "File Selection"))
;	(set! *link:file-listbox* (make <Scroll-listbox> 
;			:parent *link:file-listbox-toplevel* 
;			:value (append (glob "*.g") (glob "*.dimacs"))))
;	(set! *link:file-listbox-label* 
;			(make <label> :parent *link:file-listbox-toplevel*
;						:side 'bottom
;						:text "Enter Graph Name"))
;	(set! *link:file-entry* 
;			(make <entry> :parent *link:file-listbox-toplevel*
;						:value 'g
;						:side 'bottom))
;      	(pack *link:file-listbox*)
;      	(pack *link:file-listbox-label*)
;      	(pack *link:file-entry*)
;	(bind (slot-ref *link:file-listbox* 'listbox)  "<Double-1>"
;	    (lambda(w x y)
;	       (let ((f (selection 'get)))
;		   (cond (((string->regexp ".*\.dimacs") f)
;			      (set! *link:newly-loaded-graph* 
;				      (load-dimacs-graph f))
;			      (replace-graph *link:newly-loaded-graph* gv))
;		         (((string->regexp ".*\.g") f)
;			      (set! *link:newly-loaded-graph* 
;				      (load-graph f))
;			      (replace-graph *link:newly-loaded-graph* gv))))
;		(destroy *link:file-listbox-toplevel*)
;		;; break to avoid calling bindings for listbox
;		'break))
;)
(define-macro (str s)
        `(string-append "cat |" ,s))

(define (graph->postscript gv fname)
	(with-output-to-file fname
		 (lambda() (display (postscript (slot-ref gv 'graph-canvas))))
	)
)
;(define-macro (graph->postscript gv fname)
;        `(let* ((c (slot-ref ,gv 'graph-canvas))
;              (cmd (with-output-to-file (string-append "| cat > " ,fname)
;                        (lambda() 
;				  (display (postscript c))))))
;          cmd))


(define (edge-item-set-crds ei)
        (let* ((es (car (slot-ref ei 'seg-list)))
               (e  (edge ei))
               (crds (slot-ref es 'coords))
               (wcrds (view-to-world (car crds) (cadr crds) (graph-view ei))))
            (set-double-attribute! 'x (car wcrds) e)
            (set-double-attribute! 'y (cadr wcrds) e)
        )
)

(define (graph-save-file-listbox gv)
          (map edge-item-set-crds (edges gv))
	  (save-graph (graph gv) (make-file-box "Save graph")))

(define (save-graph-entry gv file-ext)
	(set! *link:file-listbox-toplevel*  
				(make <toplevel> :title "Save Graph"))
	(set! *link:file-listbox-label* 
			(make <label> :parent *link:file-listbox-toplevel*
						:side 'bottom
						:text "Enter Filename"))
	(set! *link:file-entry* 
			(make <entry> :parent *link:file-listbox-toplevel*
						:value (string-append 
							(slot-ref gv 'title) 
							file-ext)
						:side 'bottom))
      	(pack *link:file-listbox-label*)
      	(pack *link:file-entry*)
	(bind *link:file-entry* "<Return>"
	    (lambda(w x y)
	       (let ((f (value *link:file-entry*)))
		   (cond ((equal? file-ext ".dimacs")
			      (save-dimacs-graph (slot-ref gv 'graph) f))
		         ((equal? file-ext ".g")
			      (save-graph (slot-ref gv 'graph) f))
			 (#t  (graph->postscript gv f))
		    ))
		(destroy *link:file-listbox-toplevel*)
		;; break to avoid calling bindings for listbox
		'break))
)

(define (string-entry-ok-button)
    (if *link:file-entry*
    	(set! *link:string-entry* (value *link:file-entry*))
    	(set! *link:string-entry* #f))
    (if *link:file-entry2*
    	(set! *link:string-entry2* (value *link:file-entry2*))
    	(set! *link:string-entry2* #f))
    (if *link:file-entry3*
    	(set! *link:string-entry3* (value *link:file-entry3*))
    	(set! *link:string-entry3* #f))
    (destroy *link:file-listbox-toplevel*)
    (reset-file-listbox))
(define (string-entry prompt def-value func)
	(catch (destroy *link:file-listbox-toplevel*))
	(set! *link:file-listbox-toplevel*  
				(make <toplevel> :title "String Entry"))
	(set! *link:file-listbox-label* 
			(make <label> :parent *link:file-listbox-toplevel*
						:side 'bottom
						:text prompt))
	(set! *link:file-entry* 
			(make <entry> :parent *link:file-listbox-toplevel*
						:value def-value
						:side 'bottom))
      	(pack *link:file-listbox-label*)
      	(pack *link:file-entry*)
	(pack (make <button> :parent *link:file-listbox-toplevel*
				 :text "ok" 
				 :command (lambda () (string-entry-ok-button)
						     (func))))
)
(define (double-string-entry prompt prompt2 def-value def-value2 func)
	(catch (destroy *link:file-listbox-toplevel*))
	(set! *link:file-listbox-toplevel*  
				(make <toplevel> :title "String Entry"))
	(set! *link:file-listbox-label* 
			(make <label> :parent *link:file-listbox-toplevel*
						:side 'bottom
						:text prompt))
	(set! *link:file-entry* 
			(make <entry> :parent *link:file-listbox-toplevel*
						:value def-value
						:side 'bottom))
	(set! *link:file-listbox-label2* 
			(make <label> :parent *link:file-listbox-toplevel*
						:side 'bottom
						:text prompt2))
	(set! *link:file-entry2* 
			(make <entry> :parent *link:file-listbox-toplevel*
						:value def-value2
						:side 'bottom))
      	(pack *link:file-listbox-label*)
      	(pack *link:file-entry*)
      	(pack *link:file-listbox-label2*)
      	(pack *link:file-entry2*)
	(pack (make <button> :parent *link:file-listbox-toplevel*
				 :text "ok" 
				 :command (lambda () 
						     (string-entry-ok-button)
						     (func))))
)
(define (triple-string-entry prompt prompt2 prompt3 
			    def-value def-value2 def-value3 func)
	(catch (destroy *link:file-listbox-toplevel*))
	(set! *link:file-listbox-toplevel*  
				(make <toplevel> :title "String Entry"))
	(set! *link:file-listbox-label* 
			(make <label> :parent *link:file-listbox-toplevel*
						:side 'bottom
						:text prompt))
	(set! *link:file-entry* 
			(make <entry> :parent *link:file-listbox-toplevel*
						:value def-value
						:side 'bottom))
	(set! *link:file-listbox-label2* 
			(make <label> :parent *link:file-listbox-toplevel*
						:side 'bottom
						:text prompt2))
	(set! *link:file-entry2* 
			(make <entry> :parent *link:file-listbox-toplevel*
						:value def-value2
						:side 'bottom))
	(set! *link:file-listbox-label3* 
			(make <label> :parent *link:file-listbox-toplevel*
						:side 'bottom
						:text prompt3))
	(set! *link:file-entry3* 
			(make <entry> :parent *link:file-listbox-toplevel*
						:value def-value3
						:side 'bottom))
      	(pack *link:file-listbox-label*)
      	(pack *link:file-entry*)
      	(pack *link:file-listbox-label2*)
      	(pack *link:file-entry2*)
      	(pack *link:file-listbox-label3*)
      	(pack *link:file-entry3*)
	(pack (make <button> :parent *link:file-listbox-toplevel*
				 :text "ok" 
				 :command (lambda () (string-entry-ok-button)
						     (func))))
)
(define (double-entry-ok-button)
    (if *link:file-entry*
    	(set! *link:double-entry* (value *link:file-entry*))
    	(set! *link:double-entry* #f))
    (if *link:file-entry2*
    	(set! *link:double-entry2* (value *link:file-entry2*))
    	(set! *link:double-entry2* #f))
    (if *link:file-entry3*
    	(set! *link:double-entry3* (value *link:file-entry3*))
    	(set! *link:double-entry3* #f))
    (if (and (string? *link:double-entry*) 
	     (not (number? (string->number *link:double-entry*)))) 
			(error "double expected"))
    (if (and (string? *link:double-entry2*) 
	     (not (number? (string->number *link:double-entry2*)))) 
			(error "double expected"))
    (if (and (string? *link:double-entry3*) 
	     (not (number? (string->number *link:double-entry3*)))) 
			(error "double expected"))
    (destroy *link:file-listbox-toplevel*)
    (reset-file-listbox))
(define (double-entry prompt def-value func)
	(catch (destroy *link:file-listbox-toplevel*))
	(set! *link:file-listbox-toplevel*  
				(make <toplevel> :title "Integer Entry"))
	(set! *link:file-listbox-label* 
			(make <label> :parent *link:file-listbox-toplevel*
						:side 'bottom
						:text prompt))
	(set! *link:file-entry* 
			(make <entry> :parent *link:file-listbox-toplevel*
						:value def-value
						:side 'bottom))
      	(pack *link:file-listbox-label*)
      	(pack *link:file-entry*)
	(pack (make <button> :parent *link:file-listbox-toplevel*
				 :text "ok" 
				 :command (lambda () (double-entry-ok-button)
						     (func))))
)
(define (integer-entry-ok-button)
    (if *link:file-entry*
    	(set! *link:integer-entry* (value *link:file-entry*))
    	(set! *link:integer-entry* #f))
    (if *link:file-entry2*
    	(set! *link:integer-entry2* (value *link:file-entry2*))
    	(set! *link:integer-entry2* #f))
    (if *link:file-entry3*
    	(set! *link:integer-entry3* (value *link:file-entry3*))
    	(set! *link:integer-entry3* #f))
    (if (and (string? *link:integer-entry*) 
	     (not (integer? (string->number *link:integer-entry*)))) 
			(error "integer expected"))
    (if (and (string? *link:integer-entry2*) 
	     (not (integer? (string->number *link:integer-entry2*)))) 
			(error "integer expected"))
    (if (and (string? *link:integer-entry3*) 
	     (not (integer? (string->number *link:integer-entry3*)))) 
			(error "integer expected"))
    (destroy *link:file-listbox-toplevel*)
    (reset-file-listbox))
(define (integer-entry prompt def-value func)
	(catch (destroy *link:file-listbox-toplevel*))
	(set! *link:file-listbox-toplevel*  
				(make <toplevel> :title "Integer Entry"))
	(set! *link:file-listbox-label* 
			(make <label> :parent *link:file-listbox-toplevel*
						:side 'bottom
						:text prompt))
	(set! *link:file-entry* 
			(make <entry> :parent *link:file-listbox-toplevel*
						:value def-value
						:side 'bottom))
      	(pack *link:file-listbox-label*)
      	(pack *link:file-entry*)
	(pack (make <button> :parent *link:file-listbox-toplevel*
				 :text "ok" 
				 :command (lambda () (integer-entry-ok-button)
						     (func))))
)
(define (two-integer-entry prompt1 prompt2 def-value1 def-value2 func)
	(catch (destroy *link:file-listbox-toplevel*))
	(set! *link:file-listbox-toplevel*  
				(make <toplevel> :title "Integer Entry"))
	(set! *link:file-listbox-label* 
			(make <label> :parent *link:file-listbox-toplevel*
						:side 'bottom
						:text prompt1))
	(set! *link:file-entry* 
			(make <entry> :parent *link:file-listbox-toplevel*
						:value def-value1
						:side 'bottom))
	(set! *link:file-listbox-label2*
			(make <label> :parent *link:file-listbox-toplevel*
						:side 'bottom
						:text prompt2))
	(set! *link:file-entry2* 
			(make <entry> :parent *link:file-listbox-toplevel*
						:value def-value2
						:side 'bottom))
      	(pack *link:file-listbox-label*)
      	(pack *link:file-entry*)
      	(pack *link:file-listbox-label2*)
      	(pack *link:file-entry2*)
	(pack (make <button> :parent *link:file-listbox-toplevel*
				 :text "ok" 
				 :command  (lambda() (integer-entry-ok-button)
						     (func))))
)
(define (two-double-entry prompt1 prompt2 def-value1 def-value2 func)
	(catch (destroy *link:file-listbox-toplevel*))
	(set! *link:file-listbox-toplevel*  
				(make <toplevel> :title "Floating Point Entry"))
	(set! *link:file-listbox-label* 
			(make <label> :parent *link:file-listbox-toplevel*
						:side 'bottom
						:text prompt1))
	(set! *link:file-entry* 
			(make <entry> :parent *link:file-listbox-toplevel*
						:value def-value1
						:side 'bottom))
	(set! *link:file-listbox-label2*
			(make <label> :parent *link:file-listbox-toplevel*
						:side 'bottom
						:text prompt2))
	(set! *link:file-entry2* 
			(make <entry> :parent *link:file-listbox-toplevel*
						:value def-value2
						:side 'bottom))
      	(pack *link:file-listbox-label*)
      	(pack *link:file-entry*)
      	(pack *link:file-listbox-label2*)
      	(pack *link:file-entry2*)
	(pack (make <button> :parent *link:file-listbox-toplevel*
				 :text "ok" 
				 :command  (lambda() (double-entry-ok-button)
						     (func))))
)
(define (triple-integer-entry prompt1 prompt2 prompt3 
			      def-value1 def-value2 def-value3 func)
	(catch (destroy *link:file-listbox-toplevel*))
	(set! *link:file-listbox-toplevel*  
				(make <toplevel> :title "Integer Entry"))
	(set! *link:file-listbox-label* 
			(make <label> :parent *link:file-listbox-toplevel*
						:side 'bottom
						:text prompt1))
	(set! *link:file-entry* 
			(make <entry> :parent *link:file-listbox-toplevel*
						:value def-value1
						:side 'bottom))
	(set! *link:file-listbox-label2*
			(make <label> :parent *link:file-listbox-toplevel*
						:side 'bottom
						:text prompt2))
	(set! *link:file-entry2* 
			(make <entry> :parent *link:file-listbox-toplevel*
						:value def-value2
						:side 'bottom))
	(set! *link:file-listbox-label3*
			(make <label> :parent *link:file-listbox-toplevel*
						:side 'bottom
						:text prompt3))
	(set! *link:file-entry3* 
			(make <entry> :parent *link:file-listbox-toplevel*
						:value def-value3
						:side 'bottom))
      	(pack *link:file-listbox-label*)
      	(pack *link:file-entry*)
      	(pack *link:file-listbox-label2*)
      	(pack *link:file-entry2*)
      	(pack *link:file-listbox-label3*)
      	(pack *link:file-entry3*)
	(pack (make <button> :parent *link:file-listbox-toplevel*
				 :text "ok" 
				 :command  (lambda() (integer-entry-ok-button)
						     (func))))
)
(define (font-string ftype fwgt fstyle fsize)
		(let*((ft1 (if (symbol? ftype) (symbol->string ftype) ftype))
		      (fs1 (if (symbol? fstyle)(symbol->string fstyle) fstyle))
		      (wt1 (if (symbol? fwgt)(symbol->string fwgt) fwgt))
		      (sz1 (if (number? fsize)(number->string fsize) fsize))
		      (ft (if ft1 ft1 "times"))
		      (st (if fs1 fs1 "r"))
		      (wt (if wt1  wt1  "medium"))
		      (sz (if sz1  sz1 "12"))
	 	      (l (string-append "-adobe-" 
					ft
					"-"
					wt 
					"-"
					st
					"-Normal-*-"
					sz
					"-*-*-*-*-*-*-*")))
		   (display l) (newline)
		   l))
(define (graph-font-buttons)
	(let*((t  (make <toplevel> :title "Font Selection"))
	      (rbuttons (make <Frame> :parent t)))
	  (for-each (lambda (pt)
		    (pack (make <Radio-button>
				:parent rbuttons
				:text (format #f "Point Size ~A" pt)
				:variable '*link:point-size*
				:relief "flat"
				:width 15
				:anchor "w"
				:value pt)))
		  '("10" "12" "18" "24"))
	(for-each (lambda (ft)
		    (pack (make <Radio-button>
				:parent rbuttons
				:text ft 
				:variable '*link:ftype*
				:relief "flat"
				:width 15
				:anchor "w"
				:value ft)))
		  '("times" "helvetica"))
	(for-each (lambda (wt)
		    (pack (make <Radio-button>
				:parent rbuttons
				:text wt 
				:variable '*link:fwgt*
				:relief "flat"
				:width 15
				:anchor "w"
				:value wt)))
		  '("bold" "medium"))
	
	(pack (make <Radio-button> :parent rbuttons
				:text "Roman"
				:variable '*link:fstyle*
				:relief "flat"
				:width 15
				:anchor "w"
				:value "r"))
	(pack (make <Radio-button> :parent rbuttons
				:text "Italic" 
				:variable '*link:fstyle*
				:relief "flat"
				:width 15
				:anchor "w"
				:value "i"))
	
	(pack rbuttons :side 'top :expand #f :padx ".3c" :pady ".3c")
	(pack (make <button> :parent t :text "done" 
		     :command 
			(lambda () 
			  (let ((fs (font-string *link:ftype* *link:fwgt* 
					 *link:fstyle* *link:point-size*)))
			      (map (lambda (x) 
					(slot-set! x 'font fs))
				    (append *link:selected-vertex-items*
				            *link:selected-edge-items*)))
		 	   (destroy t))))))
(define (mess str) 
   (error "This is just a demo: no action has been defined for the \"~A\" entry"
	     str))
    
(define (set-color-selected color)
	`(command :label ,color :background,color
		  :command ,(lambda () (map (lambda (x)
			(slot-set! x 'color color))
				  (append *link:selected-vertex-items*
				          *link:selected-edge-items*)))))
    
(define (set-path-draw-selected)
	(map (lambda (x)
			(path-draw x))
	     *link:selected-edge-items*))
    
(define (set-star-draw-selected)
	(map (lambda (x)
			(path-draw x))
	     *link:selected-edge-items*))
    
(define (set-size-selected size)
	(map (lambda (x)
			(slot-set! x 'size size))
	     *link:selected-vertex-items*))
    
(define (set-label-selected lab)
	(map (lambda (x)
			(slot-set! x 'vertex-label lab))
	             *link:selected-vertex-items*)
	(map (lambda (x)
			(slot-set! x 'edge-label lab))
	             *link:selected-edge-items*))
    
(define (get-graphobj-label)
	(string-entry "Enter Label" ""
	   (lambda()
	      (set-label-selected *link:string-entry*))))
    
(define (get-vertex-size)
	(integer-entry "Enter Default Vertex Size" *link:default-vertex-size*
	   (lambda()
		     (cond ((and (string? *link:integer-entry*)
		 		(integer? 
				  (string->number *link:integer-entry*)))
			      (set! *link:default-vertex-size* 
		 		  (string->number *link:integer-entry*))
			      (set-size-selected 
				  (string->number *link:integer-entry*)))))))
    
(define (get-edge-width)
	(integer-entry "Enter Default Edge Width" *link:default-edge-size*
	   (lambda()
		     (cond ((and (string? *link:integer-entry*)
		 		(integer? 
				  (string->number *link:integer-entry*)))
			      (set! *link:default-edge-width* 
		 		  (string->number *link:integer-entry*))
			      (set-size-selected 
				  (string->number *link:integer-entry*)))))))
    
(define (set-capacity-selected capacity)
	(map (lambda (x)
			(slot-set! x 'capacity capacity))
	     *link:selected-edge-items*))
    
(define (random-weight-selected upper)
	(map (lambda (x)
			(slot-set! x 'weight (random upper))
	     *link:selected-edge-items*)))
    
(define (show-edge-weight-selected)
	(map (lambda (x)
			(slot-set! x 'edge-label 
				(number->string (slot-ref x 'weight))))
	     *link:selected-edge-items*))
(define (set-weight-selected weight)
	  (map (lambda (x)
		  (let ((wgt (if (equal? weight 'rand) (random-double) weight)))
			(slot-set! x 'weight wgt)
			(slot-set! x 'edge-label 
				(number->string (slot-ref x 'weight)))))
	     *link:selected-edge-items*))
    
(define (get-edge-weight)
	(double-entry "Enter Edge Weight" 0.0
	   (lambda()
		     (cond ((and (string? *link:double-entry*)
		 		(number? 
				  (string->number *link:double-entry*)))
			      (set-weight-selected 
		 		  (string->number *link:double-entry*)))))))
    
(define (get-edge-weight)
	(double-entry "Enter Edge Weight" 0.0
	   (lambda()
		     (cond ((and (string? *link:double-entry*)
		 		(number? 
				  (string->number *link:double-entry*)))
			      (set-weight-selected 
		 		  (string->number *link:double-entry*)))))))
(define (set-width-selected width)
	(map (lambda (x)
			(slot-set! x 'width width))
	     *link:selected-edge-items*))
    
(define (select-vertices gv)
	(link:select-graph-items (vertices gv) gv))
    
(define (select-edges gv)
	(link:select-graph-items (edges gv) gv))
    
(define (select-all gv)
	(link:select-graph-items (vertices gv) gv)
	(link:select-graph-items (edges gv) gv))
    
(define (select-edge-vertices gv)
	(map (lambda (eg)
              (let*((e (slot-ref eg 'edge))
	            (vs (set-vertex->list (vertices e))))
		   (link:select-graph-items (map vertex-item vs) gv)))
             *link:selected-edge-items*))

(define (select-neighbors gv flag)
	(map (lambda (vg)
		(let*((v (slot-ref vg 'vertex))
	              (neighs (cond ((equal? flag 'in) (in-neighbors v))
	                            ((equal? flag 'out) (out-neighbors v))
				    (#t (neighbors v)))))
		   (link:select-graph-items
			(map (lambda(x) 
				(hash-table-get (slot-ref gv 'vertex-table) x))
		             (set-vertex->list neighs)) gv)))
	     *link:selected-vertex-items*))
    
(define (select-incident-edges gv flag)
	(map (lambda (vg)
		(let*((v (slot-ref vg 'vertex))
	              (egs (cond ((equal? flag 'in) (in-incident-edges v))
	                            ((equal? flag 'out) (out-incident-edges v))
				    (#t (incident-edges v)))))
	  	  (link:select-graph-items
			(map (lambda(x) 
				(hash-table-get (slot-ref gv 'edge-table) x))
		             (set-edge->list egs)) gv)))
	     *link:selected-vertex-items*))
;
; the following 3 functions should go in a graph view utilities file
; once one exists
;
(define (set-color-edge eg n)
        (cond ((= n 1) (set! (color eg) "gold"))
              ((= n 2) (set! (color eg) "gray"))
              ((= n 3) (set! (color eg) "green"))  ;green
              ((= n 4) (set! (color eg) "red"))  ;red
              ((= n 5) (set! (color eg) "blue"))  ;blue
              ((= n 6) (set! (color eg) "orange"))
              ((= n 7) (set! (color eg) "purple"))
              ((= n 8) (set! (color eg) "yellow"))
              ((= n 9) (set! (color eg) "cyan"))
              ((= n 10) (set! (color eg) "brown"))
              ((= n 11) (set! (color eg) "tan"))
              ((= n 12) (set! (color eg) "pink"))))

(define (color-edge-item-by-weight eg)
        (let* ((e (slot-ref eg 'edge))
                (w (find-double-attribute 'weight e)))
           (set-color-edge eg w)
           (cond ((> w 6) (slot-set! eg 'width 3))) #f))

(define (color-edge-items-by-weight gv)
        (map color-edge-item-by-weight (edges gv)))
(define (random-graph-option gv)
	(integer-entry "Enter Number of Vertices" 10
	   (lambda() 
	     (cond ((and (string? *link:integer-entry*)
	 		(integer? 
				(string->number *link:integer-entry*)))
		      (let ((n (string->number *link:integer-entry*)))
	(double-entry "Enter Edge Probability" 0.0
	   (lambda()
		     (cond ((and (string? *link:double-entry*)
		 		 (number? 
				  (string->number *link:double-entry*)))
			      (let ((g (gen-random-graph n
				        (string->number *link:double-entry*))))
	    		      (replace-graph g gv)
			      (circle-layout* g gv))))))
		      ); let n
	           )
             ); cond
           ); integer-entry lambda
         ); integer-entry
)
    
(define (prufer-option gv)
	(string-entry "Enter sequence of vertex labels separated by spaces" ""
	   (lambda()
	      (let ((g (gen-prufer *link:string-entry*)))
	        (replace-graph g gv)
	        (circle-layout* g gv)
		(hide-edge-labels gv)
		(map (lambda (x) (set! (color x) "white")) (edges gv))
		(set! (title gv) *link:string-entry*)
	        (reveal-edges-by-rank g gv)
              ))))

(define (halin-graph-option gv)
	      (replace-graph (gen-halin-graph (graph gv)) gv)
	      (update-visible-attributes gv)
	      (path-draw gv))

(define (cycle-graph-option gv)
	(integer-entry "Enter Number of Vertices" 5
	   (lambda() 
		     (cond ((and (string? *link:integer-entry*)
		 		(integer? 
					(string->number *link:integer-entry*)))
			      (let ((g (gen-cycle
				        (string->number *link:integer-entry*))))
	    		      (replace-graph g gv)
			      (circle-layout* g gv)))))))
(define (complete-graph-option gv)
	(integer-entry "Enter Number of Vertices" 5
	   (lambda() 
		     (cond ((and (string? *link:integer-entry*)
		 		(integer? 
					(string->number *link:integer-entry*)))
			      (let ((g (gen-complete-graph
				        (string->number *link:integer-entry*))))
			      (circle-layout g)
	    		      (replace-graph g gv)))))))
(define (grid-graph-option gv)
	(two-integer-entry "Enter Number of Rows" 
			      "Enter Number of Columns" 4 4
	   (lambda() 
		     (cond ((and (and (string? *link:integer-entry*)
		 		   (integer? (string->number 
						*link:integer-entry*)))
		                 (and (string? *link:integer-entry2*)
		 	          (integer?(string->number 
						*link:integer-entry2*))))
			      (let*((rows (string->number *link:integer-entry*))
			            (cols(string->number *link:integer-entry2*))
				    (g (gen-grid-graph rows cols)))
			         (grid-layout g rows cols)
	    		         (replace-graph g gv)))))))

(define (regular-graph-option gv)
	(two-integer-entry "Enter Number of Vertices" 
			      "Enter degree " 10 3
	   (lambda() 
		     (cond ((and (and (string? *link:integer-entry*)
		 		   (integer? (string->number 
						*link:integer-entry*)))
		                 (and (string? *link:integer-entry2*)
		 	          (integer?(string->number 
						*link:integer-entry2*))))
			      (let*((n (string->number *link:integer-entry*))
			            (k (string->number *link:integer-entry2*))
				    (g (gen-regular-graph n k)))
			         (spring-layout g)
	    		         (replace-graph g gv)))))))

(define (latka-tournament-option gv)
	(two-integer-entry "Enter n" 
			      "Enter k" 2 1
	   (lambda() 
		     (cond ((and (and (string? *link:integer-entry*)
		 		   (integer? (string->number 
						*link:integer-entry*)))
		                 (and (string? *link:integer-entry2*)
		 	          (integer?(string->number 
						*link:integer-entry2*))))
			      (let*((n (string->number *link:integer-entry*))
			            (k(string->number *link:integer-entry2*))
				    (g (gen-latka-tournament n k)))
				 (display "layout\n")
			         (circle-layout g)
				 (display "replace\n")
	    		         (replace-graph g gv)
				 (display "hide\n")
			         (hide-edge-labels gv)
				 (display "find\n")
			         (find-triangles (graph gv))
				 (display "update\n")
			         (color-edge-items-by-weight gv)))))))
(define (uniform-hypergraph-option gv)
	(triple-integer-entry "Enter number of vertices" 
			      "Enter number of edges" 
			      "Enter cardinality of each edge" 10 10 3
	   (lambda() 
		     (cond ((and (and (string? *link:integer-entry*)
		 		   (integer? (string->number 
						*link:integer-entry*)))
		                 (and (string? *link:integer-entry2*)
		 	          (integer?(string->number 
						*link:integer-entry2*)))
		                 (and (string? *link:integer-entry3*)
		 	          (integer?(string->number 
						*link:integer-entry3*))))
			      (let*((n (string->number *link:integer-entry*))
			            (m (string->number *link:integer-entry2*))
			            (k (string->number *link:integer-entry3*))
				    (g (gen-uniform-hypergraph n m k)))
				 (spring-layout g)
	    		         (replace-graph g gv)
				 (layout-edges gv))) ))))

(define (component-layout-option gv)
	(double-string-entry 
	  "Enter layout algorithm for component graph \
	   (circular, grid, spring, random, bipartite)" 
	  "Enter layout algorithm for component graph \
	   (circular, grid, spring, random, bipartite)" 
			      "circular" "circular"
	   (lambda() 
		     (cond ((and (string? *link:string-entry*)
		                 (string? *link:string-entry2*))
			         (component-layout (slot-ref gv 'graph) 
					(scc (slot-ref gv 'graph))
						*link:string-entry*
						*link:string-entry2*)
				 (path-draw gv)
				 (layout-vertices gv))))))

(define (display-vertex-attributes gv)
	(double-string-entry 
	  "Enter attribute name" 
	  "If not integer, enter attribute type (double,string,<vertex*>)" 
			      "" ""
	   (lambda() 
		     (cond ((and (string? *link:string-entry*)
		                 (string? *link:string-entry2*))
			      (map (lambda(x) 
				(set-string-attribute! 'label 
				  (number->string 
				   (find-attribute 
				    (string->symbol *link:string-entry*) x)) x))
				(set-vertex->list (vertices 
					(slot-ref gv 'graph)))))))))
				  
(define (grid-layout-option gv)
	(two-integer-entry 
	  "Enter number of rows"
	  "Enter number of columns"
	  (inexact->exact (ceiling (sqrt (order (slot-ref gv 'graph)))))
	  (inexact->exact (ceiling (sqrt (order (slot-ref gv 'graph)))))
	   (lambda() 
		     (cond ((and(integer?(string->number *link:integer-entry*))
		               (integer?(string->number *link:integer-entry2*)))
			         (grid-layout (slot-ref gv 'graph) 
					(string->number *link:integer-entry*)
					(string->number *link:integer-entry2*))
				 (path-draw gv)
				 (layout-vertices gv))))))
(define (run-algorithm-one-vertex-input alg gv)
        (reset-graphics gv)
	(set! *link:selected-vertex-items* #f)
        (msg-window "Select a vertex"
	     (lambda () 
		(cond ((null? *link:selected-vertex-items*) #f)
		      (#t (let ((v (slot-ref 
					(car *link:selected-vertex-items*)
					'vertex)))
				(apply alg (list (slot-ref gv 'graph) gv v)))))
        	(reset-graphics gv))))
(define (run-algorithm alg gv)
        (reset-graphics gv)
	(apply alg (list (slot-ref gv 'graph) gv))
        (reset-graphics gv))
(define (menu-string gv)
	`(("File" 
	     ("Load graph" 	,(lambda () (graph-load-file-listbox gv)))
	     ("Save graph"	,(lambda () (graph-save-file-listbox gv)))
	     ;("Save (DIMACS format)",(lambda()(save-graph-entry gv ".dimacs")))
	     ("Save Postscript" ,(lambda()(save-graph-entry gv ".ps")))
	     ("New"	 	
		(("Graph"
			(("Undirected"
			   (("No Multiple Edges" 
				,(lambda ()(replace-graph (ubingraph) gv)))
			    ("Multiple Edges Allowed"
				,(lambda ()(replace-graph (mubingraph) gv)))))
			 ("Directed"
			   (("No Multiple Edges"
				,(lambda ()(replace-graph (dbingraph) gv)))
			    ("Multiple Edges Allowed"
				,(lambda ()(replace-graph (mdbingraph) gv)))))
			 ("Mixed"
			   (("No Multiple Edges"
				,(lambda ()(replace-graph (bingraph) gv)))
			    ("Multiple Edges Allowed"
				,(lambda ()(replace-graph (mbingraph) gv)))))))
		 ("Hypergraph"
			(("Undirected"
			   (("No Multiple Edges"
				,(lambda ()(replace-graph (uhypergraph) gv)))
			    ("Multiple Edges Allowed"
				,(lambda ()(replace-graph (muhypergraph) gv)))))
			 ("Directed"
			   (("No Multiple Edges"
				,(lambda ()(replace-graph (dhypergraph) gv)))
			    ("Multiple Edges Allowed"
				,(lambda ()(replace-graph (mdhypergraph) gv)))))
			 ("Mixed"
			   (("No Multiple Edges"
			      ,(lambda ()(replace-graph (hypergraph) gv)))
			    ("Multiple Edges Allowed"
			      ,(lambda ()(replace-graph(mhypergraph)gv))))))))
             )
	     ("Generate"	 	
		(("Graph"
			(("Undirected"
			   (("Cycle" 
				,(lambda ()(cycle-graph-option gv)))
			    ("Random Graph"
				,(lambda ()(random-graph-option gv)))
			    ("Complete Graph"
				,(lambda ()(complete-graph-option gv)))
			    ("Halin Graph"
				,(lambda ()(halin-graph-option gv)))
			    ("Grid Graph"
				,(lambda ()(grid-graph-option gv)))
			    ("Linear Orders Graph"
				,(lambda ()(require "permutation-chooser")
					   (vertex-permutation-chooser gv)))
			    ("Regular Graph"
				,(lambda ()(regular-graph-option gv)))
                           )
                         )
			 ("Directed"
			   (
				("Latka Tournament"
				    ,(lambda ()(latka-tournament-option gv)))
			   )
			 )
			 ("Mixed"
			   (("No Multiple Edges"
				,(lambda ()(replace-graph (bingraph) gv)))
			    ("Multiple Edges Allowed"
				,(lambda ()(replace-graph (mbingraph) gv))))))
                 )
		 ("Hypergraph"
			(("Undirected"
			   (("Uniform"
				,(lambda ()(uniform-hypergraph-option gv)))
				))
			 ("Directed"
			   (("No Multiple Edges"
				,(lambda ()(replace-graph (dhypergraph) gv)))
			    ("Multiple Edges Allowed"
				,(lambda ()(replace-graph (mdhypergraph) gv)))))
			 ("Mixed"
			   (("No Multiple Edges"
			      ,(lambda ()(replace-graph (hypergraph) gv)))
			    ("Multiple Edges Allowed"
			      ,(lambda ()(replace-graph(mhypergraph)gv))))))
                 )
		 ("Tree"
			(("Labeled" ,(lambda () (prufer-option gv)))
                        )
                )
               )
             )                  ; end generate
	     ("Clone"		,(lambda () (define *link:new-graph-view*
				   (show-labeled-graph (graph gv) 'custom))))
	     ("Multi-Graph Clone",(lambda () (define *link:new-graph-view*
				   (set! *link:new-graph-view*
				   (make <graph-view> :graph (multi-graph 
					(graph gv) 1) 
					:clone 'clone :layout 'custom)))))
	     ("Simple Graph Clone",(lambda () (define *link:new-graph-view*
				   (set! *link:new-graph-view*
				   (make <graph-view> :graph (simple-graph 
					(graph gv) 1) 
					:clone 'clone :layout 'custom)))))
	     ("Quit"		,(lambda () 
				   (destroy (slot-ref gv 'graph-toplevel)))))
	  ("Edit"
	     ("delete (x)" ,(lambda () (link:delete-selected gv)))
	     ("collapse selected (s)" ,(lambda () (link:collapse-selected gv)))
	     ("expand selected (S)" ,(lambda () (link:expand-selected gv)))
	     ("induced subgraph (i)" ,(lambda () (link:induce-selected gv)))
	     ("select all" ,(lambda () (select-all gv)))
	     ("select vertices" ,(lambda () (select-vertices gv)))
	     ("select edges" ,(lambda () (select-edges gv)))
	     ("select neighbors" ,(lambda () (select-neighbors gv 'all)))
	     ("select in-neighbors" ,(lambda () (select-neighbors gv 'in)))
	     ("select out-neighbors" ,(lambda () (select-neighbors gv 'out)))
	     ("select edge vertices" ,(lambda () (select-edge-vertices gv)))
	     ("select incident-edges" 
				,(lambda () (select-incident-edges gv 'all)))
	     ("select in-incident-edges" 
				,(lambda () (select-incident-edges gv 'in)))
	     ("select out-incident-edges" 
				,(lambda () (select-incident-edges gv 'out))))
	  ("Graph-View"
	     ("redraw" ,(lambda () (update-graph-view gv)))
	     ("refresh graphics" ,(lambda () (reset-graphics gv)))
	     ("Adjacency Matrix"
				,(lambda ()(require "matrix-view")
					   (make <matrix-view> 
					    :matrix (adjacency-matrix 
							(graph gv)))))
	     ("snap to grid" ,(lambda() (gridding gv)
					(map snap-to-grid (vertices gv))
				       (slot-set! gv 'snap-to-grid #t)))
	     ("gridding off" ,(lambda() (remove-gridding gv)
				       (slot-set! gv 'snap-to-grid #f))))
	  ("Attributes"
	     ("Labels"
		(("Set" ,(lambda() (get-graphobj-label)))
		 ("hide selected" ,(lambda() (map hide-label 
				(append *link:selected-vertex-items*
					*link:selected-edge-items*))))
		 ("show selected" ,(lambda() (map show-label 
				(append *link:selected-vertex-items*
					*link:selected-edge-items*))))
		 ("hide vertex" ,(lambda() (map hide-label (vertices gv))))
		 ("show vertex" ,(lambda() (map show-label (vertices gv))))
		 ("hide edge" 	,(lambda() (map hide-label (edges gv))))
		 ("show edge" 	,(lambda() (map show-label (edges gv))))
		 ("hide all" 	,(lambda() (hide-labels gv)))
		 ("show all" 	,(lambda() (show-labels gv)))))
	     ("Vertex Size"
	         ((radiobutton :label "0" :variable '*link:default-vertex-size*
		 	       :command ,(lambda () 
					   (set-size-selected 0)))
		  (radiobutton :label "10" :variable '*link:default-vertex-size*
		 	       :command ,(lambda () 
					   (set-size-selected 10)))
		  (radiobutton :label "20" :variable '*link:default-vertex-size*
		 	       :command ,(lambda () 
					   (set-size-selected 20)))
		  (radiobutton :label "30" :variable '*link:default-vertex-size*
		 	       :command ,(lambda () 
					   (set-size-selected 30)))
		  ("")
		  ("Set Default Size" ,(lambda() (get-vertex-size)))
	     ))
	     ("Edge Weight" 
		(("Set" ,(lambda() (get-edge-weight)))
		 ("Random" ,(lambda() (set-weight-selected 'rand)))
		 ("Show" ,(lambda() (show-edge-weight-selected)))))
	     ("Edge Width"
	         ((radiobutton :label "1" :variable width 
		 	       :command ,(lambda ()(set-width-selected 1)))
		  (radiobutton :label "2" :variable width
		 	       :command ,(lambda ()(set-width-selected 2)))
		  (radiobutton :label "3" :variable width
		 	       :command ,(lambda ()(set-width-selected 3)))
		  (radiobutton :label "4" :variable width
		 	       :command ,(lambda ()(set-width-selected 4)))
		  ("")
		  ("Set Default Size" ,(lambda() (get-edge-width)))
	     ))
	     ("Colors"
		(,(set-color-selected "green")
		 ,(set-color-selected "red")
		 ,(set-color-selected "blue")
		 ,(set-color-selected "orange")
		 ,(set-color-selected "gold")
		 ,(set-color-selected "brown")
		 ,(set-color-selected "yellow")
		 ,(set-color-selected "cyan")
		 ,(set-color-selected "white")
		 ,(set-color-selected "gray")
		 ,(set-color-selected "purple")
		 ,(set-color-selected "black")))
	     ("Font" ,graph-font-buttons))
	("Algorithm"
	    ("Custom"  
		(
		)
	    )
	    ("Searches"  
		(
		    ; run-algorithm will have to be overloaded once
		    ; algorithms can take parameters from the GUI
		    ("Depth-first Search (vertices ordered by vertex number)" 	
			,(lambda() (run-algorithm dfs* gv)))
		    ("Depth-first Search (vertices ordered by decreasing finish time)" 	
			,(lambda() 
			    (run-algorithm dfs-decreasing-finish-time* gv)))
		    ("Breadth-first Search"
			,(lambda() (run-algorithm-one-vertex-input bfs gv)))
		    ("Fleury"
			,(lambda() (run-algorithm fleury* gv)))
		    ("Topological Sort"
			,(lambda() (run-algorithm topological-sort* gv)))
		)
	    )
	    ("Components"  
		(
		    ("Bridges" 	,(lambda() (run-algorithm bridges* gv)))
		    ("Min Weight Perfect Matching" 
			   ,(lambda() (let ((m (min-weight-perfect-matching 
							(graph gv))))
					  (thicken-edges gv m 4))))
		    ("Articulation Points" 	
				,(lambda() 
				    (run-algorithm articulation-points* gv)))
		    ("Biconnected Components" 	
				,(lambda() 
				    (run-algorithm bcc* gv)))
                    ("Find a cycle" ,(lambda() (find-cycle)))
		)
	    )
	    ("Optimizations"  
		(
                    ("Minimum spanning tree"
		      (
		    	("Kruskal" 
				,(lambda()(run-algorithm kruskal gv)))
		    	("Prim" 
				,(lambda()
				   (run-algorithm-one-vertex-input prim gv)))
		      )
		    )
                    ("Shortest Paths"
		      (
		    	("Dijkstra" 
			   ,(lambda()
			      (run-algorithm-one-vertex-input dijkstra gv)))
		      )
		    )
		)
	    )
	    ;("Partitioning"  
	;	(
	;	    	("init" 
	;			,(lambda() (require "part")
        ;                                   (reset-post gv)
	;				   (post-analyze-bindings gv)))
	;	    	("post-step" 
	;			,(lambda() (post-step gv)))
	;	    	("greedy-step" 
	;			,(lambda() (greedy-step gv)))
	;	    	("backup" 
	;			,(lambda() (post-backup gv)))
	;			   
	;	)
	;    )
	)
	("Layout"
	    ("Layouts"  
		(
		    ("Bipartite"
			,(lambda ()(bipartite-layout* (slot-ref gv 'graph) gv)))
		    ("Circular"
			,(lambda ()(circle-layout* (slot-ref gv 'graph) gv)))
		    ("Component"
			,(lambda ()(component-layout-option gv)))
		    ("Grid"
			,(lambda ()(grid-layout-option gv)))
		    ("Random"
			,(lambda ()(random-layout* (slot-ref gv 'graph) gv)))
		    ("Spring"
			,(lambda ()(spring-layout* (slot-ref gv 'graph) gv)))
		)
	    )
	    ("Edge Draw"
		(
		    ("Path-Draw Graph"
			,(lambda () (path-draw gv)))
		    ("Star-Draw Graph"
			,(lambda () (star-draw gv)))
		    ("Path-Draw Selection"
			,(lambda () (set-path-draw-selected)))
		    ("Star-Draw Selection"
			,(lambda () (set-star-draw-selected)))
		)
	    )
	)
    )
)
(provide "graph-menu")
