suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add `svg-dc%'

Browse Source
This commit is contained in:
Matthew Flatt 2011-01-10 15:11:55 -07:00
parent b2877336f7
commit 6afffb329c
13 changed files with 199 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/mred/mred-sig.rkt
View File

@ -183,6 +183,7 @@ style-list%
style<%>
subarea<%>
subwindow<%>
svg-dc%
system-position-ok-before-cancel?
tab-snip%
text%

2
collects/racket/draw.rkt
View File

@ -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%

1
collects/racket/draw/draw-sig.rkt
View File

@ -27,6 +27,7 @@ post-script-dc%
ps-setup%
radial-gradient%
region%
svg-dc%
the-brush-list
the-color-database
the-font-list

14
collects/racket/draw/private/post-script-dc.rkt
View File

@ -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))

86
collects/racket/draw/private/svg-dc.rkt Normal file
View File

@ -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)))

17
collects/racket/draw/private/write-bytes.rkt Normal file
View File

@ -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))

4
collects/racket/draw/unsafe/cairo.rkt
View File

@ -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 ()

24
collects/scribblings/draw/dc-intf.scrbl
View File

@ -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

1
collects/scribblings/draw/draw.scrbl
View File

@ -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"]

5
collects/scribblings/draw/pdf-dc-class.scrbl
View File

@ -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

26
collects/scribblings/draw/svg-dc-class.scrbl Normal file
View File

@ -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].}
}

56
collects/tests/gracket/draw.rkt
View File

@ -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"

7
doc/release-notes/racket/Draw_and_GUI_5_1.txt
View File

@ -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
-----------------------------