From: Matt Birkholz Date: Fri, 5 Apr 2013 23:19:44 +0000 (-0700) Subject: gtk: Add gtk-graphics device type. X-Git-Tag: mit-scheme-pucked-9.2.12~525 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=eae9bf6d0d0b382000e8adbb815f9147eec36181;p=mit-scheme.git gtk: Add gtk-graphics device type. Just the simple operations plus fill-polygon-list, draw-circle, set-foreground-color and set-background-color. --- diff --git a/src/gtk/Includes/cairo.cdecl b/src/gtk/Includes/cairo.cdecl index 92f45fef9..71f02a2df 100644 --- a/src/gtk/Includes/cairo.cdecl +++ b/src/gtk/Includes/cairo.cdecl @@ -49,8 +49,41 @@ cairo/cairo.h |# (extern void cairo_restore (cr (* cairo_t))) -(extern void cairo_set_source (cr (* cairo_t)) - (source (* cairo_pattern_t))) +(typedef cairo_operator_t + (enum _cairo_operator + (CAIRO_OPERATOR_CLEAR) + (CAIRO_OPERATOR_SOURCE) + (CAIRO_OPERATOR_OVER) + (CAIRO_OPERATOR_IN) + (CAIRO_OPERATOR_OUT) + (CAIRO_OPERATOR_ATOP) + (CAIRO_OPERATOR_DEST) + (CAIRO_OPERATOR_DEST_OVER) + (CAIRO_OPERATOR_DEST_IN) + (CAIRO_OPERATOR_DEST_OUT) + (CAIRO_OPERATOR_DEST_ATOP) + (CAIRO_OPERATOR_XOR) + (CAIRO_OPERATOR_ADD) + (CAIRO_OPERATOR_SATURATE) + (CAIRO_OPERATOR_MULTIPLY) + (CAIRO_OPERATOR_SCREEN) + (CAIRO_OPERATOR_OVERLAY) + (CAIRO_OPERATOR_DARKEN) + (CAIRO_OPERATOR_LIGHTEN) + (CAIRO_OPERATOR_COLOR_DODGE) + (CAIRO_OPERATOR_COLOR_BURN) + (CAIRO_OPERATOR_HARD_LIGHT) + (CAIRO_OPERATOR_SOFT_LIGHT) + (CAIRO_OPERATOR_DIFFERENCE) + (CAIRO_OPERATOR_EXCLUSION) + (CAIRO_OPERATOR_HSL_HUE) + (CAIRO_OPERATOR_HSL_SATURATION) + (CAIRO_OPERATOR_HSL_COLOR) + (CAIRO_OPERATOR_HSL_LUMINOSITY))) + +(extern void cairo_set_operator (cr (* cairo_t)) (op cairo_operator_t)) + +(extern void cairo_set_source (cr (* cairo_t)) (source (* cairo_pattern_t))) (extern void cairo_set_source_rgba (cr (* cairo_t)) (red double)(green double)(blue double)(alpha double)) diff --git a/src/gtk/compile.scm b/src/gtk/compile.scm index 5bcaab1e0..b17cd648a 100644 --- a/src/gtk/compile.scm +++ b/src/gtk/compile.scm @@ -38,6 +38,7 @@ ("scm-widget" ,@base) ("fix-layout" "pango" "cairo" ,@base ,@c-types) ("keys" ,@base ,@c-types) + ("gtk-graphics" ,@base) ("main" ,@base) ("thread" "main" ,@user) ("gtk-ev" ,@base) diff --git a/src/gtk/gtk-graphics.scm b/src/gtk/gtk-graphics.scm new file mode 100644 index 000000000..a8921ffad --- /dev/null +++ b/src/gtk/gtk-graphics.scm @@ -0,0 +1,347 @@ +#| -*-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 ( (constructor () (width height))) + () + + ;; 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 ) 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 diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index 4a247ceb6..f68449473 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -399,6 +399,21 @@ USA. (export () make-fix-layout-demo)) +(define-package (runtime gtk-graphics) + (parent (gtk)) + (files "gtk-graphics") + (import (gtk fix-layout) + fix-ink-extent fix-rect-height fix-rect-width + ->color set-surface-ink-surface! drawing-damage) + (export () + gtk-graphics/set-background-color + gtk-graphics/set-foreground-color + gtk-graphics/draw-line + gtk-graphics/draw-text + gtk-graphics/draw-circle + gtk-graphics/fill-polygon-list + gtk-graphics/flush)) + (define-package (gtk swat) (parent (gtk)) (files "swat")