Ticket #762: test-cairo.scm

; A test program for the Cairo bindings
; Michael Bridgen <mikeb@squaremobius.net>
; Tony Garnock-Jones <tonyg@kcbbs.gen.nz>

(use fmt)
(use posix)
(use sdl)
(use cairo)
(import chicken scheme foreign)

;; (declare
;;  (foreign-declare "#include <SDL/SDL.h>\n")
;;  (run-time-macros))

;; (foreign-code "SDL_Init(SDL_INIT_EVERYTHING);")

(sdl-init SDL_INIT_EVERYTHING)

(define maxx 640)
(define maxy 480)
(define no-extents #f)

(sdl-wm-set-caption "TestCairo" "TestCairo")
(define s (sdl-set-video-mode maxx maxy 0 (+ SDL_HWSURFACE
                                             SDL_HWPALETTE
                                             SDL_DOUBLEBUF)))


(define is (cairo-image-surface-create-for-data
            (sdl-surface-pixels s)
            CAIRO_FORMAT_RGB24 maxx maxy
            (sdl-surface-pitch s)))

(define c (cairo-create is))

(define (cairo-clear cr)
  (cairo-set-source-rgba cr 1 1 1 1) ;; black
  (cairo-paint cr))

(define (draw-example c)

  (define (draw-boxed-text x y str)
    (cairo-select-font-face c "sans-serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL)
    (cairo-set-font-size c 30)

    (cairo-move-to c x y)
    (cairo-set-source-rgba c 0 0 1 1)
    (cairo-show-text c str)

    (if no-extents
        (begin
          (cairo-set-source-rgba c 0 0 0 0.5)
          (cairo-set-line-width c 2.0)
          (cairo-rectangle c x y 50 -20)
          (cairo-stroke c))
        (let ((ext (make-cairo-text-extents-type)))
          (cairo-text-extents c str ext)
          (cairo-new-path c)
          (cairo-set-source-rgba c 0 0 0 0.5)
          (cairo-set-line-width c 2.0)
          (cairo-rectangle c x y (cairo-text-extents-width ext) (- (cairo-text-extents-height ext)))
          (cairo-stroke c))))

  (cairo-clear c)
  (draw-boxed-text 1 50 "hello")
  (draw-boxed-text 1 100 "world")
  (draw-boxed-text 1 200 "Foo1")
  (draw-boxed-text 100 200 "Foo2")
  (draw-boxed-text 200 400 "Foo3"))

(draw-example c)
(sdl-flip s)

(let ((event (make-sdl-event))
      (last-pos '(0 . 0))
      (mouse-is-down #f))
  (let loop ()
    (sdl-wait-event! event)
    (let ((t (sdl-event-type event)))
      (cond ((= t SDL_MOUSEBUTTONDOWN)
             (set! last-pos `(,(sdl-event-x event) . ,(sdl-event-y event)))
             (set! mouse-is-down #t))
             ;;(fmt #t "saved mouse pos " last-pos nl))
            ((= t SDL_MOUSEMOTION)
             (if mouse-is-down
                 (let* ((cur-x (sdl-event-x event))
                        (cur-y (sdl-event-y event))
                        (inc-x (- cur-x (car last-pos)))
                        (inc-y (- cur-y (cdr last-pos))))
                   (unless (and (eq? inc-x 0) (eq? inc-y 0))
                     (set! last-pos `(,cur-x . ,cur-y))
                     ;; (fmt #t "transforming by " inc-x " " inc-y nl)
                     (cairo-translate c inc-x inc-y)
                     (draw-example c)
                     (sdl-flip s)))))
            ((= t SDL_MOUSEBUTTONUP)
             (set! mouse-is-down #f))
            ((= t SDL_QUIT)
             'done)))
    (loop)))

(exit 0)