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

add pdf-dc%; make slideshow/pict depend on racket/draw, not racket/gui

Browse Source
This commit is contained in:
Matthew Flatt 2010-11-26 10:25:37 -07:00
parent 7da127227a
commit 2edadd6113
27 changed files with 222 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -143,6 +143,7 @@ open-output-text-editor
pane%
panel%
pasteboard%
pdf-dc%
pen%
pen-list%
play-sound

1
collects/racket/draw.rkt
View File

@ -27,6 +27,7 @@
dc<%>
bitmap-dc%
post-script-dc%
pdf-dc%
ps-setup% current-ps-setup
get-face-list
get-family-builtin-face

32
collects/racket/draw/draw-sig.rkt Normal file
View File

@ -0,0 +1,32 @@
#lang racket/signature
bitmap%
bitmap-dc%
brush%
brush-list%
color%
color-database<%>
current-ps-setup
dc<%>
dc-path%
font%
font-list%
font-name-directory<%>
get-face-list
get-family-builtin-face
gl-config%
gl-context<%>
make-bitmap
make-monochrome-bitmap
pdf-dc%
pen%
pen-list%
point%
post-script-dc%
ps-setup%
region%
the-brush-list
the-color-database
the-font-list
the-font-name-directory
the-pen-list

8
collects/racket/draw/draw-unit.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang racket/base
(require racket/unit
racket/draw
"draw-sig.rkt")
(provide draw@)
(define-unit-from-context draw@ draw^)

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

@ -14,9 +14,10 @@
"local.ss"
"ps-setup.ss")
(provide post-script-dc%)
(provide post-script-dc%
pdf-dc%)
(define dc-backend%
(define (make-dc-backend pdf?)
(class default-dc-backend%
(init [interactive #t]
[parent #f]
@ -35,11 +36,13 @@
[to-file? (eq? (send pss get-mode) 'file)]
[get-file (lambda (fn)
((gui-dynamic-require 'put-file)
"Save PostScript As"
(if pdf?
"Save PDF As"
"Save PostScript As")
parent
(and fn (path-only fn))
(and fn (file-name-from-path fn))
"ps"))]
(if pdf? "pdf" "ps")))]
[fn (if to-file?
(if interactive
(get-file (send pss get-file))
@ -54,18 +57,26 @@
[h (caddr paper)]
[landscape? (eq? (send pss get-orientation) 'landscape)]
[file (open-output-file
(or fn (make-temporary-file "draw~a.ps"))
(or fn (make-temporary-file (if pdf?
"draw~a.pdf"
"draw~a.ps")))
#:exists 'truncate/replace)]
[port-box (make-immobile file)])
(values
(cairo_ps_surface_create_for_stream write_port_bytes
port-box
w
h)
port-box ; needs to be accessible as long as `s'
w
h
landscape?))))]
(let-values ([(w h) (if (and pdf? landscape?)
(values h w)
(values w h))])
(values
((if pdf?
cairo_pdf_surface_create_for_stream
cairo_ps_surface_create_for_stream)
write_port_bytes
port-box
w
h)
port-box ; needs to be accessible as long as `s'
w
h
landscape?)))))]
[else
(values #f #f #f #f)])))
@ -82,10 +93,11 @@
(send (current-ps-setup) get-translation xb yb)
(values (unbox xb) (unbox yb))))
(when (and s as-eps)
(cairo_ps_surface_set_eps s #t))
(when (and s landscape?)
(cairo_ps_surface_dsc_comment s "%%Orientation: Landscape"))
(unless pdf?
(when (and s as-eps)
(cairo_ps_surface_set_eps s #t))
(when (and s landscape?)
(cairo_ps_surface_dsc_comment s "%%Orientation: Landscape")))
(define c (and s (cairo_create s)))
@ -98,7 +110,7 @@
(def/override (get-size)
(let ([w (exact->inexact (/ (- width margin-x margin-x) scale-x))]
[h (exact->inexact (/ (- height margin-y margin-y) scale-y))])
(if landscape?
(if (and (not pdf?) landscape?)
(values h w)
(values w h))))
@ -112,7 +124,7 @@
(define/override (init-cr-matrix c)
(cairo_translate c trans-x trans-y)
(if landscape?
(if (and landscape? (not pdf?))
(begin
(cairo_translate c 0 height)
(cairo_rotate c (/ pi -2))
@ -138,7 +150,10 @@
(super-new)))
(define post-script-dc% (dc-mixin dc-backend%))
(define post-script-dc% (class (dc-mixin (make-dc-backend #f))
(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)

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

@ -201,6 +201,10 @@
;; allocation.
(_fun _fpointer _pointer _double* _double* -> _cairo_surface_t)
#:wrap (allocator cairo_surface_destroy))
(define-cairo cairo_pdf_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 ()

26
collects/scribblings/draw/draw-unit.scrbl Normal file
View File

@ -0,0 +1,26 @@
#lang scribble/doc
@(require "common.ss"
(for-label racket/draw/draw-unit
racket/draw/draw-sig))
@title{Signature and Unit}
The @racketmodname[racket/draw/draw-sig] and
@racketmodname[racket/draw/draw-unit] libraries define the
@racket[draw^] signature and @racket[draw@] implementation.
@section{Draw Unit}
@defmodule[racket/draw/draw-unit]
@defthing[draw@ unit?]{
Re-exports all of the exports of @racketmodname[racket/draw].}
@section{Draw Signature}
@defmodule[racket/draw/draw-sig]
@defsignature[draw^ ()]
Includes all of the identifiers exported by @racketmodname[racket/draw].

17
collects/scribblings/draw/pdf-dc-class.scrbl Normal file
View File

@ -0,0 +1,17 @@
#lang scribble/doc
@(require "common.ss")
@defclass/title[pdf-dc% object% (dc<%>)]{
Like @racket[post-script-dc%], but generates a PDF file instead of a
PostScript file.
@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])]{
See @racket[post-script-dc%] for information on the arguments. The
@racket[as-eps] argument is allowed for consistency with
@racket[post-script-dc%], but its value is ignored.}}

10
collects/scribblings/draw/pen-class.scrbl
View File

@ -95,17 +95,21 @@ A pen of size @scheme[0] uses the minimum line size for the
[style (one-of/c 'transparent 'solid 'xor 'hilite
'dot 'long-dash 'short-dash 'dot-dash
'xor-dot 'xor-long-dash 'xor-short-dash
'xor-dot-dash)])
'xor-dot-dash)]
[cap-style (one-of/c 'round 'projecting 'butt)]
[join-style (one-of/c 'round 'bevel 'miter)])
([color-name string?]
[width (real-in 0 255)]
[style (one-of/c 'transparent 'solid 'xor 'dot 'hilite
'long-dash 'short-dash 'dot-dash
'xor-dot 'xor-long-dash 'xor-short-dash
'xor-dot-dash)]))]{
'xor-dot-dash)]
[cap-style (one-of/c 'round 'projecting 'butt)]
[join-style (one-of/c 'round 'bevel 'miter)]))]{
When no argument are provided, the result is a solid black pen of
width @scheme[0]. Otherwise, the result is a pen with the given
color, width, and style. For the case that the color is specified
color, width, style, cap style, and join style. For the case that the color is specified
using a name, see @scheme[color-database<%>] for information about
color names; if the name is not known, the pen's color is black.

2
collects/scribblings/draw/post-script-dc-class.scrbl
View File

@ -5,7 +5,7 @@
A @scheme[post-script-dc%] object is a PostScript device context, that
can write PostScript files on any platform. See also
@scheme[ps-setup%].
@scheme[ps-setup%] and @racket[pdf-dc%].
@|PrintNote|

2
collects/scribblings/draw/reference.scrbl
View File

@ -18,6 +18,7 @@
@include-section["font-name-directory-intf.scrbl"]
@include-section["gl-config-class.scrbl"]
@include-section["gl-context-intf.scrbl"]
@include-section["pdf-dc-class.scrbl"]
@include-section["pen-class.scrbl"]
@include-section["pen-list-class.scrbl"]
@include-section["point-class.scrbl"]
@ -25,3 +26,4 @@
@include-section["ps-setup-class.scrbl"]
@include-section["region-class.scrbl"]
@include-section["draw-funcs.scrbl"]
@include-section["draw-unit.scrbl"]

64
collects/slideshow/cmdline.rkt
View File

@ -26,8 +26,7 @@
(define-values (use-screen-w use-screen-h) (values actual-screen-w actual-screen-h))
(define condense? #f)
(define printing? #f)
(define native-printing? #f)
(define printing-mode #f)
(define commentary? #f)
(define commentary-on-slide? #f)
(define show-gauge? #f)
@ -60,12 +59,13 @@
[once-each
(("-d" "--preview") "show next-slide preview (useful on a non-mirroring display)"
(set! two-frames? #t))
(("-p" "--print") "print (always to PostScript, except under Windows and Mac OS)"
(set! printing? #t)
(set! native-printing? #t))
(("-p" "--print") "print"
(set! printing-mode 'print))
(("-P" "--ps") "print to PostScript"
(set! printing? #t))
(("-o") file "set output file for PostScript printing"
(set! printing-mode 'ps))
(("-D" "--pdf") "print to PDF"
(set! printing-mode 'pdf))
(("-o") file "set output file for PostScript or PDF printing"
(set! print-target file))
(("-c" "--condense") "condense"
(set! condense? #t))
@ -138,40 +138,50 @@
(length slide-module-file)
slide-module-file)])]))
(when (or printing? condense?)
(define printing? (and printing-mode #t))
(when (or printing-mode condense?)
(set! use-transitions? #f))
(when printing?
(when printing-mode
(set! use-offscreen? #f)
(set! use-prefetch? #f)
(set! keep-titlebar? #t))
(dc-for-text-size
(if printing?
(if printing-mode
(let ([p (let ([pss (make-object ps-setup%)])
(send pss set-mode 'file)
(send pss set-file
(if print-target
print-target
(if file-to-load
(path-replace-suffix (file-name-from-path file-to-load)
(if quad-view?
"-4u.ps"
".ps"))
"untitled.ps")))
(let ([suffix
(if (eq? printing-mode 'pdf)
"pdf"
"ps")])
(if file-to-load
(path-replace-suffix (file-name-from-path file-to-load)
(format
(if quad-view?
"-4u.~a"
".~a")
suffix))
(format "untitled.~a" suffix)))))
(send pss set-orientation 'landscape)
(parameterize ([current-ps-setup pss])
(if native-printing?
;; Make printer-dc%
(begin
(when (can-get-page-setup-from-user?)
(let ([v (get-page-setup-from-user)])
(if v
(send pss copy-from v)
(exit))))
(make-object printer-dc% #f))
;; Make ps-dc%:
(make-object post-script-dc% (not print-target) #f #t #f))))])
(case printing-mode
[(print)
;; Make printer-dc%
(when (can-get-page-setup-from-user?)
(let ([v (get-page-setup-from-user)])
(if v
(send pss copy-from v)
(exit))))
(make-object printer-dc% #f)]
[(ps)
(make-object post-script-dc% (not print-target) #f #t #f)]
[(pdf)
(make-object pdf-dc% (not print-target) #f #t #f)])))])
;; Init page, set "screen" size, etc.:
(unless (send p ok?) (exit))
(send p start-doc "Slides")

4
collects/slideshow/core.rkt
View File

@ -3,7 +3,7 @@
(require scheme/class
scheme/unit
scheme/file
mred
racket/draw
texpict/mrpict
texpict/utils
scheme/math
@ -1019,7 +1019,7 @@
(+ x-space (* xs w)))
(>= (send scroll-bm get-height)
(+ y-space (* ys h))))
(set! scroll-bm (make-screen-bitmap
(set! scroll-bm (make-bitmap
(inexact->exact (ceiling (+ x-space (* xs w))))
(inexact->exact (ceiling (+ y-space (* ys h))))))
(if (send scroll-bm ok?)

4
collects/slideshow/pict.rkt
View File

@ -7,8 +7,8 @@
[pin-line t:pin-line]
[pin-arrow-line t:pin-arrow-line]
[pin-arrows-line t:pin-arrows-line])
(only-in scheme/gui/base dc-path%)
(only-in scheme/class new send))
(only-in racket/draw dc-path%)
(only-in racket/class new send))
(define (hline w h #:segment [seg #f])
(if seg

4
collects/slideshow/slides-to-picts.rkt
View File

@ -1,6 +1,6 @@
(module slides-to-picts scheme/base
(require mred
(require racket/draw
scheme/class
scheme/unit
"sig.ss"
@ -14,7 +14,7 @@
(define get-slides-as-picts
(lambda (file w h c? [stop-after #f])
(let ([ns (make-gui-namespace)]
(let ([ns (make-base-namespace)]
[orig-ns (namespace-anchor->empty-namespace anchor)]
[slides null]
[xs (/ w 1024)]

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

@ -263,7 +263,7 @@
[on-paint
(case-lambda
[() (time (on-paint #f))]
[(ps?)
[(kind)
(let* ([can-dc (get-dc)]
[pen0s (make-object pen% "BLACK" 0 'solid)]
[pen1s (make-object pen% "BLACK" 1 'solid)]
@ -811,7 +811,7 @@
(send dc draw-rectangle 180 205 20 20)
(send dc set-brush brushs))))
(when (and pixel-copy? last? (not (or ps? (eq? dc can-dc))))
(when (and pixel-copy? last? (not (or kind (eq? dc can-dc))))
(let* ([x 100]
[y 170]
[x2 245] [y2 188]
@ -941,7 +941,7 @@
(send dc draw-rectangle 187 310 20 20)
(send dc set-pen p)))
(when (and last? (not (or ps? (eq? dc can-dc)))
(when (and last? (not (or kind (eq? dc can-dc)))
(send mem-dc get-bitmap))
(send can-dc draw-bitmap (send mem-dc get-bitmap) 0 0 'opaque)))
@ -950,10 +950,11 @@
(send (get-dc) set-scale 1 1)
(send (get-dc) set-origin 0 0)
(let ([dc (if ps?
(let ([dc (if (eq? ps? 'print)
(make-object printer-dc%)
(make-object post-script-dc%))])
(let ([dc (if kind
(let ([dc (case kind
[(print) (make-object printer-dc%)]
[(ps) (make-object post-script-dc%)]
[(pdf) (make-object pdf-dc%)])])
(and (send dc ok?) dc))
(if (and use-bitmap?)
(begin
@ -1112,7 +1113,7 @@
(let-values ([(w h) (send dc get-size)])
(unless (cond
[ps? #t]
[kind #t]
[use-bad? #t]
[use-bitmap? (and (= w (* xscale DRAW-WIDTH)) (= h (* yscale DRAW-HEIGHT)))]
[else (and (= w (* 2 DRAW-WIDTH)) (= h (* 2 DRAW-HEIGHT)))])
@ -1143,10 +1144,10 @@
'(horizontal))
(make-object button% "PS" hp
(lambda (self event)
(send canvas on-paint #t)))
(make-object button% "Print" hp
(send canvas on-paint 'ps)))
(make-object button% "PDF" hp
(lambda (self event)
(send canvas on-paint 'print)))
(send canvas on-paint 'pdf)))
(make-object choice% #f '("1" "*2" "/2" "1,*2" "*2,1") hp
(lambda (self event)
(send canvas set-scale
@ -1243,6 +1244,7 @@
(send canvas refresh))))])
(set! do-clock clock)
(make-object button% "Clip Clock" hp3 (lambda (b e) (clock #t)))
(make-object button% "Print" hp4 (lambda (self event) (send canvas on-paint 'print)))
(make-object button% "Print Setup" hp4 (lambda (b e) (let ([c (get-page-setup-from-user)])
(when c
(send (current-ps-setup) copy-from c)))))

2
collects/texpict/balloon.rkt
View File

@ -1,7 +1,7 @@
(module balloon mzscheme
(require "mrpict.ss"
"utils.ss"
mred
racket/draw
mzlib/class
mzlib/etc
mzlib/math)

2
collects/texpict/code.rkt
View File

@ -4,7 +4,7 @@
mzlib/class
mzlib/list
(only scheme/list last)
mred
racket/draw
mzlib/unit)
(provide define-code code^ code-params^ code@)

2
collects/texpict/doc.txt
View File

@ -67,7 +67,7 @@ GRacket (or PostScript) output
The GRacket texpict function set is loaded by the _mrpict.ss_ library.
The library is available in unit form via _mrpict-unit.ss_, which
exports a `mrpict@' unit that imports mred^ and exports
exports a `mrpict@' unit that imports draw^ and exports
`texpict-common^' and `mrpict-extra^'. The _mrpict-sig.ss_ library
file provides both signatures.

2
collects/texpict/face.rkt
View File

@ -1,5 +1,5 @@
(module face mzscheme
(require mred
(require racket/draw
texpict/mrpict
texpict/utils
mzlib/class

2
collects/texpict/flash.rkt
View File

@ -3,7 +3,7 @@
(require "mrpict.ss"
mzlib/math
mzlib/etc
mred
racket/draw
mzlib/class)
(provide filled-flash

4
collects/texpict/mrpict-unit.rkt
View File

@ -2,7 +2,7 @@
(module mrpict-unit mzscheme
(require mzlib/unit)
(require mred/mred-sig)
(require racket/draw/draw-sig)
(require "private/mrpict-sig.ss"
"private/common-sig.ss"
@ -11,6 +11,6 @@
(provide mrpict@)
(define-compound-unit/infer mrpict@
(import mred^)
(import draw^)
(export texpict-common^ mrpict-extra^)
(link common@ mrpict-extra@)))

8
collects/texpict/mrpict.rkt
View File

@ -3,10 +3,10 @@
(require mzlib/unit
mzlib/contract
mzlib/class
mred)
racket/draw)
(require mred/mred-sig
mred/mred-unit)
(require racket/draw/draw-sig
racket/draw/draw-unit)
(require "private/mrpict-sig.ss"
"private/common-sig.ss")
(require "mrpict-sig.ss"
@ -15,7 +15,7 @@
(define-compound-unit/infer mrpict+mred@
(import)
(export texpict-common^ mrpict-extra^)
(link standard-mred@ mrpict@))
(link draw@ mrpict@))
(define-values/invoke-unit/infer mrpict+mred@)

2
collects/texpict/private/common-unit.rkt
View File

@ -1,6 +1,6 @@
#lang racket/unit
(require racket/gui/base
(require racket/draw
racket/class
racket/list)

9
collects/texpict/private/mrpict-extra.rkt
View File

@ -4,12 +4,13 @@
(require mzlib/class
mzlib/etc)
(require mred/mred-sig)
(require racket/draw/draw-sig
racket/gui/dynamic)
(require "mrpict-sig.ss"
"common-sig.ss")
(import mred^
(import draw^
texpict-common^
texpict-internal^)
(export mrpict-extra^
@ -21,7 +22,7 @@
(define pict-drawer (make-pict-drawer the-pict))
(define no-redraw? #f)
(define pict-frame%
(class frame%
(class (gui-dynamic-require 'frame%)
(define/public (set-pict p)
(set! the-pict p)
(set! pict-drawer (make-pict-drawer the-pict))
@ -34,7 +35,7 @@
(send c on-paint))
(super-instantiate ())))
(define pict-canvas%
(class canvas%
(class (gui-dynamic-require 'canvas%)
(inherit get-dc)
(define/override (on-paint)
(unless no-redraw?

15
collects/texpict/utils.rkt
View File

@ -1,6 +1,11 @@
#lang scheme/gui
#lang racket/base
(require "mrpict.ss")
(require racket/contract
racket/class
racket/draw
racket/math
racket/gui/dynamic
"mrpict.ss")
;; Utilities for use with mrpict
@ -886,8 +891,10 @@
(let ([bm (cond
[(bitmap-draft-mode) #f]
[(filename . is-a? . bitmap%) filename]
[(filename . is-a? . image-snip%) (send filename get-bitmap)]
[else (make-object bitmap% filename 'unknown/mask)])])
[(path-string? filename) (make-object bitmap% filename 'unknown/mask)]
[(and (gui-available?)
(filename . is-a? . (gui-dynamic-require 'image-snip%)))
(send filename get-bitmap)])])
(if (and bm (send bm ok?))
(let ([w (send bm get-width)]
[h (send bm get-height)])

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

@ -112,6 +112,9 @@ that it is installed as a clipping region.
The old 'xor mode for pens and brushes is no longer available (since
it is not supported by Cairo).
The new `pdf-dc%' drawing context is like `post-script-dc%', but it
generates PDF output.
Editor Changes
--------------