(require "graph-string")

(define *link:permutation-chooser-toplevel* #f)
(define *link:permutation-chooser-slb1* #f)
(define *link:permutation-chooser-slb2* #f)
(define *link:permutation-chooser-okb* #f)
(define *link:permutation-ub* 0)
(define *link:permutation-lb* 0)
(define *link:permutation-lock* #f)
(define *link:permutation-graph-view* #f)

(define (slb-select-rank sv)
	(cond ((not (null? ((Id sv) 'curSelection)))
		  (car ((Id sv) 'curSelection)))
	      (#t -1)))

(define (slb-selection sv)
	(cond ((>= (slb-select-rank sv) 0)
			(list-ref (slot-ref sv 'value) (slb-select-rank sv)))
	      (#t "")))

(define (get-rank perm-and-rank-string)
	(string->number (cadr (split-string perm-and-rank-string "()"))))

(define (permutation-ranks list-of-perm-strings)
	(cond ((null? list-of-perm-strings) '())
	      (#t (cons (get-rank (car list-of-perm-strings))
			(permutation-ranks (cdr list-of-perm-strings))))))

(define (update-perm-graph rank-list)
	(let* ((gv *link:permutation-graph-view*)
	       (g  (graph gv)))
	    (remove-edge-items! gv)
	    (apply update-linear-orders-graph (cons g rank-list))
	    (display "back in stk: ")
	    (describe g)
	    (replace-edge-items gv)
	    (reset-graphics gv)
	    (hide-edge-labels gv)))

(define (permutation-select-binding gt)
   (bind gt "<Double-1>" 
     (lambda() 
	(let*((slb1 *link:permutation-chooser-slb1*)
	      (slb2 *link:permutation-chooser-slb2*)
	      (lpgv  *link:permutation-graph-view*)
	      (lpg   (graph *link:permutation-graph-view*))
	      (sbs  (slb-selection slb1))
	      (sbs2 (slb-selection slb2)))
                (cond ((and(not (equal? sbs "")) 
	                   (not (member sbs 
			    (slot-ref slb2 'value))))
                          (slot-set! slb2 'value
                              (cons (slb-selection slb1)
                                    (slot-ref slb2 'value))))
			((not (equal? sbs2 ""))
			   (delete slb2
				(slb-select-rank slb2))))
		(update-perm-graph (permutation-ranks (slot-ref slb2 'value)))
))))

(define (destroy-permutation-chooser)
    (destroy *link:permutation-chooser-slb1*)
    (destroy *link:permutation-chooser-slb2*)
    (destroy *link:permutation-chooser-okb*))

(define (permutation-wait-result pb slb2)
  (let ((cur-grab (grab 'current pb)))
    (tkwait 'visibility pb)
    (grab 'set pb)
    (tkwait 'variable '*link:permutation-lock*)
    (and cur-grab (grab 'set cur-grab))

    ;; Compute result
    (case *link:permutation-lock*
      ((ok)      (let ((res (value slb2))) (destroy-permutation-chooser) res))
      ((cl)      (destroy-permutation-chooser) #f)
      ((dst)     #f))))

(define (factorial n)
	(cond ((<= n 0) 1)
               (#t (* n (factorial (- n 1))))))

(define (request-num-vertices gv)
	(let* ( (g (slot-ref gv 'graph)))
	    (integer-entry "number of vertices" 4 
           		(lambda()
                     	   (cond ((and (string? *link:integer-entry*)
                                     (integer? 
                                      (string->number *link:integer-entry*)))
                              (add-vertices!  1
				 (string->number *link:integer-entry*) g)
			      (create-vertex-items g gv (order g) 
				  (slot-ref gv 'vertex-table)
				  (slot-ref gv 'vertex-tag-table) #t)
			      (circle-layout* g gv)
			      (reset-graphics gv)
			      (hide-edge-labels gv)
		))))))

(define (request-num-permutations gv)
	(let* ( (g (slot-ref gv 'graph))
		(vs (vertices g)))
	    (two-integer-entry "lower bound on permutation rank"
			       "upper bound on permutation rank"
				0 (- (factorial (size vs)) 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*))))
                              (set! *link:permutation-lb* 
                                  (string->number *link:integer-entry*))
                              (set! *link:permutation-ub* 
                                  (string->number *link:integer-entry2*)))
		)))))

(define (plist vert-set lb ub)
	(cond ((or (< ub lb) (< ub 0)) '())
	      ((= ub lb)  (list (string-append (collection-vertex->string
				    (permutation vert-set ub)) " ("
				    (number->string ub) ")")))
	      (#t (append (plist vert-set lb (- ub 1))
	      		  (list (string-append
				  (collection-vertex->string 
				    (permutation vert-set ub)) " ("
				  (number->string ub) ")"))))))

(define (string-of-permutations gv)
	(request-num-vertices gv)
	(tkwait 'variable '*link:integer-entry*)
	(request-num-permutations gv) 
	(tkwait 'variable '*link:permutation-lb*)
	(let* ((g (slot-ref gv 'graph))
	       (vs (vertices g)))
	    (plist vs *link:permutation-lb* *link:permutation-ub*)))

(define (vertex-permutation-chooser gv)
	(let* ((gt (slot-ref gv 'graph-toplevel))
	       (slb (make <scroll-listbox> :parent gt))
	       (slb2(make <scroll-listbox> :parent gt))
	       (okb (make <button> :parent gt :text "ok")))
	(cond ((ubingraph? (graph gv))
	(slot-set! slb 'value (string-of-permutations gv))
	(slot-set! okb 'command (lambda ()(destroy-permutation-chooser)))
	(bind gt "<Destroy>" (lambda () (set! *link:permutation-lock* 'dst)))
	(pack slb slb2 :side 'left :fill 'x)
	(pack okb :side 'bottom :fill 'x)
	(set! *link:permutation-graph-view* gv)
	(set! *link:permutation-chooser-toplevel* gt)
	(set! *link:permutation-chooser-slb1* slb)
	(set! *link:permutation-chooser-slb2* slb2)
	(set! *link:permutation-chooser-okb* okb)
	(set! *link:permutation-lock* #f)
	(permutation-select-binding gt))
	    (#t (msg-window "The graph must be a simple graph.  Try selecting Simple Graph Clone from the File menu" (lambda() '()))))))

(provide "permutation-chooser")
