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 | ;; (declare |
---|
12 | ;; (foreign-declare "#include <SDL/SDL.h>\n") |
---|
13 | ;; (run-time-macros)) |
---|
14 | |
---|
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 | (define no-extents #f) |
---|
22 | |
---|
23 | (sdl-wm-set-caption "TestCairo" "TestCairo") |
---|
24 | (define s (sdl-set-video-mode maxx maxy 0 (+ SDL_HWSURFACE |
---|
25 | SDL_HWPALETTE |
---|
26 | SDL_DOUBLEBUF))) |
---|
27 | |
---|
28 | |
---|
29 | (define is (cairo-image-surface-create-for-data |
---|
30 | (sdl-surface-pixels s) |
---|
31 | CAIRO_FORMAT_RGB24 maxx maxy |
---|
32 | (sdl-surface-pitch s))) |
---|
33 | |
---|
34 | (define c (cairo-create is)) |
---|
35 | |
---|
36 | (define (cairo-clear cr) |
---|
37 | (cairo-set-source-rgba cr 1 1 1 1) ;; black |
---|
38 | (cairo-paint cr)) |
---|
39 | |
---|
40 | (define (draw-example c) |
---|
41 | |
---|
42 | (define (draw-boxed-text x y str) |
---|
43 | (cairo-select-font-face c "sans-serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL) |
---|
44 | (cairo-set-font-size c 30) |
---|
45 | |
---|
46 | (cairo-move-to c x y) |
---|
47 | (cairo-set-source-rgba c 0 0 1 1) |
---|
48 | (cairo-show-text c str) |
---|
49 | |
---|
50 | (if no-extents |
---|
51 | (begin |
---|
52 | (cairo-set-source-rgba c 0 0 0 0.5) |
---|
53 | (cairo-set-line-width c 2.0) |
---|
54 | (cairo-rectangle c x y 50 -20) |
---|
55 | (cairo-stroke c)) |
---|
56 | (let ((ext (make-cairo-text-extents-type))) |
---|
57 | (cairo-text-extents c str ext) |
---|
58 | (cairo-new-path c) |
---|
59 | (cairo-set-source-rgba c 0 0 0 0.5) |
---|
60 | (cairo-set-line-width c 2.0) |
---|
61 | (cairo-rectangle c x y (cairo-text-extents-width ext) (- (cairo-text-extents-height ext))) |
---|
62 | (cairo-stroke c)))) |
---|
63 | |
---|
64 | (cairo-clear c) |
---|
65 | (draw-boxed-text 1 50 "hello") |
---|
66 | (draw-boxed-text 1 100 "world") |
---|
67 | (draw-boxed-text 1 200 "Foo1") |
---|
68 | (draw-boxed-text 100 200 "Foo2") |
---|
69 | (draw-boxed-text 200 400 "Foo3")) |
---|
70 | |
---|
71 | (draw-example c) |
---|
72 | (sdl-flip s) |
---|
73 | |
---|
74 | (let ((event (make-sdl-event)) |
---|
75 | (last-pos '(0 . 0)) |
---|
76 | (mouse-is-down #f)) |
---|
77 | (let loop () |
---|
78 | (sdl-wait-event! event) |
---|
79 | (let ((t (sdl-event-type event))) |
---|
80 | (cond ((= t SDL_MOUSEBUTTONDOWN) |
---|
81 | (set! last-pos `(,(sdl-event-x event) . ,(sdl-event-y event))) |
---|
82 | (set! mouse-is-down #t)) |
---|
83 | ;;(fmt #t "saved mouse pos " last-pos nl)) |
---|
84 | ((= t SDL_MOUSEMOTION) |
---|
85 | (if mouse-is-down |
---|
86 | (let* ((cur-x (sdl-event-x event)) |
---|
87 | (cur-y (sdl-event-y event)) |
---|
88 | (inc-x (- cur-x (car last-pos))) |
---|
89 | (inc-y (- cur-y (cdr last-pos)))) |
---|
90 | (unless (and (eq? inc-x 0) (eq? inc-y 0)) |
---|
91 | (set! last-pos `(,cur-x . ,cur-y)) |
---|
92 | ;; (fmt #t "transforming by " inc-x " " inc-y nl) |
---|
93 | (cairo-translate c inc-x inc-y) |
---|
94 | (draw-example c) |
---|
95 | (sdl-flip s))))) |
---|
96 | ((= t SDL_MOUSEBUTTONUP) |
---|
97 | (set! mouse-is-down #f)) |
---|
98 | ((= t SDL_QUIT) |
---|
99 | 'done))) |
---|
100 | (loop))) |
---|
101 | |
---|
102 | (exit 0) |
---|