Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -206,13 +206,17 @@ (key-listboxes #f) (key-lbs #f) 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 + prev-run-id ;; previous runid selected before current runid was selected + (xor-src-runid-label #f) + (xor-dest-runid-label #f) + (mode-flag (make-parameter 'view-one-run)) + curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard ((filters-changed #f) : boolean) ;; to to indicate that the user changed filters for this tab ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters ((hide-empty-runs #f) : boolean) ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs @@ -1113,11 +1117,11 @@ (dboard:tabdat-target-set! tabdat targ) ;; (if (dboard:tabdat-updater-for-runs tabdat) ;; ((dboard:tabdat-updater-for-runs tabdat))) (if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat))) (equal? (dboard:tabdat-run-name tabdat) "")) - (dboard:tabdat-run-name-set! tabdat curr-runname)) + (dboard:tabdat-run-name-set! tabdat curr-runname)) (dashboard:update-run-command tabdat))) (define (dashboard:run-controls commondat tabdat #!key (tab-num #f)) (let* ((targets (make-hash-table)) (test-records (make-hash-table)) @@ -1141,30 +1145,55 @@ (iup:vbox (dcommon:command-execution-control tabdat) (iup:split #:orientation "VERTICAL" ;; "HORIZONTAL" #:value 200 -;; -;; (iup:split -;; #:value 300 - - ;; Target, testpatt, state and status input boxes - ;; - (iup:vbox - ;; Command to run, placed over the top of the canvas - (dcommon:command-action-selector commondat tabdat tab-num: tab-num) - (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) - (dcommon:command-testname-selector commondat tabdat update-keyvals)) ;; key-listboxes)) - - (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)) - - ;;(iup:frame - ;; #:title "Logs" ;; To be replaced with tabs - ;; (let ((logs-tb (iup:textbox #:expand "YES" - ;; #:multiline "YES"))) - ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) - ;; logs-tb)) + ;; + ;; (iup:split + ;; #:value 300 + + ;; Target, testpatt, state and status input boxes + ;; + (iup:vbox + ;; Command to run, placed over the top of the canvas + (dcommon:command-action-selector commondat tabdat tab-num: tab-num) + (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) + (dcommon:command-testname-selector commondat tabdat update-keyvals)) ;; key-listboxes)) + + (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)) + + ;;(iup:frame + ;; #:title "Logs" ;; To be replaced with tabs + ;; (let ((logs-tb (iup:textbox #:expand "YES" + ;; #:multiline "YES"))) + ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) + ;; logs-tb)) + ))) + +(define (dboard:xor-ui-update tabdat) + (let* ((mode-flag (dboard:tabdat-mode-flag tabdat)) + (current-mode (mode-flag)) + (xor-src-runid-label (dboard:tabdat-xor-src-runid-label tabdat)) + (xor-dest-runid-label (dboard:tabdat-xor-dest-runid-label tabdat)) + (curr-run-id (dboard:tabdat-curr-run-id tabdat)) + (prev-run-id (dboard:tabdat-prev-run-id tabdat)) + (curr-runname (if curr-run-id + (rmt:get-run-name-from-id curr-run-id) + "None")) + (prev-runname (if prev-run-id + (rmt:get-run-name-from-id prev-run-id) + "None")) + ) + + (case current-mode + ((view-one-run) + (iup:attribute-set! xor-src-runid-label "TITLE" "") + (iup:attribute-set! xor-dest-runid-label "TITLE" "")) + ((xor-two-runs) + (iup:attribute-set! xor-src-runid-label "TITLE" (conc " SRC: "prev-runname" ")) + (iup:attribute-set! xor-dest-runid-label "TITLE" (conc "DEST: "curr-runname" "))) + (else (print "BB> should never arrive here")) ))) (define (dboard:runs-tree-browser commondat tabdat) (let* ((tb (iup:treebox #:value 0 @@ -1174,16 +1203,28 @@ #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () (let* ((run-path (tree:node->path obj id)) - (run-id (tree-path->run-id tabdat (cdr run-path)))) - (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print "run-path: " run-path) + (run-id (tree-path->run-id tabdat (cdr run-path))) + (curr-runname (dboard:tabdat-run-name tabdat))) + + + + (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print "run-path: " run-path) (dboard:tabdat-layout-update-ok-set! tabdat #f) (if (number? run-id) (begin + ;; capture last two in tabdat. + (dboard:tabdat-prev-run-id-set! + tabdat + (dboard:tabdat-curr-run-id tabdat)) (dboard:tabdat-curr-run-id-set! tabdat run-id) + + (dboard:tabdat-run-name-set! tabdat curr-runname) + + (dboard:xor-ui-update tabdat) (dboard:tabdat-view-changed-set! tabdat #t)) (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) "treebox")) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) @@ -1300,10 +1341,15 @@ (define (tree-path->run-id tabdat path) (if (not (null? path)) (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) #f)) + +(define (tree-path->run-name tabdat path) + (if (not (null? path)) + (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) + #f)) (define (dboard:get-tests-dat tabdat run-id last-update) (let* ((tdat (if run-id (rmt:get-tests-for-run run-id (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() @@ -1363,16 +1409,18 @@ userdata: (conc "run-id: " run-id)) (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids))) - -(define (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix) + +(define (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix ) (let* ((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 (run-id (dboard:tabdat-curr-run-id tabdat)) (last-update (hash-table-ref/default (dboard:tabdat-run-update-times tabdat) run-id 0)) + (tests-dat (dboard:get-tests-dat tabdat run-id last-update)) ;; does query to get run info + (tests-mindat (dcommon:minimize-test-data tests-dat)) ;; reduces data for display (db-path (or (hash-table-ref/default (dboard:tabdat-run-db-paths tabdat) run-id #f) (let* ((db-dir (tasks:get-task-db-path)) (db-pth (conc db-dir "/" run-id ".db"))) (hash-table-set! (dboard:tabdat-run-db-paths tabdat) run-id db-pth) db-pth))) @@ -1379,11 +1427,10 @@ (tests-dat (if (or (not run-id) (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps") (>= (file-modification-time db-path) last-update)) (dboard:get-tests-dat tabdat run-id last-update) (dboard:tabdat-last-test-dat tabdat))) - (tests-mindat (dcommon:minimize-test-data tests-dat)) (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) (row-indices (cadr indices)) (col-indices (car indices)) (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) @@ -1421,11 +1468,11 @@ (begin (set! changed #t) (iup:attribute-set! run-matrix key name))))) row-indices) - ;; (print "row-indices: " row-indices " col-indices: " col-indices) +;;(print "row-indices: " row-indices " col-indices: " col-indices) (if (and (eq? pass-num 0) changed) (loop 1 #t)) ;; force second pass ;; Cell contents (for-each (lambda (entry) @@ -1467,10 +1514,114 @@ (loop 1 #t)) ;; force second pass due to column labels changing ;; (debug:print 0 *default-debug-port* "one-run-updater, changed: " changed " pass-num: " pass-num) ;; (print "one-run-updater, changed: " changed " pass-num: " pass-num) (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))) + + + + +(define (dashboard:xor-two-runs-updater commondat tabdat tb cell-lookup run-matrix ) + (let* ((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 + (prev-run-id (dboard:tabdat-prev-run-id tabdat)) + (curr-run-id (dboard:tabdat-curr-run-id tabdat)) + (last-update 0) ;; fix me - have to create and store a rundat record for this + (dest-tests-dat (dboard:get-tests-dat tabdat curr-run-id last-update)) ;; does query to get run info + (src-tests-dat (dboard:get-tests-dat tabdat prev-run-id last-update)) ;; does query to get run info + + ;;; STOPPED HERE + (dest-tests-mindat (dcommon:minimize-test-data dest-tests-dat)) ;; reduces data for display + (src-tests-mindat (dcommon:minimize-test-data src-tests-dat)) ;; reduces data for display + ;;(tests-mindat dest-tests-mindat) + (tests-mindat (dcommon:xor-tests-mindat src-tests-mindat dest-tests-mindat)) ;; TODO: flags for common, modified, new -- like meld + (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) + (row-indices (cadr indices)) + (col-indices (car indices)) + (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) + (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) + (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window + (numrows 1) + (numcols 1) + (changed #f) + (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))) + (dboard:tabdat-filters-changed-set! tabdat #f) + (let loop ((pass-num 0) + (changed #f)) + ;; Update the runs tree + (dboard:update-tree tabdat runs-hash runs-header tb) + +(if (eq? pass-num 1) + (begin ;; big reset + (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS + (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") + (iup:attribute-set! run-matrix "NUMCOL" max-col ) + (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)))) ;; min of 20 + + ;; Row labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc num ":0"))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name))))) + row-indices) + +;;(print "row-indices: " row-indices " col-indices: " col-indices) + (if (and (eq? pass-num 0) changed) + (loop 1 #t)) ;; force second pass + + ;; Cell contents + (for-each (lambda (entry) + ;; (print "entry: " entry) + (let* ((row-name (cadr entry)) + (col-name (car entry)) + (valuedat (caddr entry)) + (test-id (list-ref valuedat 0)) + (test-name row-name) ;; (list-ref valuedat 1)) + (item-path col-name) ;; (list-ref valuedat 2)) + (state (list-ref valuedat 1)) + (status (list-ref valuedat 2)) + (value (gutils:get-color-for-state-status state status)) + (row-num (cadr (assoc row-name row-indices))) + (col-num (cadr (assoc col-name col-indices))) + (key (conc row-num ":" col-num))) + (hash-table-set! cell-lookup key test-id) + (if (not (equal? (iup:attribute run-matrix key) (cadr value))) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key (cadr value)) + (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) + tests-mindat) + + ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. + + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name) + (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) + col-indices) + + (if (and (eq? pass-num 0) changed) + (loop 1 #t)) ;; force second pass due to column labels changing + + ;; (debug:print 0 *default-debug-port* "one-run-updater, changed: " changed " pass-num: " pass-num) + ;; (print "one-run-updater, changed: " changed " pass-num: " pass-num) + (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))) + ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; @@ -1517,32 +1668,60 @@ ;; (define dashboard:update-new-view-tab #f) ;; This is the Run Summary tab ;; (define (dashboard:one-run commondat tabdat #!key (tab-num #f)) - (let* ((tb (iup:treebox - #:value 0 - #:name "Runs" - #:expand "YES" - #:addexpanded "NO" - #:selection-cb - (lambda (obj id state) - ;; (print "obj: " obj ", id: " id ", state: " state) - (let* ((run-path (tree:node->path obj id)) - (run-id (tree-path->run-id tabdat (cdr run-path)))) - (if (number? run-id) - (begin - (dboard:tabdat-curr-run-id-set! tabdat run-id) - (dboard:tabdat-layout-update-ok-set! tabdat #f) - ;; (dashboard:update-run-summary-tab) - ) - ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id) - )) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - ))) - (cell-lookup (make-hash-table)) - (run-matrix (iup:matrix + (let* ((view-one-run-button #f) + (xor-two-runs-button #f) + (sel-color "180 100 100") + (nonsel-color "170 170 170") + (mode-flag (dboard:tabdat-mode-flag tabdat)) + (tb (dboard:runs-tree-browser commondat tabdat)) + (cell-lookup (make-hash-table)) + (mode-selector + (iup:hbox + (let ((temp-button + (iup:button "View One Run" + #:bgcolor sel-color + #:action + (lambda (obj) + (debug:catch-and-dump + (lambda () + (mode-flag 'view-one-run) + (iup:attribute-set! obj "BGCOLOR" sel-color) + (iup:attribute-set! xor-two-runs-button "BGCOLOR" nonsel-color) + (dboard:xor-ui-update tabdat)) + "temp-button-1")) + ))) + (set! view-one-run-button temp-button) + + temp-button) + (let ((temp-button + (iup:button "XOR Two Runs" + #:action + (lambda (obj) + (debug:catch-and-dump + (lambda () + (mode-flag 'xor-two-runs) + (iup:attribute-set! obj "BGCOLOR" sel-color) + (iup:attribute-set! view-one-run-button "BGCOLOR" nonsel-color) + (dboard:xor-ui-update tabdat)) + "temp-button-2")) + ))) + (set! xor-two-runs-button temp-button) + temp-button) + (let ((temp-label + (iup:label "" #:size "125x15" #:fontsize "10" ))) + (dboard:tabdat-xor-src-runid-label-set! tabdat temp-label) + temp-label + ) + (let ((temp-label + (iup:label "" #:size "125x15" #:fontsize "10"))) + (dboard:tabdat-xor-dest-runid-label-set! tabdat temp-label) + temp-label))) + + (run-matrix (iup:matrix #:expand "YES" #:click-cb (lambda (obj lin col status) (let* ((toolpath (car (argv))) (key (conc lin ":" col)) @@ -1549,202 +1728,31 @@ (test-id (hash-table-ref/default cell-lookup key -1)) (cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id "&"))) (system cmd))))) (one-run-updater (lambda () (if (dashboard:database-changed? commondat tabdat) - (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix))))) - (dboard:commondat-add-updater commondat one-run-updater tab-num: tab-num) + (case (mode-flag) + ((view-one-run) + (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix)) + ((xor-two-runs) + (dashboard:xor-two-runs-updater commondat tabdat tb cell-lookup run-matrix)) + ) + (dboard:xor-ui-update) + )))) + + (dboard:commondat-add-updater commondat one-run-updater tab-num: tab-num) ;; register updater (dboard:tabdat-runs-tree-set! tabdat tb) - (iup:split - tb - run-matrix))) -;; (iup:vbox -;; (let* ((cnv-obj (iup:canvas -;; ;; #:size "500x400" -;; #:expand "YES" -;; #:scrollbar "YES" -;; #:posx "0.5" -;; #:posy "0.5" -;; #:action (make-canvas-action -;; (lambda (c xadj yadj) -;; (debug:catch-and-dump -;; (lambda () -;; (if (not (dboard:tabdat-cnv tabdat)) -;; (dboard:tabdat-cnv-set! tabdat c)) -;; (let ((drawing (dboard:tabdat-drawing tabdat)) -;; (old-xadj (dboard:tabdat-xadj tabdat)) -;; (old-yadj (dboard:tabdat-yadj tabdat))) -;; (if (not (and (eq? xadj old-xadj)(eq? yadj old-yadj))) -;; (begin -;; (print "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj)) -;; (dboard:tabdat-view-changed-set! tabdat #t) -;; (dboard:tabdat-xadj-set! tabdat (* -500 (- xadj 0.5))) -;; (dboard:tabdat-yadj-set! tabdat (* 500 (- yadj 0.5))) -;; )))) -;; "iup:canvas action dashboard:one-run"))) -;; #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. -;; (debug:catch-and-dump -;; (lambda () -;; (let* ((drawing (dboard:tabdat-drawing tabdat)) -;; (scalex (vg:drawing-scalex drawing))) -;; (dboard:tabdat-view-changed-set! tabdat #t) -;; (print "step: " step " x: " x " y: " y " dir: " dir " scalex: " scalex) -;; (vg:drawing-scalex-set! drawing -;; (+ scalex -;; (if (> step 0) -;; (* scalex 0.02) -;; (* scalex -0.02)))))) -;; "dashboard:one-run wheel-cb")) -;; ))) -;; cnv-obj)))) - - -;; This is the New View tab -;; -;; (define (dashboard:new-view db commondat tabdat #!key (tab-num #f)) -;; (let* ((tb (iup:treebox -;; #:value 0 -;; #:name "Runs" -;; #:expand "YES" -;; #:addexpanded "NO" -;; #:selection-cb -;; (lambda (obj id state) -;; ;; (print "obj: " obj ", id: " id ", state: " state) -;; (let* ((run-path (tree:node->path obj id)) -;; (run-id (tree-path->run-id tabdat (cdr run-path)))) -;; (if (number? run-id) -;; (begin -;; (dboard:tabdat-curr-run-id-set! tabdat run-id) -;; ;; (dashboard:update-new-view-tab) -;; (dboard:tabdat-layout-update-ok-set! tabdat #f) -;; ) -;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id))) -;; ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) -;; ))) -;; (cell-lookup (make-hash-table)) -;; (run-matrix (iup:matrix -;; #:expand "YES" -;; #:click-cb -;; (lambda (obj lin col status) -;; (let* ((toolpath (car (argv))) -;; (key (conc lin ":" col)) -;; (test-id (hash-table-ref/default cell-lookup key -1)) -;; (cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id "&"))) -;; (system cmd))))) -;; (new-view-updater (lambda () -;; (if (dashboard:database-changed? commondat tabdat) -;; (let* ((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 -;; (run-id (dboard:tabdat-curr-run-id tabdat)) -;; (last-update 0) ;; fix me -;; (tests-dat (dboard:get-tests-dat tabdat run-id last-update)) -;; (tests-mindat (dcommon:minimize-test-data tests-dat)) -;; (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) -;; (row-indices (cadr indices)) -;; (col-indices (car indices)) -;; (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) -;; (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) -;; (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window -;; (numrows 1) -;; (numcols 1) -;; (changed #f) -;; (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)))))) -;; ;; (iup:attribute-set! tb "VALUE" "0") -;; ;; (iup:attribute-set! tb "NAME" "Runs") -;; ;; Update the runs tree -;; (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")) -;; (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) -;; (run-path (append key-vals (list run-name))) -;; (existing (tree:find-node tb run-path))) -;; (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) -;; (begin -;; (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) -;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) -;; ;; (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 tb "Runs" run-path ;; (append key-vals (list run-name)) -;; userdata: (conc "run-id: " run-id)) -;; (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) -;; ;; (set! colnum (+ colnum 1)) -;; )))) -;; run-ids) -;; (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS -;; (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") -;; (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") -;; (iup:attribute-set! run-matrix "NUMCOL" max-col ) -;; (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 -;; ;; (iup:attribute-set! run-matrix "NUMCOL_VISIBLE" max-col) -;; ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) -;; -;; ;; Row labels -;; (for-each (lambda (ind) -;; (let* ((name (car ind)) -;; (num (cadr ind)) -;; (key (conc num ":0"))) -;; (if (not (equal? (iup:attribute run-matrix key) name)) -;; (begin -;; (set! changed #t) -;; (iup:attribute-set! run-matrix key name))))) -;; row-indices) -;; -;; -;; ;; Cell contents -;; (for-each (lambda (entry) -;; (let* ((row-name (cadr entry)) -;; (col-name (car entry)) -;; (valuedat (caddr entry)) -;; (test-id (list-ref valuedat 0)) -;; (test-name row-name) ;; (list-ref valuedat 1)) -;; (item-path col-name) ;; (list-ref valuedat 2)) -;; (state (list-ref valuedat 1)) -;; (status (list-ref valuedat 2)) -;; (value (gutils:get-color-for-state-status state status)) -;; (row-num (cadr (assoc row-name row-indices))) -;; (col-num (cadr (assoc col-name col-indices))) -;; (key (conc row-num ":" col-num))) -;; (hash-table-set! cell-lookup key test-id) -;; (if (not (equal? (iup:attribute run-matrix key) (cadr value))) -;; (begin -;; (set! changed #t) -;; (iup:attribute-set! run-matrix key (cadr value)) -;; (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) -;; tests-mindat) -;; -;; ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. -;; -;; (for-each (lambda (ind) -;; (let* ((name (car ind)) -;; (num (cadr ind)) -;; (key (conc "0:" num))) -;; (if (not (equal? (iup:attribute run-matrix key) name)) -;; (begin -;; (set! changed #t) -;; (iup:attribute-set! run-matrix key name) -;; (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) -;; col-indices) -;; (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))) -;; (dboard:commondat-add-updater commondat new-view-updater tab-num: tab-num) -;; (dboard:tabdat-runs-tree-set! tabdat tb) -;; (iup:split -;; tb -;; run-matrix))) + + (iup:vbox + (iup:split + #:value 150 + tb + run-matrix) + mode-selector) +)) + + ;;====================================================================== ;; R U N S ;;====================================================================== Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -282,10 +282,107 @@ (newitem (list test-name item-path (list test-id state status)))) (if (null? tal) (reverse (cons newitem res)) (loop (car tal)(cdr tal)(cons newitem res))))))) + +(define (dcommon:tests-mindat->hash tests-mindat) + (let* ((res (make-hash-table))) + (for-each + (lambda (item) + (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1))) + (value (list-ref item 2))) + (hash-table-set! res test-name+item-path value))) + tests-mindat) + res)) + +;; return 1 if status1 is better +;; return 0 if status1 and 2 are equally good +;; return -1 if status2 is better +(define (dcommon:status-compare3 status1 status2) + (let* + ((status-goodness-ranking (list "PASS" "WARN" "WAIVED" "SKIP" "FAIL" "ABORT" #f)) + (mem1 (member status1 status-goodness-ranking)) + (mem2 (member status2 status-goodness-ranking)) + ) + (cond + ((and (not mem1) (not mem2)) 0) + ((not mem1) -1) + ((not mem2) 1) + ((= (length mem1) (length mem2)) 0) + ((> (length mem1) (length mem2)) 1) + (else -1)))) + +(define (dcommon:xor-tests-mindat src-tests-mindat dest-tests-mindat) + (let* ((src-hash (dcommon:tests-mindat->hash src-tests-mindat)) + (dest-hash (dcommon:tests-mindat->hash dest-tests-mindat)) + (all-keys + (reverse (sort + (delete-duplicates + (append (hash-table-keys src-hash) (hash-table-keys dest-hash))) + + (lambda (a b) + (cond + ((< 0 (string-compare3 (car a) (car b))) #t) + ((> 0 (string-compare3 (car a) (car b))) #f) + ((< 0 (string-compare3 (cdr a) (cdr b))) #t) + (else #f))) + + )))) + (map ;; TODO: rename xor to delta globally in dcommon and dashboard + (lambda (key) + (let* ((test-name (car key)) + (item-path (cdr key)) + + (dest-value (hash-table-ref/default dest-hash key #f)) ;; (list test-id state status) + (dest-test-id (if dest-value (list-ref dest-value 0) #f)) + (dest-state (if dest-value (list-ref dest-value 1) #f)) + (dest-status (if dest-value (list-ref dest-value 2) #f)) + + (src-value (hash-table-ref/default src-hash key #f)) ;; (list test-id state status) + (src-test-id (if src-value (list-ref src-value 0) #f)) + (src-state (if src-value (list-ref src-value 1) #f)) + (src-status (if src-value (list-ref src-value 2) #f)) + + (incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete + + (dest-complete + (and dest-value dest-state dest-status + (equal? dest-state "COMPLETED") + (not (member dest-status incomplete-statuses)))) + (src-complete + (and src-value src-state src-status + (equal? src-state "COMPLETED") + (not (member src-status incomplete-statuses)))) + (status-compare-result (dcommon:status-compare3 src-status dest-status)) + (xor-new-item + (cond + ;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a ) + ;; neither complete -> bad + + ;; src !complete, dest complete -> better + ((and (not dest-complete) (not src-complete)) + (list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE")) + ((not dest-complete) + (list src-test-id "DIFF-MISSING" "DEST-INCOMPLETE")) + ((not src-complete) + (list dest-test-id "DIFF-NEW" "SRC-INCOMPLETE")) + ((and + (equal? src-state dest-state) + (equal? src-status dest-status)) + (list dest-test-id (conc "CLEAN") (conc "CLEAN-" dest-status) )) + ;; better or worse: pass > warn > waived > skip > fail > abort + ;; pass > warn > waived > skip > fail > abort + + ((= 1 status-compare-result) ;; src is better, dest is worse + (list dest-test-id "DIRTY-WORSE" (conc src-status "->" dest-status))) + (else + (list dest-test-id "DIRTY-BETTER" (conc src-status "->" dest-status))) + ))) + (list test-name item-path xor-new-item))) + all-keys))) + (define (dcommon:examine-xterm run-id test-id) (let* ((testdat (rmt:get-test-info-by-id run-id test-id))) (if (not testdat) (begin (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") @@ -311,10 +408,12 @@ (print "Adding xterm code"))))) ;;====================================================================== ;; D A T A T A B L E S ;;====================================================================== + + ;; Table of keys (define (dcommon:keys-matrix rawconfig) (let* ((curr-row-num 1) (key-vals (configf:section-vars rawconfig "fields")) Index: gutils.scm ================================================================== --- gutils.scm +++ gutils.scm @@ -34,17 +34,22 @@ ((ARCHIVED) (case (string->symbol status) ((PASS) (list "70 170 73" status)) ((WARN WAIVED) (list "200 130 13" status)) ((SKIP) (list "180 180 0" status)) - (else (list "180 33 49" status)))) + (else (list "253 33 49" state)))) ;; (if (equal? status "PASS") ;; '("70 249 73" "PASS") ;; (if (or (equal? status "WARN") ;; (equal? status "WAIVED")) ;; (list "255 172 13" status) ;; (list "223 33 49" status)))) ;; greenish orangeish redish + + ((CLEAN) (list "60 235 63" status)) + ((DIRTY-BETTER) (list "160 255 153" status)) + ((DIRTY-WORSE) (list "165 42 42" status)) + ((BOTH-BAD) (list "180 33 49" status)) ((LAUNCHED) (list "101 123 142" state)) ((CHECK) (list "255 100 50" state)) ((REMOTEHOSTSTART) (list "50 130 195" state)) ((RUNNING) (list "9 131 232" state)) ((KILLREQ) (list "39 82 206" state))