Megatest

;; point inside line
;;
(define-inline (dashboard:px-between px lx1 lx2)
  (and (< lx1 px)(> lx2 px)))

;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing 
;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows)
;;
(define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f))

  (let ((collision #f)
	(lastrow   (if num-rows (+ rownum num-rows) rownum)))
    (let loop ((i      0)
	       (rowdat (hash-table-ref/default rowhash rownum '())))
      (for-each
       (lambda (bar)
	 (let ((bx1 (car bar))
	       (bx2 (cdr bar)))
	   (cond
	    ;; newbar x1 inside bar
	    ((dashboard:px-between x1 bx1 bx2)(set! collision #t))
	    ((dashboard:px-between x2 bx1 bx2)(set! collision #t))
	    ((and (<= x1 bx1)(>= x2 bx2))(set! collision #t)))))
       rowdat)
      (if (< i lastrow)
	  (loop (+ i 1)
		(hash-table-ref/default rowhash (+ rownum i) '()))))
    collision))

(define (dashboard:add-bar rowhash rownum x1 x2 #!key (num-rows 0))
  (let loop ((i 0))
    (hash-table-set! rowhash 
		     (+ i rownum)
		     (cons (cons x1 x2) 
			   (hash-table-ref/default rowhash (+ i rownum) '())))
    (if (< i num-rows)
	(loop (+ i 1)))))

;; get min or max, use > for max and < for min, this works around the limits on apply
;;
(define (dboard:min-max comp lst)
  (if (null? lst)
      #f ;; better than an exception for my needs
      (fold (lambda (a b)

	  (< (db:test-get-event_time a)
	     (db:test-get-event_time b)))))

;; first group items into lists, then sort by time
;; finally sort by first item time
;;
(define (dboard:tests-sort-by-time-group-by-item 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)))
	;; 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)))
		   (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)
	      (lambda (a b)
		(< (db:test-get-event_time (car a))
		   (db:test-get-event_time (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)

		;; 	     (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)
			  (let ((test-objs   '())
				(iterated     (> (length testdats) 1))
				(first-rownum #f)
				(num-items    (length testdats)))
			    (for-each 
			     (lambda (testdat)
			       (let* ((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)
				 (let loop ((rownum run-start-row)) ;; (+ start-row 1)))
				   (set! max-row (max rownum max-row)) ;; 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 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-objs-to-comp runcomp obj)
					 (set! test-objs (cons obj test-objs)))))
				 ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
				 ))
			   testdats)
			    ;; 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-objs-to-comp runcomp (vg:make-rect llx lly ulx uly
									     text:  (db:test-get-testname (car testdats))
									     font: "Helvetica -10"))))))
			hierdat)
		       ;; placeholder box
		       (set! max-row (+ max-row 1))
		       (let ((y   (- sizey (* max-row row-height))))
			 (vg:add-objs-to-comp runcomp (vg:make-rect 0 y 0 y)))
		       ;; instantiate the component 
		       (let* ((extents   (vg:components-get-extents drawing runcomp))

 vg:grow-rect
 vg:components-get-extents)

(define d1 (vg:drawing-new))
(define l1 (vg:lib-new))
(define c1 (vg:comp-new))
(define c2 (vg:comp-new))
(let ((r1 (vg:make-rect 20 20 30 30 text: "r1" font: "Helvetica, -20"))
      (r2 (vg:make-rect 30 30 60 60 text: "r2" font: "Helvetica, -10"))
      (t1 (vg:make-text 60 60 "The middle" font: "Helvetica, -10")))
  (vg:add-objs-to-comp c1 r1 r2 t1))

;; add the c1 component to lib l1 with name firstcomp
(vg:add-comp-to-lib l1 "firstcomp" c1)
(vg:add-comp-to-lib l1 "secondcomp" c2)

;; add the l1 lib to drawing with name firstlib

    (hash-table-set! (vg:drawing-insts drawing) instname inst)))

;; get component from drawing (look in apropriate lib) given libname and compname
(define (vg:get-component drawing libname compname)
  (let* ((lib  (hash-table-ref (vg:drawing-libs drawing) libname))
	 (inst (hash-table-ref (vg:lib-comps lib) compname)))
    inst))

(define (vg:get-extents-for-objs drawing objs)
  (let ((extents #f))



    (for-each
     (lambda (obj)
       (set! extents
	 (vg:get-extents-for-two-rects
	  extents
	  (vg:obj-get-extents drawing obj))))
     objs)
    extents))

;; given rectangles r1 and r2, return the box that bounds both
;;
(define (vg:get-extents-for-two-rects r1 r2)
  (if (not r1)
      r2
      (if (not r2)
	  #f ;; no extents from #f #f
	  (list (min (car r1)(car r2))           ;; llx
		(min (cadr r1)(cadr r2))         ;; lly
		(max (caddr r1)(caddr r2))       ;; ulx
		(max (cadddr r1)(cadddr r2)))))) ;; uly

(define (vg:components-get-extents drawing . comps)
  (let ((extents #f))
    (for-each
     (lambda (comp)
       (let* ((objs  (vg:comp-objs comp)))
	 (set! extents 
	   (vg:get-extents-for-two-rects
	    extents





	    (vg:get-extents-for-objs drawing objs)))))
     comps)

    extents))

;;======================================================================
;; libraries
;;======================================================================

;; register lib with drawing

	  (canvas-foreground-set! cnv prev-foreground-color)
	  (if text 
	      (let* ((prev-font    (canvas-font cnv))
		     (font-changed (and font (not (equal? font prev-font)))))
		(if font-changed (canvas-font-set! cnv font))
		(canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
		(if font-changed (canvas-font-set! cnv prev-font))))))
    (if (not text)
	pts
	(if cnv
	    (let-values (((xmax ymax)(canvas-text-size cnv text)))
	      (list llx lly
		    (max ulx (+ llx xmax))
		    (max uly (+ lly ymax))))
	    pts)))) ;; return extents 

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