diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index dd27c01b2d..472db185fe 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -183,6 +183,7 @@ style-list% style<%> subarea<%> subwindow<%> +svg-dc% system-position-ok-before-cancel? tab-snip% text% diff --git a/collects/racket/draw.rkt b/collects/racket/draw.rkt index c06c9b19a0..20c8df7363 100644 --- a/collects/racket/draw.rkt +++ b/collects/racket/draw.rkt @@ -13,6 +13,7 @@ "draw/private/bitmap-dc.rkt" "draw/private/post-script-dc.rkt" "draw/private/ps-setup.rkt" + "draw/private/svg-dc.rkt" "draw/private/gl-config.rkt" "draw/private/gl-context.rkt") @@ -32,6 +33,7 @@ post-script-dc% pdf-dc% ps-setup% current-ps-setup + svg-dc% get-face-list get-family-builtin-face gl-config% diff --git a/collects/racket/draw/draw-sig.rkt b/collects/racket/draw/draw-sig.rkt index 03d77516ee..4b8162b4fa 100644 --- a/collects/racket/draw/draw-sig.rkt +++ b/collects/racket/draw/draw-sig.rkt @@ -27,6 +27,7 @@ post-script-dc% ps-setup% radial-gradient% region% +svg-dc% the-brush-list the-color-database the-font-list diff --git a/collects/racket/draw/private/post-script-dc.rkt b/collects/racket/draw/private/post-script-dc.rkt index 8d1257ee6c..6bdede6fba 100644 --- a/collects/racket/draw/private/post-script-dc.rkt +++ b/collects/racket/draw/private/post-script-dc.rkt @@ -6,13 +6,12 @@ "syntax.rkt" racket/gui/dynamic ffi/unsafe - ffi/unsafe/alloc "../unsafe/cairo.ss" - "../unsafe/bstr.ss" "dc.ss" "font.ss" "local.ss" - "ps-setup.ss") + "ps-setup.ss" + "write-bytes.rkt") (provide post-script-dc% pdf-dc%) @@ -183,12 +182,3 @@ (super-new))) (define pdf-dc% (class (dc-mixin (make-dc-backend #t)) (super-new))) - -(define (write-port-bytes port-box bytes len) - (write-bytes (scheme_make_sized_byte_string bytes len 0) - (ptr-ref port-box _racket)) - CAIRO_STATUS_SUCCESS) - -(define write_port_bytes (function-ptr write-port-bytes _cairo_write_func_t)) - -(define make-immobile ((allocator free-immobile-cell) malloc-immobile-cell)) diff --git a/collects/racket/draw/private/svg-dc.rkt b/collects/racket/draw/private/svg-dc.rkt new file mode 100644 index 0000000000..aac6490078 --- /dev/null +++ b/collects/racket/draw/private/svg-dc.rkt @@ -0,0 +1,86 @@ +#lang racket/base +(require racket/class + racket/file + racket/path + racket/math + "syntax.rkt" + ffi/unsafe + "../unsafe/cairo.ss" + "dc.ss" + "font.ss" + "local.ss" + "ps-setup.ss" + "write-bytes.rkt") + +(provide svg-dc%) + +(define dc-backend% + (class default-dc-backend% + (init [(init-w width)] + [(init-h height)] + [(init-output output)] + [exists 'error]) + + (unless (and (real? init-w) (not (negative? init-w))) + (raise-type-error (init-name 'svg-dc%) "nonnegative real or #f" init-w)) + (unless (and (real? init-h) (not (negative? init-h))) + (raise-type-error (init-name 'svg-dc%) "nonnegative real or #f" init-h)) + (unless (or (output-port? init-output) + (path-string? init-output)) + (raise-type-error (init-name 'svg-dc%) "path string or output port" init-output)) + (unless (memq exists '(error append update can-update + replace truncate + must-truncate truncate/replace)) + (raise-type-error (init-name 'svg-dc%) + "'error, 'append, 'update, 'can-update, 'replace, 'truncate, 'must-truncate, or 'truncate/replace" + exists)) + + (define width init-w) + (define height init-h) + (define close-port? (path-string? init-output)) + + (define port-box ; needs to be accessible as long as `s' or `c' + (let ([output (if (output-port? init-output) + init-output + (open-output-file init-output #:exists exists))]) + (make-immobile output))) + (define s (cairo_svg_surface_create_for_stream + write_port_bytes + port-box + width + height)) + + (define c (and s (cairo_create s))) + (when s (cairo_surface_destroy s)) + + (define/override (ok?) (and c #t)) + + (define/override (get-cr) c) + + (def/override (get-size) + (values width height)) + + (define/override (end-cr) + (cairo_surface_finish s) + (cairo_destroy c) + (set! c #f) + (set! s #f) + (when close-port? + (close-output-port (ptr-ref port-box _racket))) + (set! port-box #f)) + + (define/override (get-pango font) + (send font get-pango)) + + (define/override (get-font-metrics-key sx sy) + (if (and (= sx 1.0) (= sy 1.0)) + 3 + 0)) + + (define/override (can-combine-text? sz) + #t) + + (super-new))) + +(define svg-dc% (class (dc-mixin dc-backend%) + (super-new))) diff --git a/collects/racket/draw/private/write-bytes.rkt b/collects/racket/draw/private/write-bytes.rkt new file mode 100644 index 0000000000..9946b1673e --- /dev/null +++ b/collects/racket/draw/private/write-bytes.rkt @@ -0,0 +1,17 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/alloc + "../unsafe/cairo.ss" + "../unsafe/bstr.ss") + +(provide write_port_bytes + make-immobile) + +(define (write-port-bytes port-box bytes len) + (write-bytes (scheme_make_sized_byte_string bytes len 0) + (ptr-ref port-box _racket)) + CAIRO_STATUS_SUCCESS) + +(define write_port_bytes (function-ptr write-port-bytes _cairo_write_func_t)) + +(define make-immobile ((allocator free-immobile-cell) malloc-immobile-cell)) diff --git a/collects/racket/draw/unsafe/cairo.rkt b/collects/racket/draw/unsafe/cairo.rkt index 7be76da5ae..6682f4835b 100644 --- a/collects/racket/draw/unsafe/cairo.rkt +++ b/collects/racket/draw/unsafe/cairo.rkt @@ -243,6 +243,10 @@ ;; As above: (_fun _fpointer _pointer _double* _double* -> _cairo_surface_t) #:wrap (allocator cairo_surface_destroy)) +(define-cairo cairo_svg_surface_create_for_stream + ;; As above: + (_fun _fpointer _pointer _double* _double* -> _cairo_surface_t) + #:wrap (allocator cairo_surface_destroy)) (define/provide _cairo_write_func_t (_fun _pointer _pointer _uint -> _int)) (define-cairo cairo_ps_surface_set_eps (_fun _cairo_surface_t _bool -> _void) #:fail (lambda () diff --git a/collects/scribblings/draw/dc-intf.scrbl b/collects/scribblings/draw/dc-intf.scrbl index e59778bf08..260bccea0a 100644 --- a/collects/scribblings/draw/dc-intf.scrbl +++ b/collects/scribblings/draw/dc-intf.scrbl @@ -439,10 +439,10 @@ See also @method[dc<%> set-text-foreground], @method[dc<%> @defmethod[(end-doc) void?]{ -Ends a document, relevant only when drawing to a printer or PostScript - device (including to a PostScript file). +Ends a document, relevant only when drawing to a printer, PostScript, + PDF, or SVG device. -For printer or PostScript output, an exception is raised if +For relevant devices, an exception is raised if @scheme[end-doc] is called when the document is not started with @method[dc<%> start-doc], when a page is currently started by @method[dc<%> start-page] and not ended with @method[dc<%> end-page], @@ -454,10 +454,10 @@ or when the document has been ended already. @defmethod[(end-page) void?]{ -Ends a single page, relevant only when drawing to a printer or - PostScript device (including to a PostScript file). +Ends a single page, relevant only when drawing to a printer, + PostScript, PDF, or SVG device. -For printer or PostScript output, an exception is raised if +For relevant devices, an exception is raised if @scheme[end-page] is called when a page is not currently started by @method[dc<%> start-page].} @@ -1065,12 +1065,12 @@ get-transformation] for information about @racket[t].} @defmethod[(start-doc [message string?]) boolean?]{ -Starts a document, relevant only when drawing to a printer or - PostScript device (including to a PostScript file). For some +Starts a document, relevant only when drawing to a printer, + PostScript, PDF, or SVG device. For some platforms, the @scheme[message] string is displayed in a dialog until @method[dc<%> end-doc] is called. -For printer or PostScript output, an exception is raised if +For relevant devices, an exception is raised if @scheme[start-doc] has been called already (even if @method[dc<%> end-doc] has been called as well). Furthermore, drawing methods raise an exception if not called while a page is active as determined by @@ -1081,10 +1081,10 @@ For printer or PostScript output, an exception is raised if @defmethod[(start-page) void?]{ -Starts a page, relevant only when drawing to a printer or PostScript - device (including to a PostScript file). +Starts a page, relevant only when drawing to a printer, PostScript, + SVG, or PDF device. -For printer or PostScript output, an exception is raised if +Relevant devices, an exception is raised if @scheme[start-page] is called when a page is already started, or when @method[dc<%> start-doc] has not been called, or when @method[dc<%> end-doc] has been called already. In addition, in the case of diff --git a/collects/scribblings/draw/draw.scrbl b/collects/scribblings/draw/draw.scrbl index 81e967d2fe..ebd13ab02b 100644 --- a/collects/scribblings/draw/draw.scrbl +++ b/collects/scribblings/draw/draw.scrbl @@ -38,6 +38,7 @@ interface, and procedure bindings defined in this manual.} @include-section["ps-setup-class.scrbl"] @include-section["radial-gradient-class.scrbl"] @include-section["region-class.scrbl"] +@include-section["svg-dc-class.scrbl"] @include-section["draw-funcs.scrbl"] @include-section["draw-unit.scrbl"] diff --git a/collects/scribblings/draw/pdf-dc-class.scrbl b/collects/scribblings/draw/pdf-dc-class.scrbl index 5847b8b6d4..baae93850f 100644 --- a/collects/scribblings/draw/pdf-dc-class.scrbl +++ b/collects/scribblings/draw/pdf-dc-class.scrbl @@ -9,7 +9,10 @@ Like @racket[post-script-dc%], but generates a PDF file instead of a @defconstructor[([interactive any/c #t] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) false/c) #f] [use-paper-bbox any/c #f] - [as-eps any/c #t])]{ + [as-eps any/c #t] + [width (or/c (and/c real? (not/c negative?)) #f) #f] + [height (or/c (and/c real? (not/c negative?)) #f) #f] + [output (or/c path-string? output-port? #f) #f])]{ See @racket[post-script-dc%] for information on the arguments. The @racket[as-eps] argument is allowed for consistency with diff --git a/collects/scribblings/draw/svg-dc-class.scrbl b/collects/scribblings/draw/svg-dc-class.scrbl new file mode 100644 index 0000000000..08f9f57e08 --- /dev/null +++ b/collects/scribblings/draw/svg-dc-class.scrbl @@ -0,0 +1,26 @@ +#lang scribble/doc +@(require "common.ss") + +@defclass/title[svg-dc% object% (dc<%>)]{ + +Similar to @racket[post-script-dc%], but generates a SVG (scalable + vector graphics) file instead of a PostScript file. + +@defconstructor[([width (and/c real? (not/c negative?))] + [height (and/c real? (not/c negative?))] + [output (or/c path-string? output-port?)] + [exists (or/c 'error 'append 'update 'can-update + 'replace 'truncate + 'must-truncate 'truncate/replace) + 'error])]{ + +The @racket[width] and @racket[height] arguments determine the width + and height of the generated image. + +The image is written to @racket[output]. If @racket[output] is a path + and the file exists already, then @racket[exists] determines how + the existing file is handled in the same way as for the @racket[#:exists] + argument to @racket[open-output-file].} + +} + diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 3663cb7a44..01b0632923 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -203,9 +203,9 @@ [vp (make-object vertical-panel% f)] [hp0 (make-object horizontal-panel% vp)] [hp (make-object horizontal-panel% vp)] + [hp3 (make-object horizontal-panel% vp)] [hp2 hp] [hp2.5 hp0] - [hp3 hp] [hp4 (new horizontal-panel% [parent vp] [stretchable-height #f])] [bb (make-object bitmap% (sys-path "bb.gif") 'gif)] @@ -222,6 +222,7 @@ [use-bad? #f] [depth-one? #f] [cyan? #f] + [multi-page? #f] [smoothing 'unsmoothed] [save-filename #f] [save-file-format #f] @@ -995,6 +996,14 @@ (let ([dc (if kind (let ([dc (case kind [(print) (make-object printer-dc%)] + [(svg) + (let ([fn (put-file)]) + (and fn + (new svg-dc% + [width (* xscale DRAW-WIDTH)] + [height (* yscale DRAW-HEIGHT)] + [output fn] + [exists 'truncate])))] [(ps pdf) (let ([page? (eq? 'yes (message-box @@ -1178,7 +1187,12 @@ (send dc set-clipping-region #f) - (send dc end-page) + + (send dc end-page) + (when (and kind multi-page?) + (send dc start-page) + (send dc draw-text "Page 2" 0 0) + (send dc end-page)) (send dc end-doc))) (when save-filename @@ -1202,6 +1216,28 @@ (make-object button% "PDF" hp (lambda (self event) (send canvas on-paint 'pdf))) + (make-object button% "SVG" hp + (lambda (self event) + (send canvas on-paint 'svg))) + (make-object check-box% "Multiple Pages" hp + (lambda (self event) + (set! multi-page? (send self get-value)))) + (make-object button% "Save" hp + (lambda (b e) + (unless use-bitmap? + (error 'save-file "only available for pixmap/bitmap mode")) + (let ([f (put-file)]) + (when f + (let ([format + (cond + [(regexp-match "[.]xbm$" f) 'xbm] + [(regexp-match "[.]xpm$" f) 'xpm] + [(regexp-match "[.]jpe?g$" f) 'jpeg] + [(regexp-match "[.]png$" f) 'png] + [else (error 'save-file "unknown suffix: ~e" f)])]) + (set! save-filename f) + (set! save-file-format format) + (send canvas refresh)))))) (make-object choice% #f '("1" "*2" "/2" "1,*2" "*2,1") hp (lambda (self event) (send canvas set-scale @@ -1246,22 +1282,6 @@ (make-object check-box% "Kern" hp2.5 (lambda (self event) (send canvas set-kern (send self get-value)))) - (make-object button% "Save" hp0 - (lambda (b e) - (unless use-bitmap? - (error 'save-file "only available for pixmap/bitmap mode")) - (let ([f (put-file)]) - (when f - (let ([format - (cond - [(regexp-match "[.]xbm$" f) 'xbm] - [(regexp-match "[.]xpm$" f) 'xpm] - [(regexp-match "[.]jpe?g$" f) 'jpeg] - [(regexp-match "[.]png$" f) 'png] - [else (error 'save-file "unknown suffix: ~e" f)])]) - (set! save-filename f) - (set! save-file-format format) - (send canvas refresh)))))) (make-object choice% "Clip" '("None" "Rectangle" "Rectangle2" "Octagon" "Circle" "Wedge" "Round Rectangle" "Lambda" diff --git a/doc/release-notes/racket/Draw_and_GUI_5_1.txt b/doc/release-notes/racket/Draw_and_GUI_5_1.txt index a899d6a657..44c2dad22a 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_1.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_1.txt @@ -95,8 +95,8 @@ backward-compatibile. Methods like `get-translation', `set-translation', `scale', etc. help hide the reundancy. -PostScript and PDF Drawing Contexts ------------------------------------ +PostScript, PDF, and SVG Drawing Contexts +----------------------------------------- The dimensions for PostScript output are no longer inferred from the drawing. Instead, the width and height must be supplied when the @@ -105,6 +105,9 @@ drawing. Instead, the width and height must be supplied when the The new `pdf-dc%' drawing context is like `post-script-dc%', but it generates PDF output. +The new `svg-dc%' drawing context is similar to `post-script-dc%', +but it generates SVG output. + Other Drawing-Context Changes -----------------------------