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

(import scheme
  (chicken base)
  (chicken foreign)
  (chicken condition)
  (chicken file posix)
  (srfi 4)
  (prefix sdl2 sdl2:)
  (prefix cairo cairo:)
  (prefix (cairo surface image) cairo:))

(define (cairo:make-text-extents-type) (make-f64vector 6))
(define (cairo:text-extents-x-bearing te) (f64vector-ref te 0))
(define (cairo:text-extents-y-bearing te) (f64vector-ref te 1))
(define (cairo:text-extents-width te) (f64vector-ref te 2))
(define (cairo:text-extents-height te) (f64vector-ref te 3))
(define (cairo:text-extents-x-advance te) (f64vector-ref te 4))
(define (cairo:text-extents-y-advance te) (f64vector-ref te 5))

(sdl2:set-main-ready!)
(sdl2:init! '(video))

;ensure we quit
(on-exit sdl2:quit!)
(current-exception-handler
 (let ((original-handler (current-exception-handler)))
   (lambda (exception)
     (sdl2:quit!)
     (original-handler exception))))

(define-constant MAX-X 640)
(define-constant MAX-Y 480)

(define w (sdl2:create-window! "TestCairo" 0 0 MAX-X MAX-Y))
(define s (sdl2:window-surface w))

(sdl2:fill-rect! s (sdl2:make-rect 0 0 MAX-X MAX-Y) (sdl2:map-rgb (sdl2:surface-format s) 0 0 0))
(sdl2:update-window-surface! w)

(define is (cairo:image-surface-create-for-data
            (sdl2:surface-pixels-raw s)
            'rgb24 MAX-X MAX-Y
            (sdl2:surface-pitch s)))

(define c (cairo:create is))

(cairo:set-source-rgba! c 1 1 0 1)

(cairo:set-line-width! c 20)

(cairo:new-path! c)
(cairo:set-line-cap! c 'butt)
(cairo:move-to! c 10 10)
(cairo:line-to! c 10 80)

(cairo:stroke! c)

(cairo:new-path! c)
(cairo:set-line-cap! c 'round)
(cairo:move-to! c 50 10)
(cairo:line-to! c 50 80)
(cairo:stroke! c)

(cairo:new-path! c)
(cairo:set-line-cap! c 'square)
(cairo:move-to! c 90 10)
(cairo:line-to! c 90 80)
(cairo:stroke! c)

(cairo:set-line-join! c 'bevel)
(define (tri)
  (cairo:new-path! c)
  (cairo:move-to! c 110 110)
  (cairo:line-to! c 110 190)
  (cairo:line-to! c 190 190)
  (cairo:close-path! c))

(cairo:set-line-width! c 10)
(tri)
(cairo:set-source-rgb! c 0 1 1)
(cairo:stroke! c)
(tri)
(cairo:set-source-rgb! c 1 0 1)
(cairo:fill! c)

(define (radians degrees)
  (* 3.142 (/ degrees 180)))

(define (sector x y d)
  (cairo:new-path! c)
  (cairo:move-to! c x y)
  (cairo:line-to! c (+ x d) y)
  (cairo:line-to! c (+ x d) (+ y d))
  (cairo:arc! c (+ x d) y d (radians 90) (radians 180)))

(sector 240 240 60)
(cairo:set-line-join! c 'miter )
(cairo:set-source-rgb! c 1 0.5 0)
(cairo:stroke! c)

(cairo:reset-clip! c)
(cairo:new-path! c)
(cairo:rectangle! c 30 240 70 300)
(cairo:clip! c)
(cairo:new-path! c)
(sector 20 250 100)
(cairo:set-source-rgb! c 0 0.5 1)
(cairo:fill! c)

(cairo:reset-clip! c)
(sector 20 250 100)
(cairo:set-source-rgba! c 0 0.5 1 0.3)
(cairo:fill! c)

(cairo:select-font-face! c "sans-serif" 'normal 'normal)
(cairo:set-font-size! c 30)

(cairo:move-to! c 300 100)
(cairo:set-source-rgba! c 1 1 1 1)
(cairo:show-text! c "Chicken Cairo")

(let ((ext (cairo:make-text-extents-type)))
  (cairo:text-extents c "Chicken Cairo" ext)
  (cairo:new-path! c)
  (cairo:rectangle! c 300 100 (cairo:text-extents-width ext) (- (cairo:text-extents-height ext)))
  (cairo:set-source-rgba! c 1 1 1 0.5)
  (cairo:set-line-width! c 2.0)
  (cairo:stroke! c))

(sdl2:update-window-surface! w)

(let ((event (sdl2:make-event)))
  (let loop ()
    (sdl2:wait-event! event)
    (let ((t (sdl2:event-type event)))
      (case t
        ((quit)
          'done)
        (else
          (loop))) ) ) )

(exit 0)