Megatest

(dboard:data-set-curr-test-ids! *data* (make-hash-table))

;; Look up test-ids by (key1 key2 ... testname [itempath])
(dboard:data-set-path-test-ids! *data* (make-hash-table))

;; Look up run-ids by ??
(dboard:data-set-path-run-ids! *data* (make-hash-table))

;;======================================================================
;; D O T F I L E
;;======================================================================

(define (dcommon:write-dotfile fname dat)
  (with-output-to-file fname
    (lambda ()
      (pp dat))))

;;======================================================================
;; TARGET AND PATTERN MANIPULATIONS
;;======================================================================

;; Convert to and from list of lines (for a text box)
;; "," => "\n"

;; TO-DO
;;  1. Make "data" hash-table hierarchial store of all displayed data
;;  2. Update synchash to understand "get-runs", "get-tests" etc.
;;  3. Add extraction of filters to synchash calls
;;
;; Mode is 'full or 'incremental for full refresh or incremental refresh
(define (run-update keys data runname keypatts testpatt states statuses mode window-id)
(define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id)
  (let* (;; count and offset => #f so not used
	 ;; the synchash calls modify the "data" hash
	 (get-runs-sig    (conc (client:get-signature) " get-runs"))
	 (get-tests-sig   (conc (client:get-signature) " get-tests"))
	 (get-details-sig (conc (client:get-signature) " get-test-details"))

	 ;; test-ids to get and display are indexed on window-id in curr-test-ids hash
	 (test-ids        (hash-table-values (dboard:data-get-curr-test-ids *data*)))

 	 (run-changes     (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts))
	 ;; run-id is #f in next line to send the query to server 0
 	 (run-changes     (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts))
	 (tests-detail-changes (if (not (null? test-ids))
				   (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0  data test-ids)
				   (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0  data #f test-ids)
				   '()))

	 ;; Now can calculate the run-ids
	 (run-hash    (hash-table-ref/default data get-runs-sig #f))
	 (run-ids     (if run-hash (filter number? (hash-table-keys run-hash)) '()))

	 (all-test-changes (let ((res (make-hash-table)))
			     (for-each (lambda (run-id)
					 (if (> run-id 0)
	 (test-changes (synchash:client-get 'db:get-tests-for-runs-mindata get-tests-sig 0 data run-ids testpatt states statuses #f))
					     (hash-table-set! res run-id (synchash:client-get 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f))))
				       run-ids)
			     res))
	 (runs-hash    (hash-table-ref/default data get-runs-sig #f))
	 (header       (hash-table-ref/default runs-hash "header" #f))
	 (run-ids      (sort (filter number? (hash-table-keys runs-hash))
			     (lambda (a b)
			       (let* ((record-a (hash-table-ref runs-hash a))
				      (record-b (hash-table-ref runs-hash b))
				      (time-a   (db:get-value-by-header record-a header "event_time"))

		  (set! colnum (+ colnum 1))))
	      run-ids)

    ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table
    ;; Do this analysis in the order of the run-ids, the most recent run wins
    (for-each (lambda (run-id)
		(let* ((run-path       (hash-table-ref (dboard:data-get-run-keys *data*) run-id))
		       (test-changes   (hash-table-ref all-test-changes run-id))
		       (new-test-dat   (car test-changes))
		       (removed-tests  (cadr test-changes))
		       (tests          (sort (map cadr (filter (lambda (testrec)
								 (eq? run-id (db:mintest-get-run_id (cadr testrec))))
							       new-test-dat))
					     (lambda (a b)
					       (let ((time-a (db:mintest-get-event_time a))

				     (testname  (db:mintest-get-testname test))
				     (itempath  (db:mintest-get-item_path test))
				     (fullname  (conc testname "/" itempath))
				     (dispname  (if (string=? itempath "") testname (conc "   " itempath)))
				     (rownum    (hash-table-ref/default testname-to-row fullname #f))
				     (test-path (append run-path (if (equal? itempath "") 
								     (list testname)
								     (list testname itempath)))))
								     (list testname itempath))))
				     (tb         (dboard:data-get-tests-tree *data*)))
				(print "INFONOTE: run-path: " run-path)
				(tree:add-node (dboard:data-get-tests-tree *data*) "Runs" 
					       test-path
					       userdata: (conc "test-id: " test-id))
				(let ((node-num (tree:find-node tb (cons "Runs" test-path)))
				      (color    (car (gutils:get-color-for-state-status state status))))
				  (debug:print 0 "node-num: " node-num ", color: " color)
				  (iup:attribute-set! tb (conc "COLOR" node-num) color))
				(hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id)
				(if (not rownum)
				    (let ((rownums (hash-table-values testname-to-row)))
				      (set! rownum (if (null? rownums)
						       1
						       (+ 1 (apply max rownums))))
				      (hash-table-set! testname-to-row fullname rownum)
				      ;; create the label
				      (iup:attribute-set! (dboard:data-get-runs-matrix *data*)
							  (conc rownum ":" 0) dispname)
				      ))
				;; set the cell text and color
				;; (debug:print 2 "rownum:colnum=" rownum ":" colnum ", state=" status)
				(iup:attribute-set! (dboard:data-get-runs-matrix *data*)
						    (conc rownum ":" colnum)
						    (if (string=? state "COMPLETED")
						    (if (member state '("ARCHIVED" "COMPLETED"))
							status
							state))
				(iup:attribute-set! (dboard:data-get-runs-matrix *data*)
						    (conc "BGCOLOR" rownum ":" colnum)
						    (car (gutils:get-color-for-state-status state status)))
				))
			    tests)))
	      run-ids)

    (let ((updater (hash-table-ref/default  (dboard:data-get-updaters *data*) window-id #f)))
      (if updater (updater (hash-table-ref/default data get-details-sig #f))))

    (iup:attribute-set! (dboard:data-get-runs-matrix *data*) "REDRAW" "ALL")
    ;; (debug:print 2 "run-changes: " run-changes)
    ;; (debug:print 2 "test-changes: " test-changes)
    (list run-changes test-changes)))
    (list run-changes all-test-changes)))

;;======================================================================
;; TESTS DATA
;;======================================================================

;; Produce a list of lists ready for common:sparse-list-generate-index
;;

;; General data
;;
(define (dcommon:general-info)
  (let ((general-matrix (iup:matrix
			 #:alignment1 "ALEFT"
			 #:expand "YES" ;; "HORIZONTAL"
			 #:numcol 1
			 #:numlin 3
			 #:numlin 2
			 #:numcol-visible 1
			 #:numlin-visible 3)))
    (iup:attribute-set! general-matrix "WIDTH1" "200")
			 #:numlin-visible 2)))
    (iup:attribute-set! general-matrix "WIDTH1" "150")
    (iup:attribute-set! general-matrix "0:1" "About this Megatest area") 
    ;; User (this is not always obvious - it is common to run as a different user
    (iup:attribute-set! general-matrix "1:0" "User")
    (iup:attribute-set! general-matrix "1:1" (current-user-name))
    ;; Megatest area
    (iup:attribute-set! general-matrix "2:0" "Area")
    (iup:attribute-set! general-matrix "2:1" *toppath*)
    ;; (iup:attribute-set! general-matrix "2:0" "Area")
    ;; (iup:attribute-set! general-matrix "2:1" *toppath*)
    ;; Megatest version
    (iup:attribute-set! general-matrix "3:0" "Version")
    (iup:attribute-set! general-matrix "3:1" megatest-version)
    (iup:attribute-set! general-matrix "2:0" "Version")
    (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))

    general-matrix))

(define (dcommon:run-stats)
(define (dcommon:run-stats dbstruct)
  (let* ((stats-matrix (iup:matrix expand: "YES"))
	 (changed      #f)
	 (updater      (lambda ()
			 (let* ((run-stats    (mt:get-run-stats))
			 (let* ((run-stats    (db:get-run-stats dbstruct))
				(indices      (common:sparse-list-generate-index run-stats)) ;;  proc: set-cell))
				(row-indices  (car indices))
				(col-indices  (cadr indices))
				(max-row      (if (null? row-indices) 1 (apply max (map cadr row-indices))))
				(max-col      (if (null? col-indices) 1 
						  (apply max (map cadr col-indices))))
				(max-visible  (max (- *num-tests* 15) 3))

    (set! dashboard:update-summary-tab updater)
    (iup:attribute-set! stats-matrix "WIDTHDEF" "40")
    (iup:vbox
     ;; (iup:label "Run statistics"  #:expand "HORIZONTAL")
     stats-matrix)))

(define (dcommon:servers-table)
  (let* ((tdbdat         (tasks:open-db))
  (let* ((colnum         0)
	 (colnum         0)
	 (rownum         0)
	 (servers-matrix (iup:matrix #:expand "YES"
				     #:numcol 7
				     #:numcol-visible 7
				     #:numlin-visible 3
				     #:numlin-visible 5
				     ))
	 (colnames       (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "State" "Transport"))
	 (colnames       (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId"))
	 (updater        (lambda ()
			   (let ((servers (open-run-close tasks:get-all-servers tasks:open-db)))
			   (let ((servers (tasks:get-all-servers (db:delay-if-busy tdbdat))))
			     (iup:attribute-set! servers-matrix "NUMLIN" (length servers))
			     ;; (set! colnum 0)
			     ;; (for-each (lambda (colname)
			     ;;    	 ;; (print "colnum: " colnum " colname: " colname)
			     ;;    	 (iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
			     ;;    	 (set! colnum (+ 1 colnum)))
			     ;;           colnames)
			     (set! rownum 1)
			     (for-each 
			      (lambda (server)
				(set! colnum 0)
				(let* ((vals (list (vector-ref server 0) ;; Id
						   (vector-ref server 9) ;; MT-Ver
						   (vector-ref server 1) ;; Pid
						   (vector-ref server 2) ;; Hostname
						   (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port
						   (seconds->hr-min-sec (- (current-seconds)(vector-ref server 6)))
						   (vector-ref server 5) ;; Pubport
						   ;; (vector-ref server 5) ;; Pubport
						   ;; (vector-ref server 10) ;; Last beat
						   ;; (vector-ref server 6) ;; Start time
						   ;; (vector-ref server 7) ;; Priority
						   ;; (vector-ref server 8) ;; State
						   (if (< (vector-ref server 10) 20) ;; Status (Please redo this properly!)
						   (vector-ref server 8) ;; State
						       "alive"
						       "dead")
						   (vector-ref server 11)  ;; Transport
						   (vector-ref server 12)  ;; RunId
						   )))
				  (for-each (lambda (val)
					      ;; (print "rownum: " rownum " colnum: " colnum " val: " val)
					      (iup:attribute-set! servers-matrix (conc rownum ":" colnum) val)
					      (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))
					      (set! colnum (+ 1 colnum)))
					      (let* ((row-col (conc rownum ":" colnum))
						     (curr-val (iup:attribute servers-matrix row-col)))
						(if (not (equal? (conc val) curr-val))
						    (begin
						      (iup:attribute-set! servers-matrix row-col val)
						      (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))))
						(set! colnum (+ 1 colnum))))
					    vals)
				  (set! rownum (+ rownum 1)))
				 (iup:attribute-set! servers-matrix "REDRAW" "ALL"))
			      servers)))))
    (set! colnum 0)
    (for-each (lambda (colname)
		(iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
		(iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))
		(set! colnum (+ colnum 1)))
	      colnames)
    (set! dashboard:update-servers-table updater) 
    ;; (iup:attribute-set! servers-matrix "WIDTHDEF" "40")
    (iup:hbox
     (iup:vbox
      (iup:button "Start"
		  ;; #:size "50x"
		  #:expand "YES"
		  #:action (lambda (obj)
			     (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
					      "megatest -server - &")))
					      ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
			       (system cmd))))
      (iup:button "Stop"
		  #:expand "YES"
		  ;; #:size "50x"
		  #:action (lambda (obj)
			     (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
					      "megatest -stop-server 0 &")))
					      ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
			       (system cmd))))
      (iup:button "Restart"
		  #:expand "YES"
		  ;; #:size "50x"
		  #:action (lambda (obj)
			     (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
					      "megatest -stop-server 0;megatest -server - &")))
					      ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
			       (system cmd)))))
      servers-matrix
     )))
  
   ;;  (iup:hbox
   ;;   (iup:vbox
   ;;    (iup:button "Start"
   ;;      	  ;; #:size "50x"
   ;;      	  #:expand "YES"
   ;;      	  #:action (lambda (obj)
   ;;      		     (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
   ;;      				      "megatest -server - &")))
   ;;      				      ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
   ;;      		       (system cmd))))
   ;;    (iup:button "Stop"
   ;;      	  #:expand "YES"
   ;;      	  ;; #:size "50x"
   ;;      	  #:action (lambda (obj)
   ;;      		     (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
   ;;      				      "megatest -stop-server 0 &")))
   ;;      				      ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
   ;;      		       (system cmd))))
   ;;    (iup:button "Restart"
   ;;      	  #:expand "YES"
   ;;      	  ;; #:size "50x"
   ;;      	  #:action (lambda (obj)
   ;;      		     (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
   ;;      				      "megatest -stop-server 0;megatest -server - &")))
   ;;      				      ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
   ;;      		       (system cmd)))))
   ;;    servers-matrix
   ;;   )))
    servers-matrix
    ))

;; The main menu
(define (dcommon:main-menu)
  (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
   (iup:menu-item "Files" (iup:menu   ;; Note that you can use either #:action or action: for options
		       (iup:menu-item "Open"  action: (lambda (obj)
							(iup:show (iup:file-dialog))
							(print "File->open " obj)))
		       (iup:menu-item "Save"  #:action (lambda (obj)(print "File->save " obj)))
		       (iup:menu-item "Exit"  #:action (lambda (obj)(exit)))))
			   (iup:menu-item "Open"  action: (lambda (obj)
							    (let* ((area-name (iup:textbox #:expand "HORIZONTAL"))
								   (fd        (iup:file-dialog #:dialogtype "DIR"))
								   (top       (iup:show fd #:modal? "YES")))
							      (iup:attribute-set! source-tb "VALUE"
										  (iup:attribute fd "VALUE"))
							      (iup:destroy! fd))))
			   ;; (lambda (obj)
			   ;;  (iup:show (iup:file-dialog))
			   ;;  (print "File->open " obj)))
			   (iup:menu-item "Save"  #:action (lambda (obj)(print "File->save " obj)))
			   (iup:menu-item "Exit"  #:action (lambda (obj)(exit)))))
   (iup:menu-item "Tools" (iup:menu
		       (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
		       ;; (iup:menu-item "Show dialog"     #:action (lambda (obj)
		       ;;  					   (show message-window
		       ;;  					     #:modal? #t
		       ;;  					     ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
		       ;;  					     ;; #:x 'mouse
		       ;;  					     ;; #:y 'mouse
		       ;;  )					     
		       ))))
			   (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
			   ;; (iup:menu-item "Show dialog"     #:action (lambda (obj)
			   ;;  					   (show message-window
			   ;;  					     #:modal? #t
			   ;;  					     ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
			   ;;  					     ;; #:x 'mouse
			   ;;  					     ;; #:y 'mouse
			   ;;  )					     
			   ))))

;;======================================================================
;; CANVAS STUFF FOR TESTS
;;======================================================================

(define (dcommon:draw-test cnv x y w h name selected)
  (let* ((llx x)
	 (lly y)
	 (urx (+ x w))
	 (ury (+ y h)))
(define (dcommon:draw-test cnv scalef x y w h name selected)
  (let* ((llx (* scalef x))
	 (lly (* scalef y))
	 (urx (* scalef (+ x w)))
	 (ury (* scalef (+ y h))))
    (canvas-text! cnv (+ llx 5)(+ lly 5) name) ;; (conc testname " (" xtorig "," ytorig ")"))
    (canvas-rectangle! cnv llx urx lly ury)
    (if selected (canvas-box! cnv llx (+ llx 5) lly (+ lly 5)))))

(define (dcommon:draw-arrow cnv test-box-center waiton-center)
  (let* ((test-box-center-x (vector-ref test-box-center 0))
	 (test-box-center-y (vector-ref test-box-center 1))
	 (waiton-center-x   (vector-ref waiton-center   0))
	 (waiton-center-y   (vector-ref waiton-center   1))
	 (delta-y           (- waiton-center-y test-box-center-y))
	 (delta-x           (- waiton-center-x test-box-center-x))
	 (abs-delta-x       (abs delta-x))
	 (abs-delta-y       (abs delta-y))
	 (use-delta-x       (> abs-delta-x abs-delta-y)) ;; use the larger one
	 (delta-ratio       (if use-delta-x
				(if (> abs-delta-x 0)
				    (/ abs-delta-y abs-delta-x)
				    1)
				(if (> abs-delta-y 0)
				    (/ abs-delta-x abs-delta-y)
				    1)))
	 (x-adj             (if use-delta-x
				8
				(* delta-ratio 8)))
	 (y-adj             (if use-delta-x
				(* x-adj delta-ratio)
				8))
	 (new-waiton-x      (inexact->exact
			     (round (if (> delta-x 0) ;; have positive x
					(- waiton-center-x x-adj)
					(+ waiton-center-x x-adj)))))
	 (new-waiton-y      (inexact->exact
			     (round (if (> delta-y 0)
					(- waiton-center-y y-adj)
					(+ waiton-center-y y-adj))))))
  ;; (canvas-line-width-set! cnv 5)
  (canvas-line! cnv
		test-box-center-x
		test-box-center-y
		new-waiton-x
		new-waiton-y
		)
  (canvas-mark! cnv new-waiton-x new-waiton-y)))

(define (dcommon:get-box-center box)
  (let* ((llx  (list-ref box 0))
	 (lly  (list-ref box 4))
	 (boxw (list-ref box 5))
	 (boxh (list-ref box 6)))
    (vector (+ llx (/ boxw 2))
	    (+ lly (/ boxh 2)))))

(define-inline (num->int num)
  (inexact->exact (round num)))

(define (dcommon:draw-edges cnv scalef edges)
  (for-each
   (lambda (e)
     (let loop ((x1 (car e))
		(y1 (cadr e))
		(x2 #f)
		(y2 #f)
		(tal (cddr e)))
       (if (and x1 y1 x2 y2)
	   (canvas-line! cnv x1 y1 x2 y2)) ;; (num->int x1)(num->int y1)(num->int x2)(num->int y2)))
       (if (< (length tal) 2)
	   (canvas-mark! cnv x1 y1) ;; (num->int x1)(num->int y1))
	   (loop (car tal)(cadr tal) x1 y1 (cddr tal)))))
   (map (lambda (e)(map (lambda (x)(num->int (* x scalef))) e)) edges)))


(define (dcommon:draw-arrows cnv testname tests-hash test-records)
  (let* ((test-box-info   (hash-table-ref tests-hash testname))
	 (test-box-center (dcommon:get-box-center test-box-info))
	 (test-record     (hash-table-ref test-records testname))
	 (waitons         (vector-ref test-record 2)))
    (for-each
     (lambda (waiton)
       (let* ((waiton-box-info (hash-table-ref/default tests-hash waiton #f))
	      (waiton-center   (dcommon:get-box-center (or waiton-box-info test-box-info))))
	 (dcommon:draw-arrow cnv test-box-center waiton-center)))
     waitons)
    ;; (debug:print 0 "test-box-info=" test-box-info)
    ;; (debug:print 0 "test-record=" test-record)
    ))

(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)
      (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8))
	     (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
	     (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
	     (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;;  (- xadj 1))))
	     (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5))))
(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)
  (let* ((dot-data ;; (map cdr (filter
		   ;; 	  (lambda (x)(equal? "node" (car x)))
	  (map string-split (tests:lazy-dot test-records "plain"))) ;; (tests:easy-dot test-records "plain")))
	 (scalef (hash-table-ref   tests-draw-state 'scalef))
	 (dotscale (hash-table-ref tests-draw-state 'dotscale))
	 (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
	 (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
	 (xtorig (+ test-browse-xoffset (* (/ sizex 2) 1 (- 0.5 xadj)))) ;;  (- xadj 1))))
	 (ytorig (+ test-browse-yoffset (* (/ sizey 2) 1 (- yadj 0.5))))
	     (boxw   90) ;; default, overriden by length estimate below
	     (boxh   25)
	 (boxw   10)
	     (gapx   20)
	     (gapy   30)
	     (tests-hash     (hash-table-ref tests-draw-state 'tests-info))
	     (selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
	(hash-table-set! tests-draw-state 'xtorig xtorig)
	(hash-table-set! tests-draw-state 'ytorig ytorig)
	(let ((longest-str   (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b)))))))
	  (let-values (((x-max y-max) (canvas-text-size cnv longest-str)))
             (if (> x-max boxw)(set! boxw (+ 10 x-max)))))
	;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj)
	 (tests-hash     (hash-table-ref tests-draw-state 'tests-info))
	 (selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
    ;; (print "dot-data=" dot-data)
    (hash-table-set! tests-draw-state 'xtorig xtorig)
    (hash-table-set! tests-draw-state 'ytorig ytorig)
    (let ((longest-str   (if (null? sorted-testnames) "         " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b))))))))
      (let-values (((x-max y-max) (canvas-text-size cnv longest-str)))
	(if (> x-max boxw)(set! boxw (+ 10 x-max)))))
    ;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj)
    (if (not (null? sorted-testnames))
	(let loop ((hed (car (reverse sorted-testnames)))
		   (tal (cdr (reverse sorted-testnames)))
		   (llx xtorig)
		   (tal (cdr (reverse sorted-testnames))))
	  (let* ((nodedat (let ((tmpres (filter (lambda (x)
						  (if (and (not (null? x))
		   (lly ytorig)
		   (urx (+ xtorig boxw))
		   (ury (+ ytorig boxh)))
							   (equal? (car x) "node"))
						      (equal? hed (cadr x))
						      #f))
	  ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury)
	  (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
	  ;; data used by mouse click calc. keep the wacky order for now.
	  (hash-table-set! tests-hash hed  (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh)) 
	  ;; (list llx lly boxw boxh)) ;; NB// Swap ury and lly
	  (if (not (null? tal))
	      ;; leave a column of space to the right to list items
	      (let ((have-room 
						dot-data)))
			    (if (null? tmpres)
				;;           llx  lly boxw boxh
				(list "0" "1" "1" (conc (length tal)) "2" "0.5") ;; return some junk
				(car tmpres))))
		 (edgedat (let ((edges (filter (lambda (x)  ;; filter for edge
						 (if (and (not (null? x))
							  (equal? (car x) "edge"))
						     (equal? hed (cadr x))
						     #f))
					       dot-data)))
			    (map (lambda (inlst)
				   (dcommon:process-polyline 
				    (map (lambda (instr)
					   (* dotscale (string->number instr))) ;; convert to number and scale
					 (let ((il (cddddr inlst)))
		     (if #t ;; put "auto" here where some form of auto rearanging can be done
			 (> (* 3 (+ boxw gapx)) (- urx xtorig))
					   (take il (- (length il) 2))))
				    (lambda (x y)
				      (list (+ x xtorig)
			 (< urx (- sizex boxw gapx boxw)))))  ;; is there room for another column?
		(loop (car tal)
		      (cdr tal)
		      (if have-room (+ llx boxw gapx) xtorig) ;; have room, 
		      (if have-room lly (+ lly boxh gapy))
					    (+ y ytorig)))
				    #f #f)) ;; process polyline
				 edges)))
		 (llx  (* (string->number (list-ref nodedat 2)) dotscale))
		 (lly  (* (string->number (list-ref nodedat 3)) dotscale))
		 (boxw (* (string->number (list-ref nodedat 4)) dotscale))
		 (boxh (* (string->number (list-ref nodedat 5)) dotscale))
		 (urx  (+ llx boxw))
		 (ury  (+ lly boxh)))
		      (if have-room (+ urx boxw gapx) (+ xtorig boxw))
		      (if have-room ury (+ ury boxh gapy))))))))

(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)
  (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8))
					; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury)
	    (dcommon:draw-test cnv scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
	    ;; (dcommon:draw-arrows cnv testname tests-hash test-records))
	    (dcommon:draw-edges cnv scalef edgedat)
	    
	    ;; data used by mouse click calc. keep the wacky order for now.
	    (hash-table-set! tests-hash hed  (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh edgedat)) 
	    ;; (list llx lly boxw boxh)) ;; NB// Swap ury and lly
	    (if (not (null? tal))
		(loop (car tal)
		      (cdr tal))))))
    ;; (for-each
    ;;  (lambda (testname)
    ;;    (dcommon:draw-arrows cnv testname tests-hash test-records))
    ;;  sorted-testnames))
    ))

;; per-point-proc required, remainder optional
;;
(define (dcommon:process-polyline line per-point-proc per-segment-proc last-segment-proc)
  (if (< (length line) 2)
      '()
      (let loop ((x1   (car  line))
		 (y1   (cadr line))
		 (x2   #f)
		 (y2   #f)
		 (tal  (cddr line))
		 (res  '()))
	(if (and x1 y1 x2 y2 per-segment-proc)
	    (per-segment-proc x1 y1 x2 y2))
	(if (< (length tal) 2)
	    (begin
	      (if last-segment-proc (last-segment-proc x1 y1 x2 y2))
	      (append res (per-point-proc x1 y1)))
	    (loop (car tal)(cadr tal) x1 y1 (cddr tal) (append res (per-point-proc x1 y1)))))))

(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)
  (let* ((scalef              (hash-table-ref tests-draw-state 'scalef))
	 (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
	 (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
	 (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;;  (- xadj 1))))
	 (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5))))
	 (xdelta (- (hash-table-ref tests-draw-state 'xtorig) xtorig))
	 (ydelta (- (hash-table-ref tests-draw-state 'ytorig) ytorig))
	 (tests-hash     (hash-table-ref tests-draw-state 'tests-info))
	 (selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
	 (xtorig              (+ test-browse-xoffset (* (/ sizex 2) (- xadj 0.5)))) ;;  (- xadj 1))))
	 (ytorig              (+ test-browse-yoffset (* (/ sizey 2) (- 0.5 yadj))))
	 (xdelta              (- (hash-table-ref tests-draw-state 'xtorig) xtorig))
	 (ydelta              (- (hash-table-ref tests-draw-state 'ytorig) ytorig))
	 (tests-hash          (hash-table-ref tests-draw-state 'tests-info))
	 (selected-tests      (hash-table-ref tests-draw-state 'selected-tests )))
    (hash-table-set! tests-draw-state 'xtorig xtorig)
    (hash-table-set! tests-draw-state 'ytorig ytorig)
    (if (not (null? sorted-testnames))
    (let loop ((hed (car (reverse sorted-testnames)))
	       (tal (cdr (reverse sorted-testnames))))
      (let* ((tvals (hash-table-ref tests-hash hed))
	     (llx   (+ xdelta (list-ref tvals 0)))
	     (lly   (+ ydelta (list-ref tvals 4)))
	     (boxw  (list-ref tvals 5))
	     (boxh  (list-ref tvals 6))
	     (urx   (+ llx boxw))
	     (ury   (+ lly boxh)))
	(dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
	(hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh))
	(if (not (null? tal))
	    ;; leave a column of space to the right to list items
	    (loop (car tal)
		  (cdr tal)))))))
	(let loop ((hed (car (reverse sorted-testnames)))
		   (tal (cdr (reverse sorted-testnames))))
	  (let* ((tvals (hash-table-ref tests-hash hed))
		 (llx   (+ xdelta (list-ref tvals 0)))
		 (lly   (+ ydelta (list-ref tvals 4)))
		 (boxw  (list-ref tvals 5))
		 (boxh  (list-ref tvals 6))
		 (edges (map (lambda (pline)
			       (dcommon:process-polyline pline
							 (lambda (x1 y1)
							   (list (+ x1 xdelta)
								 (+ y1 ydelta)))
							 #f #f))
			     (list-ref tvals 7)))
		 (urx   (+ llx boxw))
		 (ury   (+ lly boxh)))
	    (dcommon:draw-test cnv scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
	    (dcommon:draw-edges cnv scalef edges)
	    (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh edges))
	    (if (not (null? tal))
		;; leave a column of space to the right to list items
		(loop (car tal)
		      (cdr tal))))))))
    ;; (for-each
    ;;  (lambda (testname)
    ;;    (dcommon:draw-edges cnv scalef edges)) ;; (dcommon:draw-arrows cnv testname tests-hash test-records))
    ;;  sorted-testnames)))

;;======================================================================
;;  S T E P S
;;======================================================================

(define (dcommon:populate-steps teststeps steps-matrix)
  (let ((max-row 0))
    (if (null? teststeps)
	(iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS")
	(let loop ((hed    (car teststeps))
		   (tal    (cdr teststeps))
		   (rownum 1)
		   (colnum 1))
	  (if (> rownum max-row)(set! max-row rownum))
	  (let ((val     (vector-ref hed (- colnum 1)))
		(mtrx-rc (conc rownum ":" colnum)))
	    (iup:attribute-set! steps-matrix  mtrx-rc (if val (conc val) ""))
	    (if (< colnum 6)
		(loop hed tal rownum (+ colnum 1))
		(if (not (null? tal))
		    (loop (car tal)(cdr tal)(+ rownum 1) 1))))))
    (if (> max-row 0)
	(begin
	  ;; we are going to speculatively clear rows until we find a row that is already cleared
	  (let loop ((rownum  (+ max-row 1))
		     (colnum  0)
		     (deleted #f))
	    ;; (debug:print-info 0 "cleaning " rownum ":" colnum)
	    (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum))
		   (next-col (if (eq? colnum 6) 1 (+ colnum 1)))
		   (mtrx-rc  (conc rownum ":" colnum))
		   (curr-val (iup:attribute steps-matrix mtrx-rc)))
	      ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val)
	      (if (and (string? curr-val)
		       (not (equal? curr-val "")))
		  (begin
		    (iup:attribute-set! steps-matrix mtrx-rc "")
		    (loop next-row next-col #t))
		  (if (eq? colnum 6) ;; not done, didn't get a full blank row
		      (if deleted (loop next-row next-col #f)) ;; exit on this not met
		      (loop next-row next-col deleted)))))
	  (iup:attribute-set! steps-matrix "REDRAW" "ALL")))))