(flo:vector-set! v 3 xy)
(flo:vector-set! v 4 yy)
(flo:vector-set! v 5 y0)
- v))
\ No newline at end of file
+ v))
+
+(define-integrable (xx m) (flo:vector-ref m 0))
+(define-integrable (yx m) (flo:vector-ref m 1))
+(define-integrable (x0 m) (flo:vector-ref m 2))
+(define-integrable (xy m) (flo:vector-ref m 3))
+(define-integrable (yy m) (flo:vector-ref m 4))
+(define-integrable (y0 m) (flo:vector-ref m 5))
+
+(define-integrable (set-xx! m v) (flo:vector-set! m 0 v))
+(define-integrable (set-yx! m v) (flo:vector-set! m 1 v))
+(define-integrable (set-x0! m v) (flo:vector-set! m 2 v))
+(define-integrable (set-xy! m v) (flo:vector-set! m 3 v))
+(define-integrable (set-yy! m v) (flo:vector-set! m 4 v))
+(define-integrable (set-y0! m v) (flo:vector-set! m 5 v))
+
+(define (cairo-identity-matrix)
+ (cairo-matrix 1. 0. 0.
+ 0. 1. 0.))
+
+(define (cairo-rotation-matrix radians)
+ (let ((c (cos radians))
+ (s (sin radians)))
+ (cairo-matrix c s 0.
+ (- s) c 0.)))
+
+(define (cairo-matrix-scale! matrix factor)
+ (guarantee-flonum factor 'CAIRO-SCALE-MATRIX!)
+ (set-xx! matrix (flo:* (xx matrix) factor))
+ (set-yy! matrix (flo:* (yy matrix) factor)))
+
+(define (cairo-matrix-translate! matrix dx dy)
+ (guarantee-flonum dx 'CAIRO-MATRIX-TRANSLATE!)
+ (guarantee-flonum dy 'CAIRO-MATRIX-TRANSLATE!)
+ (set-x0! matrix (flo:+ dx (x0 matrix)))
+ (set-y0! matrix (flo:+ dy (y0 matrix))))
+
+(define (cairo-point x y)
+ (let ((v (flo:vector-cons 2)))
+ (flo:vector-set! v 0 x)
+ (flo:vector-set! v 1 y)
+ v))
+
+(define-integrable (x p) (flo:vector-ref p 0))
+(define-integrable (y p) (flo:vector-ref p 1))
+
+(define-integrable (set-x! p x) (flo:vector-set! p 0 x))
+(define-integrable (set-y! p y) (flo:vector-set! p 1 y))
+
+(define (cairo-transform! point matrix)
+ (let ((px (x point))
+ (py (y point)))
+ (set-x! point (flo:+ (flo:+ (flo:* (xx matrix) px)
+ (flo:* (xy matrix) py))
+ (x0 matrix)))
+ (set-y! point (flo:+ (flo:+ (flo:* (yx matrix) px)
+ (flo:* (yy matrix) py))
+ (y0 matrix)))))
+
+(define (guarantee-flonum object operator)
+ (if (not (flo:flonum? object))
+ (error:wrong-type-argument object "a flonum" operator)))
\ No newline at end of file
(let ((line1 (make-line-ink))
(line2 (make-line-ink))
(line3 (make-line-ink))
+ (poly (make-polygon-ink))
(arc (make-arc-ink))
(text (make-simple-text-ink))
(box (make-box-ink))
;; During testing.
(system-library-directory-pathname "")))))
(surface (make-surface-ink 40 40)))
+
(set-line-ink! line1 140 150 200 150)
(fix-drawing-add-ink! drawing line1)
+
(set-line-ink! line2 150 140 150 200)
(fix-drawing-add-ink! drawing line2)
+
(set-line-ink! line3 135 150 200 85)
(set-line-ink-width! line3 3)
(set-line-ink-color! line3 "blue")
(set-line-ink-dash-color! line3 "green")
(set-line-ink-dashes! line3 '(5. 5. 10. 5.))
(fix-drawing-add-ink! drawing line3)
+
(set-text-ink-position! text 150 150)
(set-simple-text-ink-text! text widget "Hello, World!")
(fix-drawing-add-ink! drawing text)
+
(set-box-ink! box 120 120 20 20)
(fix-drawing-add-ink! drawing box)
+
(set-image-ink! image 170 100)
(fix-drawing-add-ink! drawing image)
+
(set-arc-ink! arc 140 90 30 30)
(set-arc-ink-width! arc 5)
(set-arc-ink-color! arc "gold")
(fix-drawing-add-ink! drawing arc)
+
+ (set-polygon-ink! poly (star-vertices 15. 150. 95.))
+ (set-polygon-ink-width! poly 1)
+ (set-polygon-ink-color! poly "red")
+ (set-polygon-ink-fill-color! poly "gold")
+ (fix-drawing-add-ink! drawing poly)
+
(draw-on-surface surface)
(set-surface-ink-position! surface 175 175)
(fix-drawing-add-ink! drawing surface)
drawing)))
+(define (star-vertices size center.x center.y)
+ (let ((m (cairo-identity-matrix)))
+ (cairo-matrix-scale! m size)
+ (cairo-matrix-translate! m center.x center.y)
+ (map (lambda (p)
+ (cairo-transform! p m)
+ (cons (round->exact (x p)) (round->exact (y p))))
+ (unit-star-vertices 5.))))
+
+(define-integrable 2pi (flo:* 8. (flo:atan2 1. 1.)))
+
+(define (unit-star-vertices n-points)
+ (guarantee-flonum n-points 'star-vertices)
+ (let* ((incr (flo:/ 2pi n-points))
+ (incr/2 (flo:/ incr 2.)))
+ (let loop ((verts '())
+ (i 0.))
+ (if (flo:= i n-points)
+ (reverse! (cons (cairo-point 1. 0.) verts))
+ (let ((angle (flo:* i incr)))
+ (loop `(,(cairo-point (flo:* .5 (flo:cos (flo:+ angle incr/2)))
+ (flo:* .5 (flo:sin (flo:+ angle incr/2))))
+ ,(cairo-point (flo:cos angle) (flo:sin angle))
+ ,@verts)
+ (flo:+ 1. i)))))))
+
(define (draw-on-surface ink)
(let* ((surface (surface-ink-surface ink))
(cr (cairo-create surface)))
(define-guarantee rectangle-ink "a <rectangle-ink>")
(define-method fix-ink-draw-callback ((ink <rectangle-ink>)
- widget window cr area)
+ widget window cr area)
(declare (ignore window area))
(%trace2 ";drawing "ink" on "widget"\n")
(let ((view (fix-layout-view widget))
(if (set-option!? ink 'FILL color)
(drawing-damage ink))))))
\f
+(define-class (<polygon-ink> (constructor ()))
+ (<draw-ink>)
+ (vertices define standard initial-value '()))
+
+(define-guarantee polygon-ink "a <polygon-ink>")
+
+(define-method fix-ink-draw-callback ((ink <polygon-ink>) widget window cr area)
+ (declare (ignore window area))
+ (%trace2 ";drawing "ink" on "widget"\n")
+ (let ((view (fix-layout-view widget))
+ (vertices (polygon-ink-vertices ink)))
+ (if (not (null? vertices))
+ (let ((view-x (fix-rect-x view))
+ (view-y (fix-rect-y view)))
+ (C-call "cairo_move_to" cr
+ (->flonum (fix:- (caar vertices) view-x))
+ (->flonum (fix:- (cdar vertices) view-y)))
+ (let loop ((verts (cdr vertices)))
+ (if (not (null? verts))
+ (begin
+ (C-call "cairo_line_to" cr
+ (->flonum (fix:- (caar verts) view-x))
+ (->flonum (fix:- (cdar verts) view-y)))
+ (loop (cdr verts)))))
+ (let ((fill (get-option ink 'FILL '())))
+ (if (not (null? fill))
+ (begin
+ (set-fill-options! cr ink)
+ (C-call "cairo_fill_preserve" cr))))
+ (let ((outline (get-option ink 'OUTLINE '())))
+ (if (not (null? outline))
+ (begin
+ (set-outline-options! cr ink)
+ (C-call "cairo_stroke" cr))))))))
+
+(define (recache-polygon-extent! ink)
+ (let ((vertices (polygon-ink-vertices ink)))
+ (if (null? vertices)
+ (let ((extent (fix-ink-extent ink)))
+ (if (not (fix:zero? (fix-rect-width ink)))
+ (begin
+ (set-fix-rect! extent 0 0 0 0)
+ (drawing-damage ink))))
+ (let loop ((verts vertices) (min-x #f) (max-x #f) (min-y #f) (max-y #f))
+ (if (pair? verts)
+ (let ((x (caar verts))
+ (y (cdar verts)))
+ (loop (cdr verts)
+ (if min-x (fix:min min-x x) x)
+ (if max-x (fix:max max-x x) x)
+ (if min-y (fix:min min-y y) y)
+ (if max-y (fix:max max-y y) y)))
+ (let ((lw/2 (half-line-width ink)))
+ (drawing-damage ink)
+ (set-fix-rect-bounds! (fix-ink-extent ink)
+ (fix:- min-x lw/2)
+ (fix:+ max-x lw/2)
+ (fix:- min-y lw/2)
+ (fix:+ max-y lw/2))
+ (drawing-damage ink)))))))
+
+(define (set-polygon-ink! ink vertices)
+ (if (or (null? vertices)
+ (not (every (lambda (p)
+ (and (pair? p) (fixnum? (car p)) (fixnum? (cdr p))))
+ vertices)))
+ (error:wrong-type-argument vertices "a list of pairs of fixnums"
+ 'SET-POLYGON-INK!))
+ (without-interrupts
+ (lambda ()
+ (set-polygon-ink-vertices! ink vertices)
+ (recache-polygon-extent! ink))))
+
+(define-method fix-ink-move! ((ink <polygon-ink>) dx dy)
+ (without-interrupts
+ (lambda ()
+ (for-each (lambda (p)
+ (set-car! p (fix:+ (car p) dx))
+ (set-cdr! p (fix:+ (cdr p) dy)))
+ (polygon-ink-vertices ink))
+ (drawing-damage ink)
+ (fix-rect-move! (fix-ink-extent ink) dx dy)
+ (drawing-damage ink))))
+
+(define (polygon-ink-width ink)
+ (guarantee-polygon-ink ink 'polygon-ink-width)
+ (get-option ink 'LINE-WIDTH '()))
+
+(define (set-polygon-ink-width! ink width)
+ (guarantee-polygon-ink ink 'set-polygon-ink-width!)
+ (guarantee-positive-fixnum width 'set-polygon-ink-width!)
+ (without-interrupts
+ (lambda ()
+ (if (set-option!? ink 'LINE-WIDTH (->flonum width))
+ (recache-polygon-extent! ink)))))
+
+(define (polygon-ink-color ink)
+ (guarantee-polygon-ink ink 'polygon-ink-color)
+ (get-option ink 'OUTLINE '()))
+
+(define (set-polygon-ink-color! ink color)
+ (guarantee-polygon-ink ink 'set-polygon-ink-color!)
+ (let ((color (->color color 'set-polygon-ink-color!)))
+ (without-interrupts
+ (lambda ()
+ (if (set-option!? ink 'OUTLINE color)
+ (drawing-damage ink))))))
+
+(define (polygon-ink-fill-color ink)
+ (guarantee-polygon-ink ink 'polygon-ink-fill-color)
+ (get-option ink 'FILL '()))
+
+(define (set-polygon-ink-fill-color! ink color)
+ (guarantee-polygon-ink ink 'set-polygon-ink-fill-color!)
+ (let ((color (->color color 'set-polygon-ink-fill-color!)))
+ (without-interrupts
+ (lambda ()
+ (if (set-option!? ink 'FILL color)
+ (drawing-damage ink))))))
+
+\f
(define-integrable flo:pi (flo:* 4. (flo:atan2 1. 1.)))
(define-class (<arc-ink> (constructor ()))
rectangle-ink-width set-rectangle-ink-width!
rectangle-ink-fill-color set-rectangle-ink-fill-color!
+ <polygon-ink> polygon-ink? make-polygon-ink set-polygon-ink!
+ polygon-ink-color set-polygon-ink-color!
+ polygon-ink-width set-polygon-ink-width!
+ polygon-ink-fill-color set-polygon-ink-fill-color!
+
<arc-ink> arc-ink? make-arc-ink set-arc-ink!
arc-ink-start-angle set-arc-ink-start-angle!
arc-ink-sweep-angle set-arc-ink-sweep-angle!
(define-package (gtk fix-layout demo)
(parent (gtk fix-layout))
(files "fix-demo")
+ (import (gtk cairo)
+ cairo-identity-matrix cairo-matrix-scale! cairo-matrix-translate!
+ cairo-point x y cairo-transform! guarantee-flonum)
(import (gtk fix-layout)
fix-layout-view)
(export ()
fix-layout-view fix-ink-extent fix-ink-draw-callback
fix-drawing-display-list set-fix-drawing-display-list!
set-fix-ink-drawing! fix-ink-in-widget? fix-ink-in?
+ line-ink-vector
fix-rect-x fix-rect-y with-fix-rect
set-fix-rect-size! fix-rect-move! copy-fix-rect!
point-in-fix-rect? fix-rect-union!)
+ (import (gtk cairo)
+ cairo-point x y set-x! set-y! cairo-transform!
+ cairo-rotation-matrix cairo-matrix-scale! cairo-matrix-translate!)
(export (swat)
add-child! remove-child! ask-widget
add-event-handler! set-callback!
#| -*-Scheme-*-
-Copyright (C) 2010, 2011, 2012 Matthew Birkholz
+Copyright (C) 2010, 2011, 2012, 2013 Matthew Birkholz
This file is part of an extension to MIT/GNU Scheme.
picks)))
(define-class (<swat-line> (constructor ()))
- (<line-ink> <swat-ink>))
+ (<line-ink> <swat-ink>)
+ ;; #f, FIRST or SECOND
+ (arrow define standard initial-value #f)
+ ;; a <swat-polygon>
+ (arrow-head define standard initial-value #f))
+
+(define-method fix-ink-move! ((line <swat-line>) dx dy)
+ (call-next-method line dx dy)
+ (let ((arrow-head (swat-line-arrow-head line)))
+ (if arrow-head (fix-ink-move! arrow-head dx dy))))
+
+(define-class (<swat-polygon> (constructor ()))
+ (<polygon-ink> <swat-ink>))
(define-class (<swat-rectangle> (constructor ()))
(<rectangle-ink> <swat-ink>))
(error:wrong-type-argument value "an anchor direction" 'set-item-anchor!))
(set-swat-text-anchor! text value))
-(define-generic set-item-arrow! (item first?))
-(define-method set-item-arrow! ((line <swat-line>) first?)
- (warn "Unimplemented:" '(set-item-arrow! <swat-line>) line first?))
+(define-generic set-item-arrow! (item end))
+(define-method set-item-arrow! ((line <swat-line>) end)
+ (if (not (memq end '(#F FIRST LAST)))
+ (error:wrong-type-argument end "#F, 'FIRST or 'LAST" 'SET-ITEM-ARROW!))
+ (let ((head (swat-line-arrow-head line)))
+ (set-swat-line-arrow! line end)
+ (cond ((and end (not head))
+ (set-swat-line-arrow-head! line (make-arrow-head line end)))
+ ((and (not end) head)
+ (fix-ink-remove! head)
+ (set-swat-line-arrow-head! line #f)))))
+
+(define (make-arrow-head line end)
+ (let ((head (make-swat-polygon)))
+ (set-polygon-ink-fill-color! head (let ((c (line-ink-color line)))
+ (if (null? c) "black" c)))
+ (update-arrow-head head line end)
+ (fix-drawing-add-ink! (fix-ink-drawing line) head line)
+ (set-swat-line-arrow-head! line head)))
+
+(define (update-arrow-head ink line end)
+ (set-polygon-ink!
+ ink
+ (with-fix-rect
+ (line-ink-vector line)
+ (lambda (startx starty dx dy)
+ (let ((matrix (cairo-rotation-matrix
+ (flo:atan2 (flo:- 0. (->flonum dy)) (->flonum dx)))))
+ (cairo-matrix-scale!
+ matrix
+ (->flonum (let ((w (line-ink-width line)))
+ (if (null? w) 1 w))))
+ (cairo-matrix-translate!
+ matrix
+ (->flonum (if (eq? end 'FIRST) startx (+ startx dx)))
+ (->flonum (if (eq? end 'FIRST) starty (+ starty dy))))
+ (let ((pt (cairo-point 0. 0.)))
+ (map (lambda (pair)
+ (set-x! pt (->flonum (car pair)))
+ (set-y! pt (->flonum (cdr pair)))
+ (cairo-transform! pt matrix)
+ (cons (round->exact (x pt))
+ (round->exact (y pt))))
+ '((0 . 0) (-10 . 2) (-10 . -2) (0 . 0)))))))))
(define-generic set-item-fill! (item color))
(define-method set-item-fill! ((item <swat-line>) color)
+ (let ((head (swat-line-arrow-head item)))
+ (if head (set-polygon-ink-color! head color)))
(set-line-ink-color! item color))
(define-method set-item-fill! ((item <swat-oval>) color)
(set-arc-ink-fill-color! item color))
(define-generic set-item-width! (item value))
(define-method set-item-width! ((item <swat-line>) width)
+ (let ((head (swat-line-arrow-head item)))
+ (if head (set-polygon-ink-width! head width)))
(set-line-ink-width! item width))
(define-method set-item-width! ((item <swat-oval>) width)
(guarantee-positive-fixnum width '(set-item-width! <swat-oval>))
projects / mit-scheme.git / commitdiff