;; 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")
(make <canvas>)
(require "graph-view")
(require "sprouts")

(define *link:new-graph-view* #f)
    
(define (new-graph-view gtype)
    (let ((f #f))
	(cond ((equal? gtype 'mhypergraph) (set! f mhypergraph))
	      ((equal? gtype 'muhypergraph) (set! f muhypergraph))
	      ((equal? gtype 'mdhypergraph) (set! f mdhypergraph))
	      ((equal? gtype 'hypergraph) (set! f hypergraph))
	      ((equal? gtype 'uhypergraph) (set! f uhypergraph))
	      ((equal? gtype 'dhypergraph) (set! f dhypergraph))
	      ((equal? gtype 'mbingraph) (set! f mbingraph))
	      ((equal? gtype 'mubingraph) (set! f mubingraph))
	      ((equal? gtype 'mdbingraph) (set! f mdbingraph))
	      ((equal? gtype 'bingraph) (set! f bingraph))
	      ((equal? gtype 'ubingraph) (set! f ubingraph))
	      ((equal? gtype 'dbingraph) (set! f dbingraph)))
	(set! *link:new-graph-view* (make <graph-view> :graph (f)))))

(define (binary-predicate op truth-msg falsity-msg)
  (set! *link:canvas-clicks* 0)
  (set! *link:selected-graph-view1* #f)
  (set! *link:selected-graph-view2* #f)
  (msg-window "Click with button 1 on two graphs, then click ok" 
    (lambda()
	(cond ((or (not  *link:selected-graph-view1*)
   		   (not *link:selected-graph-view2*))
			(link-msg "Error: did not find two selected graphs.")
			(after 3000))
       	      (#t (if (op (graph *link:selected-graph-view1*) 
                   	    (graph *link:selected-graph-view2*))
			(ans-window truth-msg #f)
			(ans-window falsity-msg #f)
	          )))
	(set! *link:selected-graph-view1* #f)
	(set! *link:selected-graph-view2* #f))))

(define (unary-operation op transform-to-binary)
  (set! *link:canvas-clicks* 0)
  (set! *link:selected-graph-view* #f)
  (msg-window "Click with button 1 on one graph, then click ok" 
    (lambda()
      (let ((g (graph *link:selected-graph-view*)))
        ;(if transform-to-binary (set! g (mbingraph g)))
        (let ((result (op g)))
	  ;(if transform-to-binary (set! result (mbingraph result)))
	  (cond ((not  *link:selected-graph-view*)
			(link-msg "Error: did not find a selected graph.")
			(after 3000))
       	      (#t (set! *link:new-graph-view* 
			(show-labeled-graph result 'custom)
	          )))
	  (set! *link:selected-graph-view* #f))))))

(define (binary-operation op transform-to-binary)
  (set! *link:canvas-clicks* 0)
  (set! *link:selected-graph-view1* #f)
  (set! *link:selected-graph-view2* #f)
  (msg-window "Click with button 1 on two graphs, then click ok" 
    (lambda()
      (let ((g1 (graph *link:selected-graph-view1*)) 
	    (g2 (graph *link:selected-graph-view2*)))
      (if transform-to-binary (set! g1 (mbingraph g1)))
      (if transform-to-binary (set! g2 (mbingraph g2)))
      (let ((result (op g1 g2)))
	(if transform-to-binary (set! result (mbingraph result)))
	(cond ((or (not  *link:selected-graph-view1*)
   		   (not *link:selected-graph-view2*))
			(link-msg "Error: did not find two selected graphs.")
			(after 3000))
       	      (#t (set! *link:new-graph-view* 
			(show-labeled-graph result 'spring))
		  (reset-graphics *link:new-graph-view*)
	      )
	)
	(set! *link:selected-graph-view1* #f)
	(set! *link:selected-graph-view2* #f))))))

(define (sprouts-option)
	(two-integer-entry "Number of vertices" 
			      "Maximum degree" 12 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*)))
			         (sprouts n k)))))))
    
(define (main-menu-string)
	`(
	   ("File" 
		 ("Load STk(los) file" ,(lambda() 
					  (load (make-file-box "STk file load"
                                                               "*.stk*"))))
		 ("Quit" ,(lambda() (bye)))
           )
	   ("Tutorial" ("Load" ,(lambda()(require "link-wtour"))))
	   ("Graph Windows" 
		 ("Graph"
		    (
			 ("Undirected"
			   (
			    ("No Multiple Edges" 
				,(lambda()(new-graph-view 'ubingraph)))
			    ("Multiple Edges Allowed"
				,(lambda()(new-graph-view 'mubingraph)))
			    ("Cycle" 
				,(lambda ()
					(let ((gv (show-graph (graph))))
						(cycle-graph-option gv))))
			    ("Random Graph"
				,(lambda ()
					(let ((gv (show-graph (graph))))
						(random-graph-option gv))))
			    ("Complete Graph"
				,(lambda ()
					(let ((gv (show-graph (graph))))
						(complete-graph-option gv))))
			    ("Grid Graph"
				,(lambda ()
					(let ((gv (show-graph (graph))))
						(grid-graph-option gv))))
			    ("Regular Graph"
				,(lambda ()
					(let ((gv (show-graph (graph))))
						(regular-graph-option gv))))
                           )
			 )
			 ("Directed"
			   (
			    ("No Multiple Edges" 
				,(lambda()(new-graph-view 'dbingraph)))
			    ("Multiple Edges Allowed"
				,(lambda()(new-graph-view 'mdbingraph)))
				("Latka Tournament"
				   ,(lambda ()
					(let ((gv (show-graph (graph))))
						(latka-tournament-option gv))))
			   )
			 )
			 ("Mixed"
			   (
			    ("No Multiple Edges" 
				,(lambda()(new-graph-view 'bingraph)))
			    ("Multiple Edges Allowed"
				,(lambda()(new-graph-view 'mbingraph)))
			   )
			 )
		    )
		)
		("Hypergraph"
		    (
			("Undirected"
			   (	
				("No Multiple Edges" 
				   ,(lambda()(new-graph-view 'uhypergraph)))
			    	("Multiple Edges Allowed"
				   ,(lambda()(new-graph-view 'muhypergraph)))
			   )
			)
			("Directed"
			   (
				("No Multiple Edges" 
				   ,(lambda()(new-graph-view 'dhypergraph)))
			    	("Multiple Edges Allowed"
				   ,(lambda()(new-graph-view 'mdhypergraph)))
			   )
			)
			("Mixed"
			   (
				("No Multiple Edges" 
				   ,(lambda()(new-graph-view 'hypergraph)))
			    	("Multiple Edges Allowed"
				   ,(lambda()(new-graph-view 'mhypergraph)))
			   )
			)
		    )
		)
	        ("Sprouts" ,(lambda() (sprouts-option))
		)
	        ("Labeled Tree" ,(lambda() 
				    (let ((gv (show-graph (graph))))
					(prufer-option gv)))
		)
	   )
	   ("Graph Operations" 
		 ("Complement" ,(lambda() (unary-operation complement #t)))
		 ("Transpose"  ,(lambda() (unary-operation transpose #t)))
		 ("Isomorphism" ,(lambda() (binary-predicate isomorphic?
					     "nauty: They are isomorphic"
					     "nauty: They are not isomorphic")))
		 ;("Line Graph" ,(lambda() (unary-operation line-graph #t)))
		 ("Product" ,(lambda() 
				  (binary-operation product #t)))
		 ("Sum" ,(lambda() (binary-operation sum #t)))
	   )
	)
)

(pack (make-menubar *root* (main-menu-string)))

(provide "main-window")
