--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2013 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Scheme Graphics Operations to a Cairo Image Surface.
+;;; package: (runtime gtk-graphics)
+
+(define-class (<gtk-graphics> (constructor () (width height)))
+ (<surface-ink>)
+
+ ;; Cairo Context -- |cairo_t| alien.
+ (context define standard initial-value #f)
+
+ ;; Bounds to which context is clipped, scaled, translated...
+ (limits define standard initial-value '(-1. -1. 1. 1.))
+ (scale define standard initial-value 1.)
+
+ (fgcolor define standard initial-value #f)
+ (fgcolor-name define standard initial-value #f)
+ (bgcolor define standard initial-value #f)
+ (bgcolor-name define standard initial-value #f))
+
+(define-method initialize-instance ((graphics <gtk-graphics>) width height)
+ (call-next-method graphics width height)
+ (let ((cr (cairo-create (surface-ink-surface graphics)))
+ (factor (->flonum (/ (min (-1+ width) (-1+ height)) 2))))
+ (if (not (flo:positive? factor))
+ (error "Invalid width x height:" width height))
+ (C-call "cairo_save" cr)
+ (C-call "cairo_scale" cr factor (flo:negate factor))
+ (set-gtk-graphics-scale! graphics factor)
+ (C-call "cairo_set_line_width" cr (flo:/ 1.0 factor))
+ (cairo-set-font-matrix cr (let ((k (flo:/ 10.0 factor)))
+ (cairo-matrix k 0. 0.
+ 0. (flo:negate k) 0.)))
+ (C-call "cairo_translate" cr 1.0 -1.0)
+ (let ((black (->color "black" 'make-gtk-graphics))
+ (white (->color "white" 'make-gtk-graphics)))
+ (C-call "cairo_set_source_rgba" cr
+ (color-red white) (color-green white) (color-blue white)
+ (color-alpha white))
+ (C-call "cairo_paint" cr)
+ (C-call "cairo_set_source_rgba" cr
+ (color-red black) (color-green black) (color-blue black)
+ (color-alpha black))
+ (set-gtk-graphics-bgcolor-name! graphics "white")
+ (set-gtk-graphics-bgcolor! graphics white)
+ (set-gtk-graphics-fgcolor-name! graphics "black")
+ (set-gtk-graphics-fgcolor! graphics black))
+ (set-gtk-graphics-context! graphics cr)))
+
+(define gtk-graphics/available? gtk-thread-running?)
+
+(define (gtk-graphics/open make-device #!optional width height)
+ (let ((width (if (default-object? width) 512 width))
+ (height (if (default-object? height) 384 height)))
+ (guarantee-positive-fixnum width 'gtk-graphics/open)
+ (guarantee-positive-fixnum height 'gtk-graphics/open)
+ (let ((window (gtk-window-new 'toplevel))
+ (scroller (gtk-scrolled-view-new))
+ (layout (make-fix-layout width height))
+ (drawing (make-fix-drawing))
+ (graphics (make-gtk-graphics width height)))
+ (fix-drawing-add-ink! drawing graphics)
+ (set-fix-drawing-size! drawing width height)
+ (set-fix-layout-drawing! layout drawing 0 0)
+ (gtk-widget-set-hexpand layout #t)
+ (gtk-widget-set-vexpand layout #t)
+ (gtk-container-add scroller layout)
+ (gtk-container-set-border-width window 5)
+ (gtk-container-add window scroller)
+ (gtk-widget-show-all window)
+ (make-device graphics))))
+
+(define (toplevel graphics)
+ (let ((widgets (fix-drawing-widgets (fix-ink-drawing graphics))))
+ (if (null? (cdr widgets))
+ (let loop ((parent (gtk-widget-parent (car widgets))))
+ (cond ((gtk-window? parent)
+ parent)
+ ((gtk-widget? parent)
+ (loop (gtk-widget-parent parent)))
+ (else (error "gtk-graphics/toplevel not found"))))
+ (error "gtk-graphics/toplevel ambiguous"))))
+
+(define (gtk-graphics/close device)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((toplevel (toplevel graphics))
+ (surface (surface-ink-surface graphics))
+ (cr (gtk-graphics-context graphics)))
+ (gtk-widget-destroy toplevel)
+ (set-surface-ink-surface! graphics #f)
+ (cairo-surface-destroy surface)
+ (set-gtk-graphics-context! graphics #f)
+ (cairo-destroy cr))))
+
+(define (gtk-graphics/device-coordinate-limits device)
+ (let ((extent (fix-ink-extent (graphics-device/descriptor device))))
+ (values 0 (fix-rect-height extent) (fix-rect-width extent) 0)))
+
+(define (gtk-graphics/coordinate-limits device)
+ (apply values (gtk-graphics-limits (graphics-device/descriptor device))))
+
+(define (gtk-graphics/set-coordinate-limits device x-left y-bottom x-right y-top)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((extent (fix-ink-extent graphics))
+ (cr (gtk-graphics-context graphics)))
+ (if (zero? (- x-right x-left)) (error "Zero width coordinate limits:" 'x-left x-left 'y-bottom y-bottom 'x-right x-right 'y-top y-top))
+ (if (zero? (- y-bottom y-top)) (error "Zero height coordinate limits:" 'x-left x-left 'y-bottom y-bottom 'x-right x-right 'y-top y-top))
+ (C-call "cairo_restore" cr) ;back to device coords.
+ (C-call "cairo_save" cr)
+ (let ((x-factor (->flonum (/ (-1+ (fix-rect-width extent))
+ (- x-right x-left))))
+ (y-factor (->flonum (/ (-1+ (fix-rect-height extent))
+ (- y-bottom y-top)))))
+ (C-call "cairo_scale" cr x-factor y-factor)
+ (let ((factor (flo:min (flo:abs x-factor) (flo:abs y-factor))))
+ (set-gtk-graphics-scale! graphics factor)
+ (C-call "cairo_set_line_width" cr (flo:/ 1.0 factor))
+ (cairo-set-font-matrix cr (let ((k (flo:/ 10.0 factor)))
+ (cairo-matrix k 0. 0.
+ 0. (flo:negate k) 0.)))))
+ (C-call "cairo_translate" cr (->flonum (- x-left)) (->flonum (- y-top)))
+ (let ((fgcolor (gtk-graphics-fgcolor graphics)))
+ (C-call "cairo_set_source_rgba" cr
+ (color-red fgcolor) (color-green fgcolor) (color-blue fgcolor)
+ (color-alpha fgcolor))))
+ (set-gtk-graphics-limits! graphics (list x-left y-bottom x-right y-top))))
+
+(define (gtk-graphics/clear device)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((cr (gtk-graphics-context graphics))
+ (bgcolor (gtk-graphics-bgcolor graphics))
+ (bgcolor-name (gtk-graphics-bgcolor-name graphics)))
+ (set-gtk-graphics-fgcolor! graphics bgcolor)
+ (set-gtk-graphics-fgcolor-name! graphics bgcolor-name)
+ (C-call "cairo_set_source_rgba" cr
+ (color-red bgcolor) (color-green bgcolor) (color-blue bgcolor)
+ (color-alpha bgcolor))
+ (C-call "cairo_reset_clip" cr)
+ (C-call "cairo_paint" cr))))
+
+(define gtk-graphics-point-size
+ ;; A flonum number of pixels.
+ 5.)
+
+(define (gtk-graphics/draw-point device x y)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((cr (gtk-graphics-context graphics))
+ (x (->flonum x))
+ (y (->flonum y))
+ (radius (/ 3.0 (gtk-graphics-scale device))))
+ (C-call "cairo_arc" cr x y radius 0. 2pi)
+ (C-call "cairo_stroke" cr))))
+
+(define (gtk-graphics/draw-line device x-start y-start x-end y-end)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((cr (gtk-graphics-context graphics))
+ (x (->flonum x-start))
+ (y (->flonum y-start)))
+ (let ((dx (flo:- (->flonum x-end) x))
+ (dy (flo:- (->flonum y-end) y)))
+ (C-call "cairo_move_to" cr x y)
+ (C-call "cairo_rel_line_to" cr dx dy)
+ (C-call "cairo_stroke" cr)))))
+
+(define (gtk-graphics/draw-text device x y string)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((cr (gtk-graphics-context graphics))
+ (x (->flonum x))
+ (y (->flonum y)))
+ (C-call "cairo_move_to" cr x y)
+ (C-call "cairo_show_text" cr string))))
+
+(define-integrable 2pi (flo:* 8. (flo:atan2 1. 1.)))
+
+(define (gtk-graphics/draw-circle device x y radius)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((cr (gtk-graphics-context graphics))
+ (x (->flonum x))
+ (y (->flonum y))
+ (radius (->flonum radius)))
+ (C-call "cairo_arc" cr x y radius 0. 2pi)
+ (C-call "cairo_stroke" cr))))
+
+(define (gtk-graphics/move-cursor device x y)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((cr (gtk-graphics-context graphics))
+ (x (->flonum x))
+ (y (->flonum y)))
+ (C-call "cairo_move_to" cr x y))))
+
+(define (gtk-graphics/drag-cursor device x y)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((cr (gtk-graphics-context graphics))
+ (x (->flonum x))
+ (y (->flonum y)))
+ (C-call "cairo_line_to" cr x y)
+ (C-call "cairo_stroke" cr))))
+
+(define (gtk-graphics/set-drawing-mode device mode)
+ (let ((graphics (graphics-device/descriptor device))
+ (op
+ (case mode
+ ((0) (C-enum "CAIRO_OPERATOR_CLEAR")) ;GXclear 0
+ ((1) (C-enum "CAIRO_OPERATOR_IN")) ;GXand src AND dst
+ ((2) (C-enum "CAIRO_OPERATOR_OUT")) ;GXandReverse src AND NOT dst
+ ((3) (C-enum "CAIRO_OPERATOR_SOURCE")) ;GXcopy src
+ ((4) (C-enum "CAIRO_OPERATOR_DEST_OUT")) ;GXandInverted NOT src AND dst
+ ((5) (C-enum "CAIRO_OPERATOR_DEST")) ;GXnoop dst
+ ((6) (C-enum "CAIRO_OPERATOR_XOR")) ;GXxor src XOR dst
+ ((7) (C-enum "CAIRO_OPERATOR_OVER")) ;GXor src OR dst
+ ((8) (warn "unimplemented:" '|GXnor|) #f) ;GXnor NOT src AND NOT dst
+ ((9) (warn "unimplemented:" '|GXequiv|) #f) ;GXequiv NOT src XOR dst
+ ((10) (warn "unimplemented:" '|GXinvert|) #f) ;GXinvert NOT dst
+ ((11) (warn "unimplemented:" '|GXorReverse|) #f) ;GXorReverse src OR NOT dst
+ ((12) (warn "unimplemented:" '|GXcopyInverted|) #f) ;GXcopyInverted NOT src
+ ((13) (warn "unimplemented:" '|GXorInverted|) #f) ;GXorInverted NOT src OR dst
+ ((14) (warn "unimplemented:" '|GXnand|) #f) ;GXnand NOT src OR NOT dst
+ ((15) (C-enum "CAIRO_OPERATOR_SOURCE")) ;GXset 1
+ (else (error:wrong-type-argument mode "a drawing mode"
+ 'gtk-graphics/set-drawing-mode)))))
+ (C-call "cairo_set_operator" (gtk-graphics-context graphics) op)))
+
+(define (gtk-graphics/set-line-style device style)
+ (let ((graphics (graphics-device/descriptor device))
+ (dashes
+ (case style
+ ((0) '())
+ ((1) '(8.))
+ ((2) '(1.))
+ ((3) '(13. 1. 1. 1.))
+ ((4) '(11. 1. 1. 1. 1. 1.))
+ ((5) '(11. 5.))
+ ((6) '(12. 1. 2. 1))
+ ((7) '( 9. 1. 2. 1. 2. 1.))
+ (else (error:wrong-type-argument style "a line style"
+ 'gtk-graphics/set-line-style)))))
+ (let ((cr (gtk-graphics-context graphics))
+ (count (length dashes))
+ (array (malloc (* (length dashes) (C-sizeof "double")) 'double)))
+ (let ((scan (copy-alien array)))
+ (let loop ((dashes dashes))
+ (if (pair? dashes)
+ (let ((len (->flonum (car dashes)))
+ (factor (flo:/ 16. (gtk-graphics-scale graphics))))
+ (if (flo:< len 0.) (error "Negative length:" len))
+ (C->= scan "double" (flo:* len factor))
+ (alien-byte-increment! scan (C-sizeof "double"))
+ (loop (cdr dashes)))))
+ (C-call "cairo_set_dash" cr array count 0.)
+ (free array)))))
+
+(define (gtk-graphics/fill-polygon-list device points)
+ ;; POINTS should be a list of flo:vectors each with a length greater than 1.
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((cr (gtk-graphics-context graphics))
+ (p (car points)))
+ (define-integrable (x p) (flo:vector-ref p 0))
+ (define-integrable (y p) (flo:vector-ref p 1))
+ (C-call "cairo_move_to" cr (x p) (y p))
+ (for-each (lambda (p)
+ (C-call "cairo_line_to" cr (x p) (y p)))
+ (cdr points))
+ (C-call "cairo_close_path" cr)
+ (C-call "cairo_fill" cr))))
+
+(define (gtk-graphics/flush device)
+ (let ((graphics (graphics-device/descriptor device)))
+ (cairo-surface-flush (surface-ink-surface graphics))
+ (drawing-damage graphics)))
+
+(define (gtk-graphics/set-background-color device name)
+ (let ((graphics (graphics-device/descriptor device)))
+ (if (not (string=? name (gtk-graphics-bgcolor-name graphics)))
+ (let ((new (->color name 'gtk-graphics/set-background-color)))
+ (set-gtk-graphics-bgcolor! graphics new)
+ (set-gtk-graphics-bgcolor-name! graphics name)))))
+
+(define (gtk-graphics/set-foreground-color device name)
+ (let ((graphics (graphics-device/descriptor device)))
+ (if (not (string=? name (gtk-graphics-fgcolor-name graphics)))
+ (let ((new (->color name 'gtk-graphics/set-foreground-color)))
+ (set-gtk-graphics-fgcolor! graphics new)
+ (set-gtk-graphics-fgcolor-name! graphics name)
+ (C-call "cairo_set_source_rgba" (gtk-graphics-context graphics)
+ (color-red new) (color-green new) (color-blue new)
+ (color-alpha new))))))
+
+(define (gtk-graphics/set-clip-rectangle device x-left y-bottom x-right y-top)
+ (let ((cr (gtk-graphics-context (graphics-device/descriptor device)))
+ (x (->flonum x-left))
+ (y (->flonum y-top)))
+ (let ((width (flo:- (->flonum x-right) x))
+ (height (flo:- (->flonum y-bottom) y)))
+ (C-call "cairo_rectangle" cr x y width height)
+ (C-call "cairo_clip" cr))))
+
+(define (gtk-graphics/reset-clip-rectangle device)
+ (let ((cr (gtk-graphics-context (graphics-device/descriptor device))))
+ (C-call "cairo_reset_clip" cr)))
+
+(define gtk-graphics-device-type)
+
+(define (initialize-package!)
+ (set! gtk-graphics-device-type
+ (make-graphics-device-type
+ 'GTK
+ `((available? ,gtk-graphics/available?)
+ (open ,gtk-graphics/open)
+ (clear ,gtk-graphics/clear)
+ (close ,gtk-graphics/close)
+ (coordinate-limits ,gtk-graphics/coordinate-limits)
+ (device-coordinate-limits ,gtk-graphics/device-coordinate-limits)
+ (move-cursor ,gtk-graphics/move-cursor)
+ (drag-cursor ,gtk-graphics/drag-cursor)
+ (draw-line ,gtk-graphics/draw-line)
+ (draw-point ,gtk-graphics/draw-point)
+ (draw-text ,gtk-graphics/draw-text)
+ (draw-circle ,gtk-graphics/draw-circle)
+ (flush ,gtk-graphics/flush)
+ (reset-clip-rectangle ,gtk-graphics/reset-clip-rectangle)
+ (set-clip-rectangle ,gtk-graphics/set-clip-rectangle)
+ (set-coordinate-limits ,gtk-graphics/set-coordinate-limits)
+ (set-drawing-mode ,gtk-graphics/set-drawing-mode)
+ (set-line-style ,gtk-graphics/set-line-style)))))
+
+(initialize-package!)
\ No newline at end of file
projects / mit-scheme.git / commitdiff