97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
-
-
+
+
|
;; (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))
(define (vg:make-rect 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))
;; make a text obj
;;
(define (vg:make-text 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
|
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
|
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
|
-
+
|
((r)(vg:map-rect drawing inst obj))
((t)(vg:map-text 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
(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) ))
|
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
|
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
|
+
+
-
-
-
-
-
-
+
+
+
+
+
+
-
+
+
+
+
+
+
+
|
;; scale and offset
;;
(define (vg:draw-rect 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)))
(llx (car pts))
(lly (cadr pts))
(ulx (caddr pts))
(uly (cadddr pts))
(w (- ulx llx))
(h (- uly lly)))
(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-rectangle! cnv llx ulx lly uly)
(canvas-foreground-set! cnv prev-foreground-color)))
(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)
(if font-changed (canvas-font-set! cnv prev-font))))))
pts)) ;; return extents
;; given a rect obj draw it on the canvas applying first the drawing
;; scale and offset
;;
(define (vg:draw-text drawing obj #!key (draw #t))
(let* ((cnv (vg:drawing-cnv drawing))
|