1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
|
;;======================================================================
;; R U N
;;======================================================================
;;
;; display and manage a single run at a time
;; (define dashboard:update-run-summary-tab #f)
;; (define dashboard:update-new-view-tab #f)
;; (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
#: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)))))
(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)
(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)))
;;======================================================================
;; R U N S
;;======================================================================
(define (dboard:make-controls commondat tabdat)
(let ((btn-fontsz (dboard:tabdat-runs-btn-fontsz tabdat)))
|
<
<
<
>
>
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
|
;;======================================================================
;; R U N
;;======================================================================
;;
;; display and manage a single run at a time
;; 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)
(debug:catch-and-dump
(lambda ()
;; (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)
)))
"selection-cb in one-run")
;; (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)))))
(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)
(dboard:tabdat-runs-tree-set! tabdat tb)
(iup:vbox
(iup:split
tb
run-matrix)
(dboard:make-controls commondat tabdat))))
;;======================================================================
;; R U N S
;;======================================================================
(define (dboard:make-controls commondat tabdat)
(let ((btn-fontsz (dboard:tabdat-runs-btn-fontsz tabdat)))
|
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
|
(begin
(for-each (lambda (tname)
(hash-table-delete! *collapsed* tname))
(hash-table-keys *collapsed*))
(iup:attribute-set! obj "TITLE" "Collapse"))))
(mark-for-update tabdat))
"make-controls collapse button"))
#:expand "NO" #:size "40x15"))
)
(iup:vbox
;; (iup:button "Sort -t" #:action (lambda (obj)
;; (next-sort-option)
;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0))
;; (mark-for-update tabdat)))
(let* ((hide #f)
|
|
<
|
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
|
(begin
(for-each (lambda (tname)
(hash-table-delete! *collapsed* tname))
(hash-table-keys *collapsed*))
(iup:attribute-set! obj "TITLE" "Collapse"))))
(mark-for-update tabdat))
"make-controls collapse button"))
#:expand "NO" #:size "40x15")))
(iup:vbox
;; (iup:button "Sort -t" #:action (lambda (obj)
;; (next-sort-option)
;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0))
;; (mark-for-update tabdat)))
(let* ((hide #f)
|
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
|
(ntests (dboard:tabdat-num-tests runs-dat))
(keynames (dboard:tabdat-dbkeys runs-dat))
(nkeys (length keynames))
(runsvec (make-vector nruns))
(header (make-vector nruns))
(lftcol (make-vector ntests))
(keycol (make-vector ntests))
(controls '())
(lftlst '())
(hdrlst '())
(bdylst '())
(result '())
(i 0)
(btn-height (dboard:tabdat-runs-btn-height runs-dat))
(btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat))
(cell-width (dboard:tabdat-runs-cell-width runs-dat)))
;; controls (along bottom)
(set! controls (dboard:make-controls commondat runs-dat))
;; create the left most column for the run key names and the test names
(set! lftlst (list (iup:hbox
(iup:label) ;; (iup:valuator)
(apply iup:vbox
(map (lambda (x)
(let ((res (iup:hbox #:expand "HORIZONTAL"
|
|
|
|
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
|
(ntests (dboard:tabdat-num-tests runs-dat))
(keynames (dboard:tabdat-dbkeys runs-dat))
(nkeys (length keynames))
(runsvec (make-vector nruns))
(header (make-vector nruns))
(lftcol (make-vector ntests))
(keycol (make-vector ntests))
(controls (dboard:make-controls commondat runs-dat)) ;; '())
(lftlst '())
(hdrlst '())
(bdylst '())
(result '())
(i 0)
(btn-height (dboard:tabdat-runs-btn-height runs-dat))
(btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat))
(cell-width (dboard:tabdat-runs-cell-width runs-dat)))
;; controls (along bottom)
;; (set! controls (dboard:make-controls commondat runs-dat))
;; create the left most column for the run key names and the test names
(set! lftlst (list (iup:hbox
(iup:label) ;; (iup:valuator)
(apply iup:vbox
(map (lambda (x)
(let ((res (iup:hbox #:expand "HORIZONTAL"
|
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
|
(mutex-unlock! (dboard:commondat-update-mutex commondat)))
))
1))))
(let ((th1 (make-thread (lambda ()
(thread-sleep! 1)
(dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab
(dboard:commondat-please-update-set! commondat #t)
;; (dashboard:run-update commondat)
) "update buttons once"))
(th2 (make-thread iup:main-loop "Main loop")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th2))))
(main)
|
|
|
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
|
(mutex-unlock! (dboard:commondat-update-mutex commondat)))
))
1))))
(let ((th1 (make-thread (lambda ()
(thread-sleep! 1)
(dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab
;; (dboard:commondat-please-update-set! commondat #t) ;; MRW: ww36.3 - why was please update set true here? Removing it for now.
;; (dashboard:run-update commondat)
) "update buttons once"))
(th2 (make-thread iup:main-loop "Main loop")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th2))))
(main)
|