Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -2417,11 +2417,11 @@ (set! max-row (max rownum max-row)) ;; track the max row used (if (dashboard:row-collision rowhash rownum event-time end-time) (loop (+ rownum 1)) (let* ((lly (- sizey (* rownum row-height))) (uly (+ lly row-height)) - (obj (vg:make-rect event-time lly end-time uly + (obj (vg:make-rect-obj event-time lly end-time uly fill-color: (vg:iup-color->number (car name-color)) text: (if iterated item-path test-name) font: "Helvetica -10"))) ;; (if iterated ;; (dashboard:add-bar rowhash (- rownum 1) event-time end-time num-rows: (+ 1 num-items)) @@ -2441,18 +2441,18 @@ (llx (- (car xtents) 5)) (lly (- (cadr xtents) 10)) (ulx (+ 5 (caddr xtents))) (uly (+ 0 (cadddr xtents)))) (dashboard:add-bar rowhash first-rownum llx ulx num-rows: num-items) - (vg:add-objs-to-comp runcomp (vg:make-rect llx lly ulx uly + (vg:add-objs-to-comp runcomp (vg:make-rect-obj llx lly ulx uly text: (db:test-get-testname (car testdats)) font: "Helvetica -10")))))) hierdat) ;; placeholder box (set! max-row (+ max-row 1)) (let ((y (- sizey (* max-row row-height)))) - (vg:add-objs-to-comp runcomp (vg:make-rect 0 y 0 y))) + (vg:add-objs-to-comp runcomp (vg:make-rect-obj 0 y 0 y))) ;; instantiate the component (let* ((extents (vg:components-get-extents drawing runcomp)) ;; move the following into mapping functions in vg.scm ;; (deltax (- llx ulx)) ;; (scalex (if (> deltax 0)(/ sizex deltax) 1)) @@ -2462,11 +2462,11 @@ (llx (list-ref new-xtnts 0)) (lly (list-ref new-xtnts 1)) (ulx (list-ref new-xtnts 2)) (uly (list-ref new-xtnts 3)) ) ;; (vg:components-get-extents d1 c1))) - (vg:add-objs-to-comp runcomp (vg:make-rect llx lly ulx uly text: run-full-name)) + (vg:add-objs-to-comp runcomp (vg:make-rect-obj llx lly ulx uly text: run-full-name)) (vg:instantiate drawing "runslib" run-full-name run-full-name 0 0)) (set! max-row (+ max-row 1))))) allruns) (vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat)(dboard:tabdat-cnv tabdat)) ;; cnv-obj) (canvas-clear! (dboard:tabdat-cnv tabdat)) ;; -obj) Index: vg-test.scm ================================================================== --- vg-test.scm +++ vg-test.scm @@ -11,15 +11,15 @@ (define d1 (vg:drawing-new)) (define l1 (vg:lib-new)) (define c1 (vg:comp-new)) (define c2 (vg:comp-new)) -(define bt1 (vg:make-rect 10 40 20 50 text: "A long piece of text" font: "Helvetica, -10")) +(define bt1 (vg:make-rect-obj 10 40 20 50 text: "A long piece of text" font: "Helvetica, -10")) -(let ((r1 (vg:make-rect 20 20 30 30 text: "r1" font: "Helvetica, -20")) - (r2 (vg:make-rect 30 30 60 60 text: "r2" font: "Helvetica, -10")) - (t1 (vg:make-text 60 60 "The middle" font: "Helvetica, -10"))) +(let ((r1 (vg:make-rect-obj 20 20 30 30 text: "r1" font: "Helvetica, -20")) + (r2 (vg:make-rect-obj 30 30 60 60 text: "r2" font: "Helvetica, -10")) + (t1 (vg:make-text-obj 60 60 "The middle" font: "Helvetica, -10"))) (vg:add-objs-to-comp c1 r1 r2 t1 bt1)) ;; add the c1 component to lib l1 with name firstcomp (vg:add-comp-to-lib l1 "firstcomp" c1) (vg:add-comp-to-lib l1 "secondcomp" c2) @@ -39,20 +39,20 @@ ;; 1.1 1.1 -2 -2)) ;; get extents of c1 and put a rectange around it ;; (define xtnts (apply vg:grow-rect 10 10 (vg:components-get-extents d1 c1))) -(vg:add-objs-to-comp c1 (apply vg:make-rect xtnts)) +(vg:add-objs-to-comp c1 (apply vg:make-rect-obj xtnts)) (define bt1xt (vg:obj-get-extents d1 bt1)) (print "bt1xt: " bt1xt) -(vg:add-objs-to-comp c1 (apply vg:make-rect bt1xt)) +(vg:add-objs-to-comp c1 (apply vg:make-rect-obj bt1xt)) ;; get extents of all objects and put rectangle around it ;; (define big-xtnts (vg:instances-get-extents d1)) -(vg:add-objs-to-comp c2 (apply vg:make-rect big-xtnts)) +(vg:add-objs-to-comp c2 (apply vg:make-rect-obj big-xtnts)) (vg:instantiate d1 "firstlib" "secondcomp" "inst3" 0 0) (vg:drawing-scalex-set! d1 1.5) (vg:drawing-scaley-set! d1 1.5) Index: vg.scm ================================================================== --- vg.scm +++ vg.scm @@ -17,11 +17,14 @@ (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 angle font attrib extents) +;; extents caches extents calculated on draw +;; proc is called on draw and takes the obj itself as a parameter +;; attrib is an alist of parameters +(defstruct vg:obj type pts fill-color text line-color call-back angle font attrib extents proc) (defstruct vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache) (defstruct vg:drawing libs insts scalex scaley xoff yoff cnv cache) ;; libs: hash of name->lib, insts: hash of instname->inst ;; inits ;; @@ -99,23 +102,33 @@ ;; 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)(text #f)(font #f)) +(define (vg:make-rect-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)) (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: #f)) +;; make a rectangle obj +;; +(define (vg:make-line-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)) + (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color extents: #f)) + ;; make a text obj ;; -(define (vg:make-text x1 y1 text #!key (line-color #f)(fill-color #f) +(define (vg:make-text-obj x1 y1 text #!key (line-color #f)(fill-color #f) (angle #f)(scale-with-zoom #f)(font #f) (font-size #f)) (make-vg:obj type: 't pts: (list x1 y1) text: text line-color: line-color fill-color: fill-color angle: angle font: font attributes: (vg:make-attrib 'font-size font-size))) +;; proc takes startnum and endnum and yields scalef, per-grad and unitname +;; +(define (vg:make-xaxis-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(proc #f)) + (make-vg:obj type: 'x pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: #f proc: proc)) + ;;====================================================================== ;; obj modifiers and queries ;;====================================================================== ;; get extents, use knowledge of type ... @@ -233,12 +246,14 @@ ;; 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)) - ((t)(vg:map-text drawing inst obj)) + ((l)(vg:map-line drawing inst obj)) + ((r)(vg:map-rect drawing inst obj)) + ((t)(vg:map-text drawing inst obj)) + ((x)(vg:map-xaxis 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) @@ -245,10 +260,21 @@ (let ((res (make-vg:obj type: 'r ;; is there a defstruct copy? 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)) + (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) )) + res)) + +;; given a drawing and a inst map a line to it screen coordinates +;; +(define (vg:map-line drawing inst obj) + (let ((res (make-vg:obj type: 'l ;; is there a defstruct copy? + 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)) (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) )) res)) @@ -264,10 +290,21 @@ attrib: (vg:obj-attrib obj))) (pts (vg:obj-pts obj))) (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts)) (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing))) res)) + +;; given a drawing and a inst map a line to it screen coordinates +;; +(define (vg:map-xaxis drawing inst obj) + (let ((res (make-vg:obj type: 'x ;; is there a defstruct copy? + 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)) + (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) )) + res)) ;;====================================================================== ;; instances ;;====================================================================== @@ -301,10 +338,18 @@ (arithmetic-shift g 8) b)) (define (vg:iup-color->number iup-color) (apply vg:rgb->number (map string->number (string-split iup-color)))) + +;;====================================================================== +;; graphing +;;====================================================================== + +(define (vg:make-xaxis drawing component x1 y1 x2 y2 startnum endnum scaleproc) + (let ((obj (vg:make-xaxis-obj x1 y1 x2 y2))) + #f)) ;;====================================================================== ;; Unravel and draw the objects ;;====================================================================== @@ -347,10 +392,128 @@ (if fill-color (canvas-foreground-set! cnv prev-foreground-color))) (canvas-rectangle! cnv llx ulx lly uly) (canvas-foreground-set! cnv prev-foreground-color) (if text + (let* ((prev-font (canvas-font cnv)) + (font-changed (and font (not (equal? font prev-font))))) + (if font-changed (canvas-font-set! cnv font)) + (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (set! text-xmax xmax)(set! text-ymax ymax)) + (if font-changed (canvas-font-set! cnv prev-font)))))) + (print "text-xmax: " text-xmax " text-ymax: " text-ymax) + (if (vg:obj-extents obj) + (vg:obj-extents obj) + (if (not text) + pts + (if (and text-xmax text-ymax) + (let ((xt (list llx lly + (max ulx (+ llx text-xmax)) + (max uly (+ lly text-ymax))))) + (vg:obj-extents-set! obj xt) + xt) + (if cnv + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (let ((xt (list llx lly + (max ulx (+ llx xmax)) + (max uly (+ lly ymax))))) + (vg:obj-extents-set! obj xt) + xt)) + pts)))))) ;; return extents + +;; given a rect obj draw it on the canvas applying first the drawing +;; scale and offset +;; +(define (vg:draw-line drawing obj #!key (draw #t)) + (let* ((cnv (vg:drawing-cnv drawing)) + (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) + ;; (fill-color (vg:obj-fill-color obj)) + (line-color (vg:obj-line-color obj)) + (text (vg:obj-text obj)) + (font (vg:obj-font obj)) + (llx (car pts)) + (lly (cadr pts)) + (ulx (caddr pts)) + (uly (cadddr pts)) + (w (- ulx llx)) + (h (- uly lly)) + (text-xmax #f) + (text-ymax #f)) + (if draw + (let ((prev-background-color (canvas-background cnv)) + (prev-foreground-color (canvas-foreground cnv))) + ;; (if fill-color + ;; (begin + ;; (canvas-foreground-set! cnv fill-color) + ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h) + (if line-color + (canvas-foreground-set! cnv line-color) + (if fill-color + (canvas-foreground-set! cnv prev-foreground-color))) + (canvas-line! cnv llx ulx lly uly) + (canvas-foreground-set! cnv prev-foreground-color) + (if text + (let* ((prev-font (canvas-font cnv)) + (font-changed (and font (not (equal? font prev-font))))) + (if font-changed (canvas-font-set! cnv font)) + (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (set! text-xmax xmax)(set! text-ymax ymax)) + (if font-changed (canvas-font-set! cnv prev-font)))))) + (print "text-xmax: " text-xmax " text-ymax: " text-ymax) + (if (vg:obj-extents obj) + (vg:obj-extents obj) + (if (not text) + pts + (if (and text-xmax text-ymax) + (let ((xt (list llx lly + (max ulx (+ llx text-xmax)) + (max uly (+ lly text-ymax))))) + (vg:obj-extents-set! obj xt) + xt) + (if cnv + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (let ((xt (list llx lly + (max ulx (+ llx xmax)) + (max uly (+ lly ymax))))) + (vg:obj-extents-set! obj xt) + xt)) + pts)))))) ;; return extents + +;; given a rect obj draw it on the canvas applying first the drawing +;; scale and offset +;; +(define (vg:draw-xaxis drawing obj #!key (draw #t)) + (let* ((cnv (vg:drawing-cnv drawing)) + (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) + ;; (fill-color (vg:obj-fill-color obj)) + (line-color (vg:obj-line-color obj)) + (text (vg:obj-text obj)) + (font (vg:obj-font obj)) + (llx (car pts)) + (lly (cadr pts)) + (ulx (caddr pts)) + (uly (cadddr pts)) + (w (- ulx llx)) + (h (- uly lly)) + (text-xmax #f) + (text-ymax #f)) + (if draw + (let ((prev-background-color (canvas-background cnv)) + (prev-foreground-color (canvas-foreground cnv))) + ;; (if fill-color + ;; (begin + ;; (canvas-foreground-set! cnv fill-color) + ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h) + (if line-color + (canvas-foreground-set! cnv line-color) + (if fill-color + (canvas-foreground-set! cnv prev-foreground-color))) + (canvas-line! cnv llx ulx lly uly) + (canvas-foreground-set! cnv prev-foreground-color) + (if text (let* ((prev-font (canvas-font cnv)) (font-changed (and font (not (equal? font prev-font))))) (if font-changed (canvas-font-set! cnv font)) (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) (let-values (((xmax ymax)(canvas-text-size cnv text)))