Megatest

Check-in [cd3c0cae4d]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Progress on run time display
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.61
Files: files | file ages | folders
SHA1: cd3c0cae4dcf13cb5b7d7905b4f76cc2233fb72d
User & Date: mrwellan on 2016-07-12 17:49:57
Other Links: branch diff | manifest | tags
Context
2016-07-12
23:01
Added instance and drawing scale x and y, offset x and y check-in: 2548ff7aad user: matt tags: v1.61
17:49
Progress on run time display check-in: cd3c0cae4d user: mrwellan tags: v1.61
01:46
Force getting some run data check-in: fdb15678bf user: matt tags: v1.61
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified dashboard.scm from [b5a492a3b9] to [bb09c340a6].

︙
1011
1012
1013
1014
1015
1016
1017
1018

1019
1020
1021
1022
1023
1024
1025
1026

1011
1012
1013
1014
1015
1016
1017

1018

1019
1020
1021
1022
1023
1024
1025








-
+
-








;; R U N   C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
(define (dashboard:run-times commondat tabdat #!key (tab-num #f))
  ;; (dashboard:run-times-tab-updater commondat tab-num)
  (let ((drawing (vg:drawing-new))
  (let ((drawing               (vg:drawing-new))
	(lib1    (vg:lib-new))
	(run-times-tab-updater (lambda ()
				 (dashboard:run-times-tab-updater commondat tab-num))))
    (dboard:tabdat-drawing-set! tabdat drawing)
    (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
    (iup:vbox
     (let* ((cnv-obj (iup:canvas 
		     #:size "500x400"
︙
1863
1864
1865
1866
1867
1868
1869



























1870



1871
1872
1873



1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886


1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901

1902
1903
1904

1905
1906
1907
1908
1909
1910
1911














1912
1913
1914
1915
1916
1917
1918

1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901

1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916

1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941




1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

+
+
+


-
+
+
+












-
+
+















+



+



-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+








(define (dashboard:database-changed? commondat tabdat)
  (let* ((run-update-time (current-seconds))
	 (modtime         (dashboard:get-youngest-run-db-mod-time tabdat)) ;; NOTE: ensure this is tabdat!! 
	 (recalc          (dashboard:recalc modtime (dboard:commondat-please-update commondat) (dboard:tabdat-last-db-update tabdat))))
     (dboard:commondat-please-update-set! commondat #f)
     recalc))

;; 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?
;;
(define (dashboard:row-collision rowhash rownum x1 x2)
  (let ((rowdat    (hash-table-ref/default rowhash rownum '()))
	(collision #f))
    (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)
    collision))

(define-inline (dashboard:add-bar rowhash rownum x1 x2)
  (hash-table-set! rowhash rownum (cons (cons x1 x2) 
					(hash-table-ref/default rowhash rownum '()))))

(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)))
    (if tabdat
	(begin
	(let* ((row-height 10)
	       (drawing    (dboard:tabdat-drawing tabdat))
	       (runslib    (vg:get/create-lib drawing "runslib")))
	  (update-rundat tabdat
			 "%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") 
			 100  ;; (dboard:tabdat-numruns tabdat)
			 "%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
			 ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
			 (let ((res '()))
			   (for-each (lambda (key)
				       (if (not (equal? key "runname"))
					   (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
					     (if val (set! res (cons (list key val) res))))))
				     (dboard:tabdat-dbkeys tabdat))
			   res))
	  (let ((allruns (dboard:tabdat-allruns tabdat)))
	  (let ((allruns (dboard:tabdat-allruns tabdat))
		(rowhash (make-hash-table))) ;; store me in tabdat
	    (print "allruns: " allruns)
	    (for-each
	     (lambda (rundat)
	       (if (vector? rundat)
		   (let* ((run      (vector-ref rundat 0))
			  (testsdat  (sort (vector-ref rundat 1)
					   (lambda (a b)
					     (< (db:test-get-event_time a)
						(db:test-get-event_time b)))))
			  (key-val-dat (vector-ref rundat 2))
			  (run-id   (db:get-value-by-header run (dboard:tabdat-header tabdat) "id"))
			  (key-vals (append key-val-dat
					    (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname")))
						    (if x x "")))))
			  (run-key  (string-intersperse key-vals "\n"))
			  (run-full-name (string-intersperse key-vals "/"))
			  (runcomp  (vg:comp-new));; new component for this run
			  (rows-used (make-hash-table)) ;; keep track of what parts of the rows are used here row1 = (obj1 obj2 ...)
			  (row-height 4))
		     (vg:add-comp-to-lib runslib run-full-name runcomp)
		     ;; get tests in list sorted by event time ascending
		     (for-each 
		      (lambda (testdat)
			(let ((event-time   (db:test-get-event_time   testdat))
			      (run-duration (db:test-get-run_duration testdat))
			      (test-name    (db:test-get-testname     testdat)))
			  (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)))
			(let* ((event-time   (/ (db:test-get-event_time   testdat) 60))
			       (run-duration (/ (db:test-get-run_duration testdat) 60))
			       (end-time     (+ event-time run-duration))
			       (test-name    (db:test-get-testname     testdat))
			       (item-path    (db:test-get-item_path    testdat)))
			  (let loop ((rownum 0))
			    (if (dashboard:row-collision rowhash rownum event-time end-time)
				(loop (+ rownum 1))
				(let* ((lly (* rownum row-height))
				       (uly (+ lly row-height)))
				  (dashboard:add-bar rowhash rownum event-time end-time)
				  (vg:add-objs-to-comp runcomp (vg:make-rect event_time lly end-time uly)))))
			  ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
			  ))
		      testsdat))))
	     allruns)
       (vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat)(dboard:tabdat-cnv tabdat)) ;; cnv-obj)
       (canvas-clear! (dboard:tabdat-cnv tabdat)) ;; -obj)
       (vg:draw (dboard:tabdat-drawing tabdat))
       ))
	(print "no tabdat for run-times-tab-updater"))))
︙

Modified vg.scm from [47e6fcaa5e] to [eb7981f441].

︙
35
36
37
38
39
40
41














42
43
44
45





46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63

























64

65
66
67











68
69
70
71
72
73
74

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130








+
+
+
+
+
+
+
+
+
+
+
+
+
+




+
+
+
+
+


















+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

+



+
+
+
+
+
+
+
+
+
+
+








  (make-vg:drawing libs: (make-hash-table) insts: (make-hash-table)))

;; make a rectangle obj
;;
(define (vg:make-rect x1 y1 x2 y2 #!key (line-color #f)(fill-color #f))
  (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: #f line-color: line-color fill-color: fill-color))

;; get extents, use knowledge of type ...
;;
(define (vg:obj-get-extents obj)
  (let ((type (vg:obj-type obj)))
    (case type
      ((r)(vg:rect-get-extents obj)))))

(define (vg:rect-get-extents obj)
  (vg:obj-pts obj)) ;; extents are just the points for a rectangle

;;======================================================================
;; components
;;======================================================================

;; add obj to comp
;;
(define (vg:add-objs-to-comp comp . objs)
  (vg:comp-objs-set! comp (append (vg:comp-objs comp) objs)))

;; use the struct. leave this here to remind of this!
;;
;; (define (vg:comp-get-objs comp)
;;   (vg:comp-objs comp))

;; add comp to lib
;;
(define (vg:add-comp-to-lib lib compname comp)
  (hash-table-set! (vg:lib-comps lib) compname comp))

;; instanciate component in drawing
;;
(define (vg:instantiate drawing libname compname instname xoff yoff t #!key (scale 1)(mirrx #f)(mirry #f))
  (let ((inst (make-vg:inst libname: libname compname: compname xoff: xoff yoff: yoff theta: t scale: scale mirrx: mirrx mirry: mirry)) )
    (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:component-get-extents comp)
  (let ((llx #f)
	(lly #f)
	(ulx #f)
	(uly #f)
	(objs (vg:comp-objs comp)))
    (for-each
     (lambda (obj)
       (let* ((extents (vg:get-extents obj))
	      (ollx    (list-ref extents 0))
	      (olly    (list-ref extents 1))
	      (oulx    (list-ref extents 2))
	      (ouly    (list-ref extents 3)))
	 (if (or (not llx)(< ollx llx))(set! llx ollx))
	 (if (or (not lly)(< olly llx))(set! llx ollx))
	 (if (or (not ulx)(< ollx llx))(set! llx ollx))
	 (if (or (not uly)(< ollx llx))(set! llx ollx))))
     objs)
    (list llx lly ulx uly)))


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

;; register lib with drawing

;;
(define (vg:add-lib drawing libname lib)
  (hash-table-set! (vg:drawing-libs drawing) libname lib))

(define (vg:get-lib drawing libname)
  (hash-table-ref/default (vg:drawing-libs drawing) libname #f))

(define (vg:get/create-lib drawing libname)
  (let ((lib (vg:get-lib drawing libname)))
    (if lib
	lib
	(let ((newlib (vg:lib-new)))
	  (vg:add-lib drawing libname newlib)
	  newlib))))

;;======================================================================
;; map objects given offset, scale and mirror
;;======================================================================

(define (vg:map-obj xoff yoff theta scale mirrx mirry obj)
  (case (vg:obj-type obj)
︙

This page was generated in about 0.118s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00