postscript-dc% interactive and landscape
This commit is contained in:
Matthew Flatt
parent
b69d4322af
commit
16f15b0cad
|
|
@ -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?]
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
(init-cr-matrix)
|
||||
(define c (and s (cairo_create s)))
|
||||
|
||||
(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,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]
|
||||
|
|
@ -35,6 +35,16 @@
|
|||
(define scale-y 0.8)
|
||||
(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])
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user