1 | ; A test program for the Cairo bindings |
---|
2 | ; Michael Bridgen <mikeb@squaremobius.net> |
---|
3 | ; Tony Garnock-Jones <tonyg@kcbbs.gen.nz> |
---|
4 | |
---|
5 | (use fmt) |
---|
6 | (use posix) |
---|
7 | (use sdl) |
---|
8 | (use cairo) |
---|
9 | (import chicken scheme foreign) |
---|
10 | |
---|
11 | ;; only required on OS X |
---|
12 | ;; (declare |
---|
13 | ;; (foreign-declare "#include <SDL/SDL.h>\n") |
---|
14 | ;; (run-time-macros)) |
---|
15 | ;; (foreign-code "SDL_Init(SDL_INIT_EVERYTHING);") |
---|
16 | |
---|
17 | (sdl-init SDL_INIT_EVERYTHING) |
---|
18 | |
---|
19 | (define maxx 640) |
---|
20 | (define maxy 480) |
---|
21 | |
---|
22 | (sdl-wm-set-caption "TestCairo" "TestCairo") |
---|
23 | (define s (sdl-set-video-mode maxx maxy 0 (+ SDL_HWSURFACE |
---|
24 | SDL_HWPALETTE |
---|
25 | SDL_DOUBLEBUF))) |
---|
26 | |
---|
27 | |
---|
28 | (define is (cairo-image-surface-create-for-data |
---|
29 | (sdl-surface-pixels s) |
---|
30 | CAIRO_FORMAT_RGB24 maxx maxy |
---|
31 | (sdl-surface-pitch s))) |
---|
32 | |
---|
33 | (define c (cairo-create is)) |
---|
34 | |
---|
35 | (define (draw-example c) |
---|
36 | (define (tri) |
---|
37 | (cairo-new-path c) |
---|
38 | (cairo-move-to c 110 110) |
---|
39 | (cairo-line-to c 110 190) |
---|
40 | (cairo-line-to c 190 190) |
---|
41 | (cairo-close-path c)) |
---|
42 | |
---|
43 | (define (radians degrees) |
---|
44 | (* 3.142 (/ degrees 180))) |
---|
45 | |
---|
46 | (define (sector x y d) |
---|
47 | (cairo-new-path c) |
---|
48 | (cairo-move-to c x y) |
---|
49 | (cairo-line-to c (+ x d) y) |
---|
50 | (cairo-line-to c (+ x d) (+ y d)) |
---|
51 | (cairo-arc c (+ x d) y d (radians 90) (radians 180))) |
---|
52 | |
---|
53 | (sdl-fill-rect s (make-sdl-rect 0 0 maxx maxy) (sdl-map-rgb (sdl-surface-pixel-format s) 0 0 0)) |
---|
54 | |
---|
55 | (cairo-set-source-rgba c 1 1 0 1) |
---|
56 | |
---|
57 | (cairo-set-line-width c 20) |
---|
58 | |
---|
59 | (cairo-new-path c) |
---|
60 | (cairo-set-line-cap c CAIRO_LINE_CAP_BUTT) |
---|
61 | (cairo-move-to c 10 10) |
---|
62 | (cairo-line-to c 10 80) |
---|
63 | |
---|
64 | (cairo-stroke c) |
---|
65 | |
---|
66 | (cairo-new-path c) |
---|
67 | (cairo-set-line-cap c CAIRO_LINE_CAP_ROUND) |
---|
68 | (cairo-move-to c 50 10) |
---|
69 | (cairo-line-to c 50 80) |
---|
70 | (cairo-stroke c) |
---|
71 | (cairo-new-path c) |
---|
72 | (cairo-set-line-cap c CAIRO_LINE_CAP_SQUARE) |
---|
73 | (cairo-move-to c 90 10) |
---|
74 | (cairo-line-to c 90 80) |
---|
75 | (cairo-stroke c) |
---|
76 | |
---|
77 | (cairo-set-line-join c CAIRO_LINE_JOIN_BEVEL) |
---|
78 | |
---|
79 | |
---|
80 | (cairo-set-line-width c 10) |
---|
81 | (tri) |
---|
82 | (cairo-set-source-rgb c 0 1 1) |
---|
83 | (cairo-stroke c) |
---|
84 | (tri) |
---|
85 | (cairo-set-source-rgb c 1 0 1) |
---|
86 | (cairo-fill c) |
---|
87 | |
---|
88 | (sector 240 240 60) |
---|
89 | (cairo-set-line-join c CAIRO_LINE_JOIN_MITER) |
---|
90 | (cairo-set-source-rgb c 1 0.5 0) |
---|
91 | (cairo-stroke c) |
---|
92 | |
---|
93 | (cairo-reset-clip c) |
---|
94 | (cairo-new-path c) |
---|
95 | (cairo-rectangle c 30 240 70 300) |
---|
96 | (cairo-clip c) |
---|
97 | (cairo-new-path c) |
---|
98 | (sector 20 250 100) |
---|
99 | (cairo-set-source-rgb c 0 0.5 1) |
---|
100 | (cairo-fill c) |
---|
101 | |
---|
102 | (cairo-reset-clip c) |
---|
103 | (sector 20 250 100) |
---|
104 | (cairo-set-source-rgba c 0 0.5 1 0.3) |
---|
105 | (cairo-fill c) |
---|
106 | |
---|
107 | (cairo-select-font-face c "sans-serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL) |
---|
108 | (cairo-set-font-size c 30) |
---|
109 | |
---|
110 | (cairo-move-to c 300 100) |
---|
111 | (cairo-set-source-rgba c 1 1 1 1) |
---|
112 | (cairo-show-text c "Chicken Cairo") |
---|
113 | |
---|
114 | (let ((ext (make-cairo-text-extents-type))) |
---|
115 | (cairo-text-extents c "Chicken Cairo" ext) |
---|
116 | ; (display ext)(newline) |
---|
117 | (cairo-new-path c) |
---|
118 | (cairo-rectangle c 300 100 (cairo-text-extents-width ext) (- (cairo-text-extents-height ext))) |
---|
119 | (cairo-set-source-rgba c 1 1 1 0.5) |
---|
120 | (cairo-set-line-width c 2.0) |
---|
121 | (cairo-stroke c))) |
---|
122 | |
---|
123 | (draw-example c) |
---|
124 | (sdl-flip s) |
---|
125 | |
---|
126 | (let ((event (make-sdl-event)) |
---|
127 | (last-pos '(0 . 0)) |
---|
128 | (mouse-is-down #f)) |
---|
129 | (let loop () |
---|
130 | (sdl-wait-event! event) |
---|
131 | (let ((t (sdl-event-type event))) |
---|
132 | (cond ((= t SDL_MOUSEBUTTONDOWN) |
---|
133 | (set! last-pos `(,(sdl-event-x event) . ,(sdl-event-y event))) |
---|
134 | (set! mouse-is-down #t) |
---|
135 | (fmt #t "saved mouse pos " last-pos nl)) |
---|
136 | ((= t SDL_MOUSEMOTION) |
---|
137 | (if mouse-is-down |
---|
138 | (let* ((cur-x (sdl-event-x event)) |
---|
139 | (cur-y (sdl-event-y event)) |
---|
140 | (inc-x (- cur-x (car last-pos))) |
---|
141 | (inc-y (- cur-y (cdr last-pos)))) |
---|
142 | (unless (and (eq? inc-x 0) (eq? inc-y 0)) |
---|
143 | (set! last-pos `(,cur-x . ,cur-y)) |
---|
144 | (fmt #t "transforming by " inc-x " " inc-y nl) |
---|
145 | (cairo-translate c inc-x inc-y) |
---|
146 | (draw-example c) |
---|
147 | (sdl-flip s))))) |
---|
148 | ((= t SDL_MOUSEBUTTONUP) |
---|
149 | (set! mouse-is-down #f)) |
---|
150 | ((= t SDL_QUIT) |
---|
151 | 'done))) |
---|
152 | (loop))) |
---|
153 | |
---|
154 | (exit 0) |
---|