Megatest

(use iup)

(define t #f) 

(define tree-dialog
  (dialog
   #:title "Tree Test"
   (let ((t1 (treebox
	      #:selection_cb (lambda (obj id state)
			       (print "selection_db with id=" id " state=" state)
			       (print "SPECIALDATA: " (attribute obj "SPECIALDATA"))
			       ))))
     (set! t t1)
     t1)))

(show tree-dialog)

(map (lambda (elname el)
       (print "Adding " elname " with value " el)
       (attribute-set! t elname el)
       (attribute-set! t "SPECIALDATA" el))
     '("VALUE" "NAME"    "ADDLEAF" "ADDBRANCH1" "ADDLEAF2"    "VALUE")
     '("0"     "Figures" "Other"   "triangle"   "equilateral" "4")
     )
(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
  (let loop ((hed     (car path))
	     (tal     (cdr path))
	     (depth   0)
	     (nodenum 0))
    (attribute-set! obj "VALUE" nodenum)
    (if (not (equal? (string->number (attribute obj "VALUE")) nodenum))
	;; when not equal we have reached the end of the line
	#f
	(let ((node-depth (string->number (attribute obj (conc "DEPTH" nodenum))))
	      (node-title (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) nodenum))
	      (loop hed tal depth (+ nodenum 1)))))))

(main-loop)

    (client:launch))


(debug:setup)

(define *tim* (iup:timer))
(define *ord* #f)
(define *runs-matrix* #f) ;; This is the table of the runs, need it to be global (for now)
(define *runs-data*   #f)

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

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

		       ;;  					     #:modal? #t
		       ;;  					     ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
		       ;;  					     ;; #:x 'mouse
		       ;;  					     ;; #:y 'mouse
		       ;;  )					     
		       ))))

;; mtest is actually the megatest.config file
;;
(define (mtest)
  (let* ((curr-row-num     0)
	 (rawconfig        (read-config (conc *toppath* "/megatest.config") #f 'return-string))
	 (keys-matrix      (iup:matrix
		            #:expand "VERTICAL"
		            ;; #:scrollbar "YES"
		            #:numcol 1

		      validvals-matrix)
		     ))))
	 (iup:attribute-set! tabs "TABTITLE0" "Required settings")
	 (iup:attribute-set! tabs "TABTITLE1" "Optional settings")
	 tabs))
       ))))

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

(define *tests-treebox* #f)
(define *tests-node-map* (make-hash-table)) ;; map paths to nodes

;;======================================================================
;; 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
  (let loop ((hed      (car path))
	     (tal      (cdr path))
	     (depth    0)
	     (nodenum  0)
)
;;	     (maxdepth 9999999999999)) ;; Use TOTALCHILDCOUNTid
    (iup:attribute-set! obj "VALUE" nodenum)
    (if (not (equal? (string->number (iup:attribute obj "VALUE")) nodenum))
	;; when not equal we have reached the end of the line
	#f
	(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) nodenum))
	      (loop hed tal depth (+ nodenum 1)))))))

;; Test browser
(define (tests)
  (iup:hbox 
   (let* ((tb      (iup:treebox
		    #:selection_cb (lambda (obj id state)
				     (print "obj: " obj ", id: " id ", state: " state)))))
     (set! *tests-treebox* tb)
     tb)
   (iup:vbox
    )))
       
;; Overall runs browser
;;
(define (runs)
  (let* ((runs-matrix     (iup:matrix
			   #:expand "YES"
			   ;; #:fittosize "YES"
			   #:scrollbar "YES"
			   #:numcol 100
			   #:numlin 100
			   #:numcol-visible 7
			   #: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")



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

;; Browse and control a single run
;;
(define (runcontrol)
  (iup:hbox))

;; Main Panel
(define (main-panel)
  (iup:dialog
   #:title "Megatest Control Panel"
   #:menu (main-menu)
   (let ((tabtop (iup:tabs 
		  (runs)
		  (tests)
		  (runcontrol)
		  (mtest) 
		  (rconfig)

		  )))
     (iup:attribute-set! tabtop "TABTITLE0" "Runs")
     (iup:attribute-set! tabtop "TABTITLE1" "Tests")
     (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
     (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") 
     (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
     tabtop)))

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

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

;;
;; Mode is 'full or 'incremental for full refresh or incremental refresh
(define (run-update keys data runname keypatts testpatt states statuses mode)
  (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"))
	 (run-changes   (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts))
	 ;; 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)) '()))
	 (test-changes (synchash:client-get 'db:get-tests-for-runs-mindata get-tests-sig 0 data run-ids testpatt states statuses))
	 (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"))
				      (time-b   (db:get-value-by-header record-b header "event_time")))
				 (> time-a time-b)))
			     ))
	 (runid-to-col    (hash-table-ref *data* "runid-to-col"))
	 (testname-to-row (hash-table-ref *data* "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
	 ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes))))

    ;; Given a run-id and testname/item_path calculate a cell R:C

    ;; NOTE: Also build the test tree browser and look up table
    ;;
    ;; Each run is unique on its keys and runname or run-id, store in hash on colnum
    (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! *runs-matrix* (conc rownum ":" colnum) col-name)
		    (hash-table-set! runid-to-col run-id (list colnum run-record))
		    ;; Here we update *tests-treebox* and *tests-node-map* 
		    (let loop ((hed      (car key-vals))
			       (tal      (cdr key-vals))
			       (depth    0)
			       (pathl    (list (car key-vals))))
		      (let ((nodenum (tree-find-node *tests-treebox* pathl)))
			(if nodenum ;;
			    (if (not (null? tal)) ;; if null here then this path has already been added
				(loop (car tal)(cdr tal)(+ depth 1)(append pathl (list hed))))
			    (if (eq? depth 0)
				(iup:attribute-set! *tests-treebox* "INSERTBRANCH" hed)
				(debug:print 0 "ERROR: Failed to add " hed " no parent matching " pathl)))))
			    


;;		      (let* ((path         (string-intersperse pathl "/"))
;;			     (parent-found (hash-table-ref/default *tests-node-map* prevpath #f))
;;			     (found        (hash-table-ref/default *tests-node-map* path #f))
;;			     (refnode      (if parent-found parent-found 0))) ;; add to this node
;;			(if (not found) ;; this level in the hierarchy might have already been added
;;			    (begin
;;			      ;; first add to the tree
;;			      (iup:attribute-set! *tests-treebox* (conc "ADDBRANCH" (if refnode refnode 0)) hed)
;;			      (hash-table-set! *tests-node-map* path (iup:attribute *tests-treebox* "PARENT")))
;;		      (if (not (null? tal))
;;			  (loop (car tal)(cdr tal)(+ depth 1)(conc path "/" hed))))
		    (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))

			    tests)))
	      run-ids)

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

;; Given the master data struct and a key fill out the tree
;; browser for tests
;;
;; node-path is a hash of node-id to path key1/key2/key3/runname/testname/itempath
;;
;; (define (test-tree-update testtree runsdata node-path)
;;   (let* ((runs-sig   (conc (client:get-signature " get-runs")))
;; 	 (tests-sig  (conc (client:get-signature) " get-tests"))
;; 	 (runs-data  (hash-table-ref/default runsdata #f))
;; 	 (tests-data (hash-table-ref/default runsdata #f)))
;;     (if (not runs-data) 
;; 	(debug:print 0 "ERROR: no data found for " runs-sig)
;; 	(for-each (lambda (run-id)
;; 		    (let ((run-dat (hash-table-ref runs-data run-id)))
		    

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