Megatest

;; data for each specific tab goes here
;;
(defstruct dboard:tabdat 
  ;; runs
  allruns          ;; list of dboard:rundat records
  allruns-by-id    ;; hash of run-id -> dboard:rundat records
  done-run-ids     ;; list of run-ids already drawn
  not-done-run-ids ;; list of run-ids not yet drawn
  header           ;; header for decoding the run records
  keys             ;; keys for this run (i.e. target components)
  numruns
  tot-runs

  ;; Runs view
  buttondat 
  item-test-names
  run-keys
  runs-matrix       ;; used in newdashboard
  start-run-offset  ;; left-right slider value
  start-test-offset ;; up-down slider value

  ;; Canvas and drawing data
  cnv
  cnv-obj
  drawing
  draw-cache     ;; 

  ;; 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 ...

  ;; Selector variables
  curr-run-id      ;; current row to display in Run summary view
  curr-test-ids    ;; used only in dcommon:run-update which is used in newdashboard
  filters-changed  ;; to to indicate that the user changed filters for this tab
  hide-empty-runs
  hide-not-hide    ;; toggle for hide/not hide empty runs
  hide-not-hide-button
  searchpatts
  state-ignore-hash    ;; hash of  STATE => #t/#f for display control
  status-ignore-hash   ;; hash of STATUS => #t/#f
  target
  test-patts

  ;; db info to file the .db files for the area
  dbdir
  dbfpath
  dbkeys 
  last-db-update  ;; last db file timestamp
  monitor-db-path ;; where to find monitor.db
  ro               ;; is the database read-only?

  ;; tests data
  last-update      ;; last time rmt:get-tests-for-run was used to get data
  num-tests
  num-tests        ;; total number of tests to show (used in the old runs display)

  path-run-ids
  ro
  run-keys
  run-name
  runs
  runs-listbox
  ;; runs tree
  path-run-ids     ;; path (target / runname) => id
  runs-matrix 
  runs-tree
  searchpatts

  start-run-offset
  start-test-offset
  state-ignore-hash
  states 
  ;; tab data
  status-ignore-hash
  statuses
  target
  test-patts
  last-update      ;; last time this tab was updated
  tests
  tests-tree
  tot-runs
  view-changed
  xadj
  yadj
  xadj             ;; x slider number (if using canvas)
  yadj             ;; y slider number (if using canvas)

  tests-tree       ;; used in newdashboard
  )

(define (dboard:tabdat-target-string vec)
  (let ((targ (dboard:tabdat-target vec)))
    (if (list? targ)(string-intersperse targ "/") "no-target-specified")))

(define (dboard:tabdat-test-patts-use vec)    

  )

;; used to keep the rundata from rmt:get-tests-for-run
;; in sync. 
;;
(defstruct dboard:rundat
  run
  tests-drawn
  tests  
  tests-drawn    ;; list of id's already drawn on screen
  tests-notdrawn ;; list of id's NOT already drawn
  tests          ;; hash of id => testdat
  key-vals
  last-update
  last-update    ;; last query to db got records from before last-update
  )

(define (dboard:runsdat-make-init)
  (make-dboard:runsdat
   runs-index: (make-hash-table)
   tests-index: (make-hash-table)
   matrix-dat: (make-sparse-array)))

	 (statuses    (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
	 (sort-info   (get-curr-sort))
	 (sort-by     (vector-ref sort-info 1))
	 (sort-order  (vector-ref sort-info 2))
	 (bubble-type (if (member sort-order '(testname))
			  'testname
			  'itempath))
	 (prev-dat    (let ((rec (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)))
			(if rec rec (make-dboard:rundat run: run tests: '() key-vals: key-vals last-update: -100)))) ;; -100 is before time began
	 (prev-tests  (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
	 (run-dat    (let ((rec (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)))
			(if rec rec (make-dboard:rundat run: run tests: (make-hash-table) key-vals: key-vals last-update: -100)))) ;; -100 is before time began
	 ;; (prev-tests  (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
	 (last-update (dboard:tabdat-last-update tabdat)) ;; (vector-ref prev-dat 3))
	 (tmptests    (rmt:get-tests-for-run run-id testnamepatt states statuses  ;; run-id testpatt states statuses
					     #f #f                                ;; offset limit 
					     (dboard:tabdat-hide-not-hide tabdat) ;; no-in
					     sort-by                              ;; sort-by
					     sort-order                           ;; sort-order
					     #f ;; 'shortlist                           ;; qrytype
					     (if (dboard:tabdat-filters-changed tabdat) 
						 0
						 last-update) ;; last-update
					     *dashboard-mode*)) ;; use dashboard mode
	 (tests      (dashboard:merge-changed-tests prev-tests tmptests  (dboard:tabdat-hide-not-hide tabdat) prev-tests)))
    (dboard:rundat-last-update-set! prev-dat (- (current-seconds) 10)) ;; go back two seconds in time to ensure all changes are captured.
	 (use-new    (dboard:tabdat-hide-not-hide tabdat))
	 (tests-ht   (dboard:rundat-tests run-dat))
	 (start-time (current-seconds)))
    (for-each 
     (lambda (tdat)
       (let ((test-id (db:test-get-id tdat))
	     (state   (db:test-get-state tdat)))
	 (if (equal? state "DELETED")
	     (hash-table-delete! tests-ht test-id)
	     (hash-table-set! tests-ht test-id tdat))))
     tmptests)
    (dboard:rundat-last-update-set! run-dat (- (current-seconds) 10)) ;; go back two seconds in time to ensure all changes are captured.
    (print "prev-tests: " (length prev-tests) " tests: " (length tests))
    tests))
    tests-ht))

;; tmptests   - new tests data
;; prev-tests - old tests data
;;
(define (dashboard:merge-changed-tests tests tmptests use-new prev-tests) 
;; (define (dashboard:merge-changed-tests tabdat tests tmptests) ;;  use-new prev-tests) 
  (let ((start-time (current-seconds))
	(newdat     (filter
		     (lambda (x)
		       (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging
		     (delete-duplicates (if use-new ;; (dboard:tabdat-filters-changed tabdat)
					    tmptests
					    (append tmptests prev-tests))
					(lambda (a b)
					  (eq? (db:test-get-id a)(db:test-get-id b)))))))
    (print "Time took: " (- (current-seconds) start-time))
    (if (eq? *tests-sort-reverse* 3) ;; +event_time
	(sort newdat dboard:compare-tests)
	newdat)))
;;   (let* ((newdat     (filter
;; 		      (lambda (x)
;; 			(not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging
;; 		      (delete-duplicates (if use-new ;; (dboard:tabdat-filters-changed tabdat)
;; 					     tmptests
;; 					     (append tmptests prev-tests))
;; 					 (lambda (a b)
;; 					   (eq? (db:test-get-id a)(db:test-get-id b)))))))
;;     (print "Time took: " (- (current-seconds) start-time))
;;     (if (eq? *tests-sort-reverse* 3) ;; +event_time
;; 	(sort newdat dboard:compare-tests)
;; 	newdat)))

;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
  (let* ((referenced-run-ids '())
	 (allruns     (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
  (let* ((allruns     (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns))
	 (start-time  (current-seconds)))
	 (result      '())
    (dboard:tabdat-header-set! tabdat header)
	 (maxtests    0))
    ;; 
    ;; trim runs to only those that are changing often here
    ;; 
    (for-each (lambda (run)
		(let* ((run-id      (db:get-value-by-header run header "id"))
		       (key-vals    (rmt:get-key-vals run-id))
		       (tests       (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
		       (num-tests   (length tests)))
		  ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
		  ;; (tests       (bubble-up tmptests priority: bubble-type))
		  ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
		  ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals)
		  ;; Not sure this is needed?
		  (if (not (null? tests))
    (if (not (null? runs))
	(let loop ((run      (car runs))
		   (tal      (cdr runs))
		   (res     '())
		   (maxtests 0))
	  (let* ((run-id       (db:get-value-by-header run header "id"))
		 (key-vals     (rmt:get-key-vals run-id))
		 (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
		 (all-test-ids (hash-table-keys tests-ht))
		 (num-tests    (length all-test-ids)))
	    ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
	    ;; (tests       (bubble-up tmptests priority: bubble-type))
	    ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
	    ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals)
	    ;; Not sure this is needed?
	    (if (not (null? all-test-ids))
		(let* ((newmaxtests (max num-tests maxtests))
		       (last-update (- (current-seconds) 10))
		       (run-struct  (make-dboard:rundat 
				     run:         run 
				     tests:       tests-ht
				     key-vals:    key-vals
				     last-update: last-update))
		       (new-res     (cons run-struct res))
		       (elapsed-time (- (current-seconds) start-time)))
		  (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)
		  (if (or (null? tal)
			  (> elapsed-time 5)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update
		      (begin
			(set! referenced-run-ids (cons run-id referenced-run-ids))
			(if (> num-tests maxtests)
			(if (> elapsed-time 5)(print "WARNING: timed out in update-testdat " elapsed-time "s"))
			    (set! maxtests num-tests))
			;; (if (or (not (dboard:tabdat-hide-empty-runs tabdat)) ;; this reduces the data burden when set
			;;	(not (null? tests)))
			(let* ((last-update (- (current-seconds) 10))
			       (run-struct  (make-dboard:rundat run: run tests: tests key-vals: key-vals last-update: last-update)))
			  (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)
			  (set! result (cons run-struct result)))))))
	      runs)
    (dboard:tabdat-header-set! tabdat header)
    (dboard:tabdat-allruns-set! tabdat result)
			(dboard:tabdat-allruns-set! tabdat new-res)
    (debug:print-info 6 *default-log-port* "(dboard:tabdat-allruns tabdat) has " (length (dboard:tabdat-allruns tabdat)) " runs")
    maxtests))
			maxtests)
		      (loop (car tal)(cdr tal) new-res newmaxtests)))))))))

(define *collapsed* (make-hash-table))

(define (toggle-hide lnum uidat) ; fulltestname)
  (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
	 (fulltestname (iup:attribute btn "TITLE"))
	 (parts        (string-split fulltestname "("))

  (if (null? lst)
      #f ;; better than an exception for my needs
      (fold (lambda (a b)
	      (if (comp a b) a b))
	    (car lst)
	    lst)))

(define-inline (dboard:sort-testsdat-by-event-time testsdat)
  (sort testsdat
(define-inline (dboard:sort-testsdat-by-event-time test-ids tests-ht)
  (sort test-ids
	(lambda (a b)
	  (< (db:test-get-event_time a)
	     (db:test-get-event_time b)))))
	  (< (db:test-get-event_time (hash-table-ref tests-ht a))
	     (db:test-get-event_time (hash-table-ref tests-ht b))))))

;; first group items into lists, then sort by time
;; finally sort by first item time
;;
;; 
;; NOTE: we are returning lists of lists of ids!
;;
(define (dboard:tests-sort-by-time-group-by-item testsdat)
  (let ((test-ids (hash-table-keys testsdat)))
  (if (null? testsdat)
      testsdat
      (let* ((tests (let ((ht (make-hash-table)))
		      (for-each
		       (lambda (tdat)
			 (let ((testname (db:test-get-testname tdat)))
			   (hash-table-set! 
			    ht 
			    testname
			    (cons tdat (hash-table-ref/default ht testname '())))))
		       testsdat)
		      ht)))
    (if (null? test-ids)
	test-ids
	;; now group all tests by testname tname => (id1 id2 ...), tname2 => ( ...
	(let* ((test-ids-by-name
		(let ((ht (make-hash-table)))
		  (for-each
		   (lambda (tdat)
		     (let ((testname (db:test-get-testname tdat))
			   (test-id  (db:test-get-id tdat)))
		       (hash-table-set! 
			ht 
			testname
			(cons test-id (hash-table-ref/default ht testname '())))))
		   (hash-table-values testsdat))
		  ht)))
	;; remove toplevel tests from iterated tests, sort tests in the list by event time
	(for-each 
	 (lambda (testname)
	   (let ((testslst (hash-table-ref tests testname)))
	     (if (> (length testslst) 1) ;; must be iterated
		 (let ((item-tests (filter (lambda (tdat) ;; filter out toplevel tests
					     (not (equal? (db:test-get-item-path tdat) "")))
					   testslst)))
	   (let ((tests-id-lst (hash-table-ref test-ids-by-name testname)))
	     (if (> (length tests-id-lst) 1) ;; must be iterated
		 (let ((item-tests (filter (lambda (tid) ;; filter out toplevel tests
					     (let ((tdat (hash-table-ref testsdat tid)))
					       (not (equal? (db:test-get-item-path tdat) ""))))
					   tests-id-lst)))
		   (if (not (null? item-tests)) ;; resist bad data, generally should not fail this condition
		       (hash-table-set! tests 
					testname 
					(dboard:sort-testsdat-by-event-time item-tests)))))))
	 (hash-table-keys tests))
	(sort (hash-table-values tests)
					(dboard:sort-testsdat-by-event-time item-tests testsdat)))))))
	 (hash-table-keys test-ids-by-name))
	(sort (hash-table-values test-ids-by-name)
	      (lambda (a b)
		(< (db:test-get-event_time (car a))
		   (db:test-get-event_time (car b))))))))
		(< (db:test-get-event_time (hash-table-ref testsdat (car a)))
		   (db:test-get-event_time (hash-table-ref testsdat (car b))))))))))

(define (dashboard:run-times-tab-updater commondat tab-num)
  ;; each test is an object in the run component
  ;; each run is a component
  ;; all runs stored in runslib library
  (let* ((tabdat        (dboard:common-get-tabdat commondat tab-num: tab-num))
	 (canvas-margin 10)

	     (dboard:tabdat-view-changed tabdat))
	(let* ((drawing    (dboard:tabdat-drawing tabdat))
	       (runslib    (vg:get/create-lib drawing "runslib")) ;; creates and adds lib
	       (compute-start (current-seconds)))
	  (vg:drawing-xoff-set! drawing (dboard:tabdat-xadj tabdat))
	  (vg:drawing-yoff-set! drawing (dboard:tabdat-yadj tabdat))
	  (print "Updating rundat")
	  (time (update-rundat tabdat
	  (update-rundat tabdat
			 "%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") 
			 100  ;; (dboard:tabdat-numruns tabdat)
			 "%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
			 ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
			 (let ((res '()))
			   (for-each (lambda (key)
				       (if (not (equal? key "runname"))
					   (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
					     (if val (set! res (cons (list key val) res))))))
				     (dboard:tabdat-dbkeys tabdat))
			   res)))
			   res))
	  (let ((allruns (dboard:tabdat-allruns tabdat))
		(rowhash (make-hash-table)) ;; store me in tabdat
		(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)
	      (for-each
	       (lambda (rundat)
		 (if rundat
		     (let* ((run       (dboard:rundat-run rundat))
			    (hierdat   (dboard:tests-sort-by-time-group-by-item (dboard:rundat-tests rundat)))
			    (testsdat  (apply append hierdat))
			    (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"))
			    (key-vals (append key-val-dat
					      (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname")))
						      (if x x "")))))
			    (run-key  (string-intersperse key-vals "\n"))
			    (run-full-name (string-intersperse key-vals "/"))

		;; (let ((x 10)
		;; 	     (y (- sizey (* start-row row-height))))
		;; 	 (vg:add-objs-to-comp runcomp (vg:make-text x y run-full-name font: "Helvetica -10"))
		;; 	 (dashboard:add-bar rowhash start-row x (+ x 100)))
		       (set! start-row (+ start-row 1))
		       ;; get tests in list sorted by event time ascending
		       (for-each 
			(lambda (testdats)
			(lambda (test-ids)
			  (let ((test-objs   '())
				(iterated     (> (length testdats) 1))
				(iterated     (> (length test-ids) 1))
				(first-rownum #f)
				(num-items    (length testdats))
				(num-items    (length test-ids))
				(item-num     0))
			    (set! test-num (+ test-num 1))
			    (for-each 
			     (lambda (testdat)
			       (let* ((event-time   (maptime (db:test-get-event_time   testdat)))
			     (lambda (test-id)
			       (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)))
				 (set! item-num (+ item-num 1))
				 ;; (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 run-start-row)) ;; (+ start-row 1)))
				   (set! max-row (max rownum max-row)) ;; track the max row used
				   (print "Allocating test")
				   (time (if (dashboard:row-collision rowhash rownum event-time end-time)
				   (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))))))
					 (set! test-objs (cons obj test-objs)))))
				 ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
				 ))
			   testdats)
			   test-ids)
			    ;; 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 (car testdats))
									     text:  (db:test-get-testname (hash-table-ref tests-ht (car test-ids)))
									     font: "Helvetica -10"))))))
			hierdat)
		       ;; placeholder box
		       (set! max-row (+ max-row 1))
		       (let ((y   (- sizey (* max-row row-height))))
			 (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
		       ;; instantiate the component