Megatest

Check-in [2548ff7aad]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Added instance and drawing scale x and y, offset x and y
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.61
Files: files | file ages | folders
SHA1: 2548ff7aad2234074fda702d529e249f6d476cb8
User & Date: matt on 2016-07-12 23:01:26
Other Links: branch diff | manifest | tags
Context
2016-07-13
23:05
Fixed points handling for rectangles check-in: 02b5c6c31c user: matt tags: v1.61
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
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified dashboard.scm from [bb09c340a6] to [0961e0974f].

︙︙
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
1963

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









|
|


|






|


|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








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
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981

			  (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) 60.0))
			       (run-duration (/ (db:test-get-run_duration testdat) 60.0))
			       (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)))
	       ;; instantiate the component 
	       (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
			    ((originx originy)             (canvas-origin cnv)))
		 (let* ((extents (vg:component-get-extents runcomp))
			(llx     (list-ref extents 0))
			(lly     (list-ref extents 1))
			(ulx     (list-ref extents 2))
			(uly     (list-ref extents 3))
			;; move the following into mapping functions in vg.scm
			(deltax  (- llx ulx))
			(scalex  (/ sizex deltax))
			(sllx    (* scalex llx))
			(offx    (- sllx originx))
		   
		 
		 
	       
	       )
	     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 [eb7981f441] to [ff6b4c8f1a].

︙︙
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35


















































36
37
38
39
40
41
42

(use canvas-draw iup)
(import canvas-draw-iup)
;; structs
;;
(defstruct vg:lib     comps)
(defstruct vg:comp    objs name file)
(defstruct vg:obj     type pts fill-color text line-color call-back font)
(defstruct vg:inst    libname compname theta xoff yoff scale mirrx mirry call-back)
(defstruct vg:drawing libs insts cnv) ;; libs: hash of name->lib, insts: hash of instname->inst

;; inits
;;
(define (vg:comp-new)
  (make-vg:comp objs: '() name: #f file: #f))

(define (vg:lib-new)
  (make-vg:lib comps: (make-hash-table)))

(define (vg:drawing-new)
  (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 ...








|
|










|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
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

(use canvas-draw iup)
(import canvas-draw-iup)
;; structs
;;
(defstruct vg:lib     comps)
(defstruct vg:comp    objs name file)
(defstruct vg:obj     type pts fill-color text line-color call-back font)
(defstruct vg:inst    libname compname theta xoff yoff scalex scaley mirrx mirry call-back)
(defstruct vg:drawing libs insts scalex scaley xoff yoff cnv) ;; libs: hash of name->lib, insts: hash of instname->inst

;; inits
;;
(define (vg:comp-new)
  (make-vg:comp objs: '() name: #f file: #f))

(define (vg:lib-new)
  (make-vg:lib comps: (make-hash-table)))

(define (vg:drawing-new)
  (make-vg:drawing scalex: 1 scaley: 1 xoff: 0 yoff: 0 libs: (make-hash-table) insts: (make-hash-table)))

;;======================================================================
;; scaling and offsets
;;======================================================================

(define-inline (vg:scale-offset val s o)
  (+ o (* val s)))

;; apply scale and offset to a list of x y values
;;
(define (vg:scale-offset-xy lstxy sx sy ox oy)
  (if (> (length lstxy) 1) ;; have at least one xy pair
      (let loop ((x   (car lstxy))
		 (y   (cadr lstxy))
		 (tal (cddr lstxy))
		 (res '()))
	(let ((newres (cons (vg:scale-offset y sy oy)
			    (cons (vg:scale-offset x sx ox)
				  res))))
	  (if (> (length tal) 1)
	      (loop (car tal)(cadr tal)(cddr tal) newres)
	      (reverse newres))))
      '()))

;; apply drawing offset and scaling to the points in lstxy
;;
(define (vg:drawing-apply-scale drawing lstxy)
  (vg:scale-offset-xy 
   lstxy
   (vg:drawing-scalex drawing)
   (vg:drawing-scaley drawing)
   (vg:drawing-xoff   drawing)
   (vg:drawing-yoff   drawing)))

;; apply instance offset and scaling to the points in lstxy
;;
(define (vg:inst-apply-scale inst lstxy)
  (vg:scale-offset-xy 
   lstxy
   (vg:inst-scalex inst)
   (vg:inst-scaley inst)
   (vg:inst-xoff   inst)
   (vg:inst-yoff   inst)))

;; apply both drawing and instance scaling to a list of xy points
;; 
(define (vg:drawing-inst-apply-scale-offset drawing inst lstxy)
  (vg:inst-apply-scale 
   inst
   (vg:drawing-apply-scale drawing lstxy)))

;; 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 ...
︙︙
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81

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








|
|








116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131

;; 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 (scalex 1)(scaley 1)(mirrx #f)(mirry #f))
  (let ((inst (make-vg:inst libname: libname compname: compname xoff: xoff yoff: yoff theta: t scalex: scalex scaley: scaley 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))
︙︙
119
120
121
122
123
124
125
126
127
128


129
130
131
132
133


134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187

    (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)
    ((r)(vg:map-rect xoff yoff theta scale mirrx mirry obj))
    (else #f)))



(define (vg:map-rect xoff yoff theta scale mirrx mirry obj)
  (let ((res (make-vg:obj type:       'r
			  fill-color: (vg:obj-fill-color obj)
			  text:       (vg:obj-text       obj)
			  line-color: (vg:obj-line-color obj)
			  font:       (vg:obj-font       obj)))
	(pts (vg:obj-pts obj)))
    (vg:obj-pts-set! res 
		     (list (+ xoff (car pts))
			   (+ yoff (cadr pts))
			   (+ xoff (caddr pts))
			   (+ yoff (cadddr pts))))
    res))

;;======================================================================
;; Unravel and draw the objects
;;======================================================================

(define (vg:draw-obj cnv obj)
  (print "obj type: " (vg:obj-type obj))
  (case (vg:obj-type obj)
    ((r)(vg:draw-rect cnv obj))))

(define (vg:draw-rect cnv obj)
  (let* ((pts (vg:obj-pts obj))
	 (llx (car pts))
	 (lly (cadr pts))
	 (urx (caddr pts))
	 (ury (cadddr pts)))
    (print "(canvas-rectangle! " cnv " " llx " " urx " " lly " " ury ")")
    (canvas-rectangle! cnv llx urx lly ury)
    ))

(define (vg:draw drawing)
  (let ((insts (vg:drawing-insts drawing))
	(cnv   (vg:drawing-cnv   drawing)))
    (for-each 
     (lambda (inst)
       (let* ((xoff     (vg:inst-xoff inst))
	      (yoff     (vg:inst-yoff inst))
	      (theta    (vg:inst-theta inst))
	      (scale    (vg:inst-scale inst))
	      (mirrx    (vg:inst-mirrx inst))
	      (mirry    (vg:inst-mirry inst))
	      (libname  (vg:inst-libname inst))
	      (compname (vg:inst-compname inst))
	      (comp     (vg:get-component drawing libname compname)))
	 (print "comp: " comp)
	 (for-each
	  (lambda (obj)
	    (print "obj: " obj)
	    (vg:draw-obj cnv (vg:map-obj xoff yoff theta scale mirrx mirry obj)))
	  (vg:comp-objs comp))))
    (hash-table-values insts))))








|


>
>
|

|


>
>
|






|
<
<
<
<






|


|

|
|
|
<
<
<
<
|
<


|
<


<
<
<
<
<
<
|






|



169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195




196
197
198
199
200
201
202
203
204
205
206
207
208
209




210

211
212
213

214
215






216
217
218
219
220
221
222
223
224
225

    (if lib
	lib
	(let ((newlib (vg:lib-new)))
	  (vg:add-lib drawing libname newlib)
	  newlib))))

;;======================================================================
;; map objects given offset, scale and mirror, resulting obj is displayed
;;======================================================================

;; dispatch the drawing of obj off to the correct drawing routine
;;
(define (vg:map-obj drawing inst obj)
  (case (vg:obj-type obj)
    ((r)(vg:map-rect drawing inst obj))
    (else #f)))

;; given a drawing and a inst map a rectangle to it screen coordinates
;;
(define (vg:map-rect drawing inst obj)
  (let ((res (make-vg:obj type:       'r
			  fill-color: (vg:obj-fill-color obj)
			  text:       (vg:obj-text       obj)
			  line-color: (vg:obj-line-color obj)
			  font:       (vg:obj-font       obj)))
	(pts (vg:obj-pts obj)))
    (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))




    res))

;;======================================================================
;; Unravel and draw the objects
;;======================================================================

(define (vg:draw-obj drawing obj)
  (print "obj type: " (vg:obj-type obj))
  (case (vg:obj-type obj)
    ((r)(vg:draw-rect drawing obj))))

(define (vg:draw-rect drawing obj)
  (let* ((cnv (vg:drawing-cnv drawing))
	 (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))))




    (apply canvas-rectangle! cnv pts)))


(define (vg:draw drawing)
  (let ((insts (vg:drawing-insts drawing)))

    (for-each 
     (lambda (inst)






       (let* ((libname  (vg:inst-libname inst))
	      (compname (vg:inst-compname inst))
	      (comp     (vg:get-component drawing libname compname)))
	 (print "comp: " comp)
	 (for-each
	  (lambda (obj)
	    (print "obj: " obj)
	    (vg:draw-obj drawing (vg:map-obj drawing inst obj)))
	  (vg:comp-objs comp))))
    (hash-table-values insts))))

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