;; 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: 31-Jul-1996
;; 

(require "Tk-classes")

(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 *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 *link:ans-window-toplevel* #f)	; window used to give answers to 
(define *link:ans-window-label* "")	; predicates

(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)))

(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 (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-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 (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*)))
		   (display file-ext)(display "\n")
		   (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 (slot-ref gv 'graph-canvas) 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*))

(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 (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*))

(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 (double-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 (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
					"-*-*-*-*-*-*-*")))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 '*point-size*
				:relief "flat"
				:width 15
				:anchor "w"
				:value pt)))
		  '("10" "12" "18" "24" "32"))
	(for-each (lambda (ft)
		    (pack (make <Radio-button>
				:parent rbuttons
				:text ft 
				:variable '*ftype*
				:relief "flat"
				:width 15
				:anchor "w"
				:value ft)))
		  '("times" "helvetica"))
	(for-each (lambda (wt)
		    (pack (make <Radio-button>
				:parent rbuttons
				:text wt 
				:variable '*fwgt*
				:relief "flat"
				:width 15
				:anchor "w"
				:value wt)))
		  '("bold" "medium"))
	
	(pack (make <Radio-button> :parent rbuttons
				:text "Roman"
				:variable '*fstyle*
				:relief "flat"
				:width 15
				:anchor "w"
				:value "r"))
	(pack (make <Radio-button> :parent rbuttons
				:text "Italic" 
				:variable '*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 Size" *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-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-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")))
        (cond ((> n 6) (set! (width eg) 3))))

(define (color-edge-item-by-weight eg)
        (let* ((e (slot-ref eg 'edge))
                (w (find-double-attribute 'weight e)))
           (set-color-edge eg w)) #f)

(define (color-edge-items-by-weight gv)
        (map color-edge-item-by-weight (edges 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)
	(double-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 (latka-tournament-option gv)
	(double-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() 
		     (display "dse\n")
		     (cond ((and (string? *link:string-entry*)
		                 (string? *link:string-entry2*))
				 (display "about to test slot-ref\n") 
				 (slot-ref gv 'graph)
				 (display "its ok\n") 
				 (display "about to test scc\n") 
				 (scc (slot-ref gv 'graph))
				 (display "its ok\n") 
				 (display "about to call cl\n")
			         (component-layout (slot-ref gv 'graph) 
					(scc (slot-ref gv 'graph))
						*link:string-entry*
						*link:string-entry2*)
				 (display "after call to cl\n")
				 (path-draw gv)
				 (layout-vertices gv))))))

(define (grid-layout-option gv)
	(double-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" 		,(lambda () (graph-file-listbox gv)))
	     ("Save" 		,(lambda () (save-graph-entry gv ".g")))
	     ("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)))
			    ("Complete Graph"
				,(lambda ()(complete-graph-option gv)))
			    ("Grid Graph"
				,(lambda ()(grid-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)))))))))
		
	     ("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 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))))
	  ("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 Width"
	         ((radiobutton :label "1" :variable width 
		 	       :command ,(lambda ()(set-width-selected width)))
		  (radiobutton :label "2" :variable width
		 	       :command ,(lambda ()(set-width-selected width)))
		  (radiobutton :label "3" :variable width
		 	       :command ,(lambda ()(set-width-selected width)))
		  (radiobutton :label "4" :variable width
		 	       :command ,(lambda ()(set-width-selected width)))
		  ("")
		  ("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"
	    ("Searches"  
		(
		    ; run-algorithm will have to be overloaded once
		    ; algorithms can take parameters from the GUI

		    ("Depth-first Search" 	
			,(lambda() (run-algorithm dfs* gv)))
		    ("Breadth-first Search"
			,(lambda() (run-algorithm-one-vertex-input bfs gv)))
		    ("Topological Sort"
			,(lambda() (run-algorithm topological-sort* gv)))
		)
	    )
	    ("Optimizations"  
		(
		    ("Kruskal's Minimum Spanning Tree" 
				,(lambda()(run-algorithm kruskal 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")