Megatest

(use iup test)

(define t #f) 

(define tree-dialog
  (dialog
   #:title "Tree Test"
   (let ((t1 (treebox

     )
(map (lambda (attr)
       (print attr " is " (attribute t attr)))
     '("KIND1" "PARENT2" "STATE1"))

(define (tree-find-node obj path)
  ;; start at the base of the tree
  (if (null? path)
      #f ;; or 0 ????
      (let loop ((hed      (car path))
		 (tal      (cdr path))
		 (depth    0)
		 (nodenum  0))
	;; (debug:print 0 "hed: " hed ", depth: " depth ", nodenum: " nodenum)
	;; nodes in iup tree are 100% sequential so iterate over nodenum
	(if (attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes


	    (let ((node-depth (string->number (attribute obj (conc "DEPTH" nodenum))))
		  (node-title (attribute obj (conc "TITLE" nodenum))))
	      ;; (print 0 "hed: " hed ", depth: " depth ", node-depth: " node-depth ", nodenum: " nodenum ", node-title: " node-title)
	      (if (and (equal? depth node-depth)
		       (equal? hed   node-title)) ;; yep, this is the one!
		  (if (null? tal) ;; end of the line
		      nodenum
		      (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum)))
		  ;; this is the case where we found part of the hierarchy but not 
		  ;; all of it, i.e. the node-depth went from deep to less deep
		  (if (> depth node-depth) ;; (+ 1 node-depth))
		      #f
		      (loop hed tal depth (+ nodenum 1)))))
	    #f))))

;; top is the top node name zeroeth node VALUE=0
(define (tree-add-node obj top nodelst)
  (if (not (attribute obj "TITLE0"))
      (attribute-set! obj "ADDBRANCH0" top))
  (cond
   ((not (string=? top (attribute obj "TITLE0")))
    (print "ERROR: top name " top " doesn't match " (attribute obj "TITLE0")))
   ((null? nodelst))
   (else
    (let loop ((hed      (car nodelst))
	       (tal      (cdr nodelst))
	       (depth    1)
	       (pathl    (list top)))
      ;; Because the tree dialog changes node numbers when
      ;; nodes are added or removed we must look up nodes
      ;; each and every time. 0 is the top node so default
      ;; to that.
      (let* ((newpath    (append pathl (list hed)))
	       (parentnode (tree-find-node obj pathl))
	       (nodenum    (tree-find-node obj newpath)))
	  ;; (print "newpath: " newpath ", nodenum " nodenum ", hed: " hed ", depth: " depth ", parentnode: " parentnode ", pathl: " pathl)
	  ;; Add the branch under lastnode if not found
	  (if (not nodenum)
	      (begin
		(attribute-set! obj (conc "ADDBRANCH" parentnode) hed)
		(if (null? tal)
		    #t
		    ;; reset to top
		    (loop (car nodelst)(cdr nodelst) 1 (list top)))) 
	      (if (null? tal) ;; if null here then this path has already been added
		  #t
		  ;; (if nodenum
		  (loop (car tal)(cdr tal)(+ depth 1) newpath)))))))) ;;  (if nodenum nodenum lastnode)))))))
	      ;; 	  (loop hed tal depth pathl lastnode)))))))

(test #f 0  (tree-find-node t '("Figures")))
(test #f 1  (tree-find-node t '("Figures" "Other")))
(test #f #f (tree-find-node t '("Figures" "Other"    "equilateral")))
(test #f 3  (tree-find-node t '("Figures" "triangle" "equilateral")))
(test #f #t (tree-add-node  t "Figures" '()))
(test #f #t (tree-add-node  t "Figures" '("a" "b" "c")))
(test #f 3  (tree-find-node t '("Figures" "a" "b" "c")))
(test #f #t (tree-add-node  t "Figures" '("d" "b" "c")))
(test #f 3  (tree-find-node t '("Figures" "d" "b" "c")))
(test #f 6  (tree-find-node t '("Figures" "a" "b" "c")))
(test #f #t (tree-add-node  t "Figures" '("a" "e" "c")))
(test #f 6  (tree-find-node t '("Figures" "a" "e" "c")))
(main-loop)

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "megatest-fossil-hash.scm")

(define help (conc "
Megatest, documentation at http://chiselapp.com/user/kiatoa/repository/megatest
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2012

Usage: megatest [options]
  -h                      : this help
  -version                : print megatest version (currently " megatest-version ")

    (client:launch))


(debug:setup)

(define *tim* (iup:timer))
(define *ord* #f)

(define *data* (make-vector 6 #f))
(define-inline (dboard:data-get-runs          vec)    (vector-ref  vec 0))
(define-inline (dboard:data-get-tests         vec)    (vector-ref  vec 1))
(define-inline (dboard:data-get-runs-matrix   vec)    (vector-ref  vec 2))
(define-inline (dboard:data-get-tests-tree    vec)    (vector-ref  vec 3))
(define-inline (dboard:data-get-tree-keys     vec)    (vector-ref  vec 4))
(define-inline (dboard:data-set-runs!         vec val)(vector-set! vec 0 val))
(define-inline (dboard:data-set-tests!        vec val)(vector-set! vec 1 val))
(define-inline (dboard:data-set-runs-matrix!  vec val)(vector-set! vec 2 val))
(define-inline (dboard:data-set-tests-tree!   vec val)(vector-set! vec 3 val))
(define-inline (dboard:data-set-tree-keys!    vec val)(vector-set! vec 4 val))

(dboard:data-set-tree-keys! *data* (make-hash-table))

(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")

(define (message-window msg)
  (iup:show
   (iup:dialog

;; The runconfigs.config file
;;
(define (rconfig)
  (iup:vbox
   (iup:frame #:title "Default")))




;;======================================================================
;; tree stuff
;;======================================================================

;; path is a list of nodes, each the child of the previous
;; this routine returns the id so another node can be added
;; either as a leaf or as a branch
;;
;; BUG: This needs a stop sensor for when a branch is exhausted
;;
(define (tree-find-node obj path)
  ;; start at the base of the tree
  (if (null? path)
      #f ;; or 0 ????
      (let loop ((hed      (car path))
		 (tal      (cdr path))
		 (depth    0)
		 (nodenum  0))


	;; nodes in iup tree are 100% sequential so iterate over nodenum
	(if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes


	    (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum))))
		  (node-title (iup:attribute obj (conc "TITLE" nodenum))))
	      (if (and (equal? depth node-depth)
		       (equal? hed   node-title)) ;; yep, this is the one!
		  (if (null? tal) ;; end of the line
		      nodenum
		      (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum)))
		  ;; this is the case where we found part of the hierarchy but not 
		  ;; all of it, i.e. the node-depth went from deep to less deep
		  (if (> depth node-depth) ;; (+ 1 node-depth))
		      #f
		      (loop hed tal depth (+ nodenum 1)))))
	    #f))))

;; top is the top node name zeroeth node VALUE=0
(define (tree-add-node obj top nodelst)
  (if (not (iup:attribute obj "TITLE0"))
      (iup:attribute-set! obj "ADDBRANCH0" top))
  (cond
   ((not (string=? top (iup:attribute obj "TITLE0")))
    (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0")))
   ((null? nodelst))
   (else
    (let loop ((hed      (car nodelst))
	       (tal      (cdr nodelst))
	       (depth    1)
	       (pathl    (list top)))
      ;; Because the tree dialog changes node numbers when
      ;; nodes are added or removed we must look up nodes
      ;; each and every time. 0 is the top node so default
      ;; to that.
      (let* ((newpath    (append pathl (list hed)))
	     (parentnode (tree-find-node obj pathl))
	     (nodenum    (tree-find-node obj newpath)))
	;; Add the branch under lastnode if not found
	(if (not nodenum)
	    (begin
	      (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed)
	      (if (null? tal)
		  #t
		  ;; reset to top
		  (loop (car nodelst)(cdr nodelst) 1 (list top)))) 
	    (if (null? tal) ;; if null here then this path has already been added
		#t
		(loop (car tal)(cdr tal)(+ depth 1) newpath))))))))


;; Test browser
(define (tests)
  (iup:hbox 
   (let* ((tb      (iup:treebox
		    #:selection_cb (lambda (obj id state)
				     (print "obj: " obj ", id: " id ", state: " state)))))
     (iup:attribute-set! tb "VALUE" "0")
     (iup:attribute-set! tb "NAME" "Runs")
     (dboard:data-set-tests-tree! *data* tb)
     tb)
   (iup:vbox
    )))
       
;; Overall runs browser
;;
(define (runs)

			   #:numlin-visible 7
			   #:click-cb (lambda (obj lin col status)
					(print "obj: " obj " lin: " lin " col: " col " status: " status)))))

    (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES")
    (iup:attribute-set! runs-matrix "WIDTH0" "100")

    (dboard:data-set-runs-matrix! *data* runs-matrix)
    (iup:hbox
     (iup:frame 
      #:title "Runs browser"
      (iup:vbox
       runs-matrix)))))

;; Browse and control a single run

     (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
     tabtop)))

;;======================================================================
;; Process runs
;;======================================================================

;; MOVE THIS INTO *data*
(define *cachedata* (make-hash-table))
(hash-table-set! *cachedata* "runid-to-col"    (make-hash-table))
(hash-table-set! *cachedata* "testname-to-row" (make-hash-table))

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

			     (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"))
				      (time-b   (db:get-value-by-header record-b header "event_time")))
				 (> time-a time-b)))
			     ))
	 (runid-to-col    (hash-table-ref *cachedata* "runid-to-col"))
	 (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) 
	 (colnum       1)
	 (rownum       0) ;; rownum = 0 is the header
	 ;; These are used in populating the tests tree
	 (branchnum   0)
	 (leafnum     0)) ;; IUP is funky here, keep adding using 
    
	 ;; tests related stuff

    (for-each (lambda (run-id)
		(let* (;; (run-id    (db:get-value-by-header rundat header "id"))
		       (run-record (hash-table-ref/default runs-hash run-id #f))
		       (key-vals   (map (lambda (key)(db:get-value-by-header run-record header key))
					  (map key:get-fieldname keys)))
		       (run-name   (db:get-value-by-header run-record header "runname"))
		       (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name)))
		  (iup:attribute-set! (dboard:data-get-runs-matrix *data*)
				      (conc rownum ":" colnum) col-name)
		  (hash-table-set! runid-to-col run-id (list colnum run-record))
		  ;; Here we update the tests treebox and tree keys














		  (tree-add-node (dboard:data-get-tests-tree *data*) "Runs" key-vals)












		  (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* ((new-test-dat   (car test-changes))
		       (removed-tests  (cadr test-changes))
		       (tests          (sort (map cadr (filter (lambda (testrec)

				(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")
							status
							state))
				(iup:attribute-set! (dboard:data-get-runs-matrix *data*)
						    (conc "BGCOLOR" rownum ":" colnum)
						    (gutils:get-color-for-state-status state status))
				))
			    tests)))
	      run-ids)

    (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)))



;; 













(define (newdashboard)
  (let* ((data     (make-hash-table))
	 (keys     (cdb:remote-run db:get-keys #f))
	 (runname  "%")
	 (testpatt "%")
	 (keypatts (map (lambda (k)(list (vector-ref k 0) "%")) keys))
	 (states   '())
	 (statuses '())
	 (nextmintime (current-milliseconds)))
    (dboard:data-set-runs! *data* data) ;; make this data available to the rest of the application
    (iup:show (main-panel))
    (iup:callback-set! *tim*
		       "ACTION_CB"
		       (lambda (x)
			 ;; Want to dedicate no more than 50% of the time to this so skip if
			 ;; 2x delta time has not passed since last query
			 (if (< nextmintime (current-milliseconds))