15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
|
(declare (unit vg))
(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 angle font attrib)
(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
;;
(define (vg:comp-new)
(make-vg:comp objs: '() name: #f file: #f))
|
|
|
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
|
(declare (unit vg))
(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 angle font attrib extents)
(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
;;
(define (vg:comp-new)
(make-vg:comp objs: '() name: #f file: #f))
|
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)(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
|
|
|
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)(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 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
|
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
|
(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)))
(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)
(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))))))
(if (not text)
pts
(if cnv
(let-values (((xmax ymax)(canvas-text-size cnv text)))
(list llx lly
(max ulx (+ llx xmax))
(max uly (+ lly ymax))))
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))
(pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
|
|
>
>
>
>
>
>
>
|
|
>
>
>
>
>
>
|
|
|
|
|
>
>
|
|
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
|
(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-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-text drawing obj #!key (draw #t))
(let* ((cnv (vg:drawing-cnv drawing))
(pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
|