From 4c9f7fb3e38daa7345dfdf2df5f496173af4ff46 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Fri, 22 Nov 2013 13:45:07 -0700 Subject: [PATCH] gtk: Added . Used it to make arrow heads for SWAT. Added a gold star to the demo. Used new cairo-matrix and -point procedures to scale and translate a unit star with N points. --- src/gtk/cairo.scm | 63 ++++++++++++++++++++- src/gtk/fix-demo.scm | 41 ++++++++++++++ src/gtk/fix-layout.scm | 123 ++++++++++++++++++++++++++++++++++++++++- src/gtk/gtk.pkg | 12 ++++ src/gtk/swat.scm | 67 ++++++++++++++++++++-- 5 files changed, 299 insertions(+), 7 deletions(-) diff --git a/src/gtk/cairo.scm b/src/gtk/cairo.scm index 5bc3e2c2a..920c49cbc 100644 --- a/src/gtk/cairo.scm +++ b/src/gtk/cairo.scm @@ -268,4 +268,65 @@ USA. (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 diff --git a/src/gtk/fix-demo.scm b/src/gtk/fix-demo.scm index 6ca1e531a..b19f8be1e 100644 --- a/src/gtk/fix-demo.scm +++ b/src/gtk/fix-demo.scm @@ -101,6 +101,7 @@ USA. (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)) @@ -112,32 +113,72 @@ USA. ;; 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))) diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm index 1feaa2945..5b1f0a8f8 100644 --- a/src/gtk/fix-layout.scm +++ b/src/gtk/fix-layout.scm @@ -1109,7 +1109,7 @@ USA. (define-guarantee rectangle-ink "a ") (define-method fix-ink-draw-callback ((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)) @@ -1231,6 +1231,127 @@ USA. (if (set-option!? ink 'FILL color) (drawing-damage ink)))))) +(define-class ( (constructor ())) + () + (vertices define standard initial-value '())) + +(define-guarantee polygon-ink "a ") + +(define-method fix-ink-draw-callback ((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 ) 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)))))) + + (define-integrable flo:pi (flo:* 4. (flo:atan2 1. 1.))) (define-class ( (constructor ())) diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index a843958e8..6aefbd893 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -307,6 +307,11 @@ USA. rectangle-ink-width set-rectangle-ink-width! rectangle-ink-fill-color set-rectangle-ink-fill-color! + 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? make-arc-ink set-arc-ink! arc-ink-start-angle set-arc-ink-start-angle! arc-ink-sweep-angle set-arc-ink-sweep-angle! @@ -417,6 +422,9 @@ USA. (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 () @@ -433,9 +441,13 @@ USA. 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! diff --git a/src/gtk/swat.scm b/src/gtk/swat.scm index 738ccceec..101e815da 100644 --- a/src/gtk/swat.scm +++ b/src/gtk/swat.scm @@ -1,6 +1,6 @@ #| -*-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. @@ -450,7 +450,19 @@ USA. picks))) (define-class ( (constructor ())) - ( )) + ( ) + ;; #f, FIRST or SECOND + (arrow define standard initial-value #f) + ;; a + (arrow-head define standard initial-value #f)) + +(define-method fix-ink-move! ((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 ( (constructor ())) + ( )) (define-class ( (constructor ())) ( )) @@ -712,12 +724,55 @@ USA. (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 ) first?) - (warn "Unimplemented:" '(set-item-arrow! ) line first?)) +(define-generic set-item-arrow! (item end)) +(define-method set-item-arrow! ((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 ) 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 ) color) (set-arc-ink-fill-color! item color)) @@ -743,6 +798,8 @@ USA. (define-generic set-item-width! (item value)) (define-method set-item-width! ((item ) 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 ) width) (guarantee-positive-fixnum width '(set-item-width! )) -- 2.25.1