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

postscript-dc% interactive and landscape

Browse Source
This commit is contained in:
Matthew Flatt 2010-08-03 16:37:49 -06:00
parent b69d4322af
commit 16f15b0cad
7 changed files with 98 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/mred/private/filedialog.rkt
View File

@ -52,7 +52,9 @@
(raise-type-error who "list of 2-string lists" filters))
(let* ([std? (memq 'common style)]
[style (if std? (remq 'common style) style)])
(if (or std? (eq? (system-type) 'unix))
(if (or std?
#t ; for now, always use the manually constructed dialog
(eq? (system-type) 'unix))
(send (new path-dialog%
[put? put?]
[dir? dir?]

4
collects/mred/private/wx/cocoa/item.rkt
View File

@ -27,12 +27,12 @@
(define/public (get-cocoa-control) (get-cocoa))
(define/override (enable on?)
(tellv (get-cocoa) setEnabled: #:type _BOOL on?))
(tellv (get-cocoa-control) setEnabled: #:type _BOOL on?))
(define/override (is-window-enabled?)
(tell #:type _BOOL (get-cocoa-control) isEnabled))
(define/override (gets-focus?)
(tell #:type _BOOL (get-cocoa) canBecomeKeyView))
(tell #:type _BOOL (get-cocoa-control) canBecomeKeyView))
(define/public (command e)
(callback this e))

2
collects/racket/draw/cairo.rkt
View File

@ -168,6 +168,8 @@
(define-cairo cairo_ps_surface_create (_fun _path _double* _double* -> _cairo_surface_t)
#:wrap (allocator cairo_surface_destroy))
(define-cairo cairo_ps_surface_set_eps (_fun _cairo_surface_t _bool -> _void))
(define-cairo cairo_ps_surface_dsc_begin_setup (_fun _cairo_surface_t -> _void))
(define-cairo cairo_ps_surface_dsc_comment (_fun _cairo_surface_t _string -> _void))
(define-cairo cairo_image_surface_get_data (_fun (s : _cairo_surface_t)
-> (_bytes o
(* (cairo_image_surface_get_height s)

11
collects/racket/draw/dc.rkt
View File

@ -325,13 +325,10 @@
(define/private (do-reset-matrix cr)
(if (and (zero? scroll-dx)
(zero? scroll-dy))
(cairo_set_matrix cr matrix)
(begin
(cairo_identity_matrix cr)
(cairo_translate cr scroll-dx scroll-dy)
(cairo_transform cr matrix)))
(cairo_identity_matrix cr)
(init-cr-matrix cr)
(cairo_translate cr scroll-dx scroll-dy)
(cairo_transform cr matrix)
(cairo_translate cr origin-x origin-y)
(cairo_scale cr scale-x scale-y)
(cairo_rotate cr (- rotation)))

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

@ -1,7 +1,10 @@
#lang scheme/base
(require scheme/class
scheme/file
racket/path
racket/math
mred/private/syntax
racket/gui/dynamic
"cairo.ss"
"dc.ss"
"font.ss"
@ -17,6 +20,47 @@
[use-paper-bbox #f]
[as-eps #t])
(define-values (s width height landscape?)
(let ([su (if interactive
((gui-dynamic-require 'get-ps-setup-from-user))
(current-ps-setup))])
(cond
[su
(unless (eq? su (current-ps-setup))
(send (current-ps-setup) copy-from su))
(let* ([pss (current-ps-setup)]
[to-file? (eq? (send pss get-mode) 'file)]
[get-file (lambda (fn)
((gui-dynamic-require 'put-file)
"Save PostScript As"
#f
(and fn (path-only fn))
(and fn (file-name-from-path fn))
"ps"))]
[fn (if to-file?
(if interactive
(get-file (send pss get-file))
(let ([fn (send pss get-file)])
(or fn (get-file #f))))
#f)])
(if (and to-file?
(not fn))
(values #f #f #f #f)
(let* ([paper (assoc (send pss get-paper-name) paper-sizes)]
[w (cadr paper)]
[h (caddr paper)]
[landscape? (eq? (send pss get-orientation) 'landscape)])
(values
(cairo_ps_surface_create (or fn
(make-temporary-file "draw~a.ps"))
w
h)
w
h
landscape?))))]
[else
(values #f #f #f #f)])))
(define-values (margin-x margin-y)
(let ([xb (box 0)] [yb (box 0.0)])
(send (current-ps-setup) get-margin xb yb)
@ -25,30 +69,28 @@
(let ([xb (box 0)] [yb (box 0.0)])
(send (current-ps-setup) get-scaling xb yb)
(values (unbox xb) (unbox yb))))
(define-values (trans-x trans-y)
(let ([xb (box 0)] [yb (box 0.0)])
(send (current-ps-setup) get-translation xb yb)
(values (unbox xb) (unbox yb))))
(define-values (s width height)
(let* ([pss (current-ps-setup)]
[paper (assoc (send pss get-paper-name) paper-sizes)])
(values
(cairo_ps_surface_create (or (send pss get-filename)
(make-temporary-file "draw~a.ps"))
(cadr paper)
(caddr paper))
(cadr paper)
(caddr paper))))
(when as-eps
(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 (cairo_create s))
(cairo_surface_destroy s)
(define c (and s (cairo_create s)))
(init-cr-matrix)
(when s (cairo_surface_destroy s))
(define/override (get-cr) c)
(def/override (get-size)
(values (exact->inexact width)
(exact->inexact height)))
(let ([w (exact->inexact (/ (- width margin-x margin-x) scale-x))]
[h (exact->inexact (/ (- height margin-y margin-y) scale-y))])
(if landscape?
(values h w)
(values w h))))
(define/override (end-cr)
(cairo_surface_finish s)
@ -56,9 +98,17 @@
(set! c #f)
(set! s #f))
(define/override (init-cr-matrix)
(cairo_translate c margin-x margin-y)
(cairo_scale c scale-x scale-y))
(define/override (init-cr-matrix c)
(cairo_translate c trans-x trans-y)
(if landscape?
(begin
(cairo_translate c 0 height)
(cairo_rotate c (/ pi -2))
(cairo_translate c margin-y margin-x)
(cairo_scale c scale-y scale-x))
(begin
(cairo_translate c margin-x margin-y)
(cairo_scale c scale-x scale-y))))
(define/override (get-pango font)
(send font get-ps-pango))
@ -70,5 +120,4 @@
(super-new)))
(define post-script-dc%
(dc-mixin dc-backend%))
(define post-script-dc% (dc-mixin dc-backend%))

14
collects/racket/draw/ps-setup.rkt
View File

@ -14,13 +14,13 @@
(define (paper-name-string? s)
(and (string? s)
(assoc paper-sizes s)))
(assoc s paper-sizes)))
(define ps-setup%
(class object%
(properties
[[string? command] "lpr"]
[[(make-or-false path-string?) filename] #f]
[[(make-or-false path-string?) file] #f]
[[bool? level-2] #t]
[[(symbol-in preview file printer) mode] 'file]
[[(symbol-in portrait landscape) orientation] 'portrait]
@ -36,6 +36,16 @@
(define trans-x 0.0)
(define trans-y 0.0)
(def/public (copy-from [ps-setup% source]
[any? [filename? #f]])
(set! command (send source get-command))
(when filename? (set! file (send source get-file)))
(set! level-2 (send source get-level-2))
(set! mode (send source get-mode))
(set! orientation (send source get-orientation))
(set! paper-name (send source get-paper-name))
(set! preview-command (send source get-preview-command)))
(def/public (get-editor-margin [(make-box nonnegative-real?) x]
[(make-box nonnegative-real?) y])
(set-box! x editor-margin-x)

6
collects/scribblings/gui/ps-setup-class.scrbl
View File

@ -22,10 +22,12 @@ Creates a new @scheme[ps-setup%] object with the (platform-specific)
}
@defmethod[(copy-from [source (is-a?/c ps-setup%)])
@defmethod[(copy-from [source (is-a?/c ps-setup%)]
[copy-filename? any/c #f])
void?]{
Copies the settings @scheme[copy-from] to @this-obj[].
Copies the settings @scheme[copy-from] to @this-obj[], excluding the
filename unless @racket[copy-filename?] is true.
}