Megatest

  start-test-offset ;; up-down slider value

  ;; Canvas and drawing data
  cnv
  cnv-obj
  drawing
  draw-cache     ;; 
  start-row
  run-start-row
  max-row

  ;; Controls used to launch runs etc.
  command
  command-tb 
  run-name         ;; from run name setting widget
  states           ;; states for -state s1,s2 ...
  statuses         ;; statuses for -status s1,s2 ...

	      start-run-offset:     0
	      start-test-offset:    0
	      state-ignore-hash:    (make-hash-table)
	      status-ignore-hash:   (make-hash-table)
	      xadj:                 0
	      yadj:                 0
	      view-changed:         #t
	      run-start-row:        0
	      max-row:              0
	      )))
    (dboard:setup-tabdat dat)
    (dboard:setup-num-rows dat)
    dat))

(define (dboard:setup-tabdat tabdat)
  (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))

		   (db:test-get-event_time (hash-table-ref testsdat (car b))))))))))

(define (dashboard:run-times-tab-updater commondat tabdat tab-num)
  ;; each test is an object in the run component
  ;; each run is a component
  ;; all runs stored in runslib library
  (let* ((canvas-margin 10)
	 ;; (start-row     0) ;; each run starts in this row
	 ;; (run-start-row 0)
	 ;; (max-row       0) ;; the max row seen for this run
	 (row-height    10)
	 (runs-dat      (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
	 (runs-header   (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
	 (runs-hash     (let ((ht (make-hash-table)))
			  (for-each (lambda (run)
				      (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
				    (vector-ref runs-dat 1))
			  ht))
	 (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 runs-header "event_time"))
				       (time-b   (db:get-value-by-header record-b runs-header "event_time")))
				  (< time-a time-b)))))
	 (tb            (dboard:tabdat-runs-tree tabdat))
	 (num-runs      (length (hash-table-keys runs-hash)))

	 (update-start-time (current-seconds)))
    ;; fill in the tree
    (if tb (for-each (lambda (run-id)
		       (let* ((run-record (hash-table-ref/default runs-hash run-id #f))
			      (key-vals   (map (lambda (key)(db:get-value-by-header run-record runs-header key))
					       (dboard:tabdat-keys tabdat)))
			      (run-name   (db:get-value-by-header run-record runs-header "runname"))

		(cnv     (dboard:tabdat-cnv tabdat)))
	    (print "allruns: " allruns)
	    (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
			 ((originx originy)             (canvas-origin cnv)))
	      ;; (print "allruns: " allruns)
	      (let runloop ((rundat   (car allruns))
			    (runtal   (cdr allruns))
			    (run-num   1)
			    (doneruns '())
			    (run-start-row 0))
		(let* ((run       (dboard:rundat-run rundat))
		       (hierdat   (dboard:tests-sort-by-time-group-by-item (dboard:rundat-tests rundat))) ;; hierarchial list of ids
		       (tests-ht  (dboard:rundat-tests rundat))
		       (all-tids  (hash-table-keys   tests-ht)) ;; (apply append hierdat)) ;; was testsdat
		       (testsdat  (hash-table-values tests-ht))
		       (key-val-dat (dboard:rundat-key-vals rundat))
		       (run-id   (db:get-value-by-header run (dboard:tabdat-header tabdat) "id"))

		       (run-duration (- run-end run-start))
		       (timescale  (/ (- sizex (* 2 canvas-margin))
				      (if (> run-duration 0)
					  run-duration
					  (current-seconds)))) ;; a least lously guess
		       (maptime    (lambda (tsecs)(* timescale (+ tsecs timeoffset))))
		       (num-tests  (length hierdat))

		       (tot-tests  (length testsdat))
		       (new-run-start-row (+ (dboard:tabdat-max-row tabdat) 2)))
		  ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx)
		  (vg:add-comp-to-lib runslib run-full-name runcomp)
		  ;; (set! run-start-row (+ max-row 2))
		  ;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1))






		  ;; get tests in list sorted by event time ascending

		  (let testsloop ((test-ids  (car hierdat))              ;; loop on tests (NOTE: not items!)
				 (tests-tal (cdr hierdat))
				 (test-num  1))
		     (let ((test-objs   '())
			   (iterated     (> (length test-ids) 1))
			   (first-rownum #f)
			   (num-items    (length test-ids)))
		       (let testitemloop ((test-id  (car test-ids))    ;; loop on test or test items
					  (tidstal  (cdr test-ids))
					  (item-num 1))



			 (let* ((testdat      (hash-table-ref tests-ht test-id))
				(event-time   (maptime (db:test-get-event_time   testdat)))
				(run-duration (* timescale (db:test-get-run_duration testdat)))
				(end-time     (+ event-time run-duration))
				(test-name    (db:test-get-testname     testdat))
				(item-path    (db:test-get-item-path    testdat))
				(state         (db:test-get-state       testdat))
				(status        (db:test-get-status      testdat))
				(test-fullname (conc test-name "/" item-path))
				(name-color    (gutils:get-color-for-state-status state status)))

			   ;; (print "event_time: " (db:test-get-event_time   testdat) " mapped event_time: " event-time)
			   ;; (print "run-duration: "  (db:test-get-run_duration testdat) " mapped run_duration: " run-duration)
			   (if (> item-num 50)
			       (if (eq? 0 (modulo item-num 50))
				   (print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests")))
			   (let loop ((rownum new-run-start-row)) ;; (+ start-row 1)))
			     (dboard:tabdat-max-row-set! tabdat (max rownum (dboard:tabdat-max-row tabdat))) ;; track the max row used
			     (if (dashboard:row-collision rowhash rownum event-time end-time)
				 (loop (+ rownum 1))
				 (let* ((lly (- sizey (* rownum row-height)))
					(uly (+ lly row-height))
					(obj (vg:make-rect-obj event-time lly end-time uly
							       fill-color: (vg:iup-color->number (car name-color))
							       text: (if iterated item-path test-name)
							       font: "Helvetica -10")))
				   ;; (if iterated
				   ;;     (dashboard:add-bar rowhash (- rownum 1) event-time end-time num-rows: (+ 1 num-items))
				   (if (not first-rownum)
				       (begin
					 (dashboard:row-collision rowhash (- rownum 1) event-time end-time num-rows: num-items)
					 (set! first-rownum rownum)))
				   (dashboard:add-bar rowhash rownum event-time end-time)
				   (vg:add-obj-to-comp runcomp obj)
				   (set! test-objs (cons obj test-objs)))))
			   ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
			   (if (not (null? tidstal))
			       (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1)))))
		       ;; If it is an iterated test put box around it now.
		       (if iterated
			   (let* ((xtents (vg:get-extents-for-objs drawing test-objs))
				  (llx (- (car xtents)   5))
				  (lly (- (cadr xtents) 10))
				  (ulx (+ 5 (caddr xtents)))
				  (uly (+ 0 (cadddr xtents))))
			     (dashboard:add-bar rowhash first-rownum llx ulx num-rows:  num-items)
			     (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly
									   text:  (db:test-get-testname (hash-table-ref tests-ht (car test-ids)))
									   font: "Helvetica -10"))))
		       (if (not (null? tests-tal))
			   (testsloop  (car tests-tal)(cdr tests-tal)(+ test-num 1)))))
		 ;; placeholder box
		 (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1))
		 (let ((y   (- sizey (* (dboard:tabdat-max-row tabdat) row-height))))
		   (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
		 ;; instantiate the component 
		 (let* ((extents   (vg:components-get-extents drawing runcomp))
			;; move the following into mapping functions in vg.scm
			;; (deltax    (- llx ulx))
			;; (scalex    (if (> deltax 0)(/ sizex deltax) 1))
			;; (sllx      (* scalex llx))
			;; (offx      (- sllx originx))
			(new-xtnts (apply vg:grow-rect 5 5 extents))
			(llx       (list-ref new-xtnts 0))
			(lly       (list-ref new-xtnts 1))
			(ulx       (list-ref new-xtnts 2))
			(uly       (list-ref new-xtnts 3))
			) ;;  (vg:components-get-extents d1 c1)))
		   (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly text: run-full-name))
		   (vg:instantiate drawing "runslib" run-full-name run-full-name 0 0))
		 (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1)))
		;; end of the run handling loop 
		(let ((newdoneruns (cons rundat doneruns)))
		  (if (null? runtal)
		      (begin
			(dboard:tabdat-not-done-runs-set! tabdat '())
			(dboard:tabdat-done-runs-set! tabdat allruns))
		      (if (> (- (current-seconds) update-start-time) 5)
			  (begin
			    (print "drawing runs taking too long....  have " (length runtal) " remaining")
			    (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here!
			    (dboard:tabdat-not-done-runs-set! tabdat runtal))
			  (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns new-run-start-row)))))

	      (vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat)(dboard:tabdat-cnv tabdat)) ;; cnv-obj)
	      (canvas-clear! (dboard:tabdat-cnv tabdat)) ;; -obj)
	      (print "Number of objs: " (length (vg:draw (dboard:tabdat-drawing tabdat) #t)))
	      (dboard:tabdat-view-changed-set! tabdat #f)
	      )))
	(debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater"))))

(use canvas-draw iup foof-loop)
(import canvas-draw-iup)

(load "vg.scm")

(define numtorun 1000)
;; (if (> (length (argv)) 1)
;; 		     (string->number (cadr (argv)))
;; 		     1000))

;; (use trace)
;; (trace 
;;  vg:draw-rect
;;  vg:grow-rect
;;  vg:components-get-extents
;;  vg:instances-get-extents)

(define d1 (vg:drawing-new))
(define l1 (vg:lib-new))
(define c1 (vg:comp-new))
(define c2 (vg:comp-new))
(define bt1 (vg:make-rect-obj 10 40 20 50 text: "A long piece of text" font: "Helvetica, -10"))

(let ((r1 (vg:make-rect-obj 20 20 30 30 text: "r1" font: "Helvetica, -20"))
      (r2 (vg:make-rect-obj 30 30 60 60 text: "r2" font: "Helvetica, -10"))
      (t1 (vg:make-text-obj 60 60 "The middle" font: "Helvetica, -10")))
  (vg:add-objs-to-comp c1 r1 r2 t1 bt1))

(loop ((for x (up-from 0 (to 20))))
       (loop ((for y (up-from 0 (to 20))))
	     (vg:add-objs-to-comp c1 (vg:make-rect-obj x y (+ x 5)(+ y 5)))))
      
(let ((start (current-seconds)))
  (let loop ((i 0))
    (vg:add-obj-to-comp c1 (vg:make-rect-obj 0 0 100 100))
    (if (< i numtorun)(loop (+ i 1))))
  (print "Run time: " (- (current-seconds) start)))

;; add the c1 component to lib l1 with name firstcomp

;;   (vg:inst-apply-scale 
;;    inst
;;    (vg:drawing-apply-scale drawing lstxy)))

;; make a rectangle obj
;;
(define (vg:make-rect-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f))
  (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: extents))

;; make a rectangle obj
;; 
(define (vg:make-line-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f))
  (make-vg:obj type: 'l pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color extents: extents))

;; make a text obj
;;
(define (vg:make-text-obj x1 y1 text #!key (line-color #f)(fill-color #f)
		      (angle #f)(scale-with-zoom #f)(font #f)
		      (font-size #f))
  (make-vg:obj type: 't pts: (list x1 y1) text: text 
	       line-color: line-color fill-color: fill-color
	       angle: angle font: font extents: #f
	       attributes: (vg:make-attrib 'font-size font-size)))

;; proc takes startnum and endnum and yields scalef, per-grad and unitname
;;
(define (vg:make-xaxis-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(proc #f))
  (make-vg:obj type: 'x pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: #f proc: proc))

		    (let-values (((xmax ymax)(canvas-text-size cnv text)))
				(set! text-xmax xmax)(set! text-ymax ymax)))
		(if font-changed (canvas-font-set! cnv prev-font))))))
    ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
    (if (vg:obj-extents obj)
	(vg:obj-extents obj)
	(if (not text)
	    pts ;; no text
	    (if (and text-xmax text-ymax) ;; have text
		(let ((xt (list llx lly
				(max ulx (+ llx text-xmax))
				(max uly (+ lly text-ymax)))))
		  (vg:obj-extents-set! obj xt)
		  xt)
		(if cnv
		    (if (eq? draw 'get-extents)
			(let-values (((xmax ymax)(canvas-text-size cnv text)))
				    (let ((xt (list llx lly
						    (max ulx (+ llx xmax))
						    (max uly (+ lly ymax)))))
				      (vg:obj-extents-set! obj xt)
				      xt))
			pts)
		    pts)))))) ;; return extents 

;; given a rect obj draw it on the canvas applying first the drawing
;; scale and offset
;;
(define (vg:draw-line drawing obj #!key (draw #t))
  (let* ((cnv (vg:drawing-cnv drawing))
	 (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))