From 16f15b0cad7e3edafe06119c71660e6254f2b1b5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 3 Aug 2010 16:37:49 -0600 Subject: [PATCH] postscript-dc% interactive and landscape --- collects/mred/private/filedialog.rkt | 4 +- collects/mred/private/wx/cocoa/item.rkt | 4 +- collects/racket/draw/cairo.rkt | 2 + collects/racket/draw/dc.rkt | 11 +-- collects/racket/draw/post-script-dc.rkt | 93 ++++++++++++++----- collects/racket/draw/ps-setup.rkt | 14 ++- collects/scribblings/gui/ps-setup-class.scrbl | 6 +- 7 files changed, 98 insertions(+), 36 deletions(-) diff --git a/collects/mred/private/filedialog.rkt b/collects/mred/private/filedialog.rkt index a3d06564df..9babd0879e 100644 --- a/collects/mred/private/filedialog.rkt +++ b/collects/mred/private/filedialog.rkt @@ -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?] diff --git a/collects/mred/private/wx/cocoa/item.rkt b/collects/mred/private/wx/cocoa/item.rkt index 54c3d34cdc..571295bf04 100644 --- a/collects/mred/private/wx/cocoa/item.rkt +++ b/collects/mred/private/wx/cocoa/item.rkt @@ -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)) diff --git a/collects/racket/draw/cairo.rkt b/collects/racket/draw/cairo.rkt index 50b955397c..faa4d08bf9 100644 --- a/collects/racket/draw/cairo.rkt +++ b/collects/racket/draw/cairo.rkt @@ -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) diff --git a/collects/racket/draw/dc.rkt b/collects/racket/draw/dc.rkt index 525575ea65..f9ac887fb5 100644 --- a/collects/racket/draw/dc.rkt +++ b/collects/racket/draw/dc.rkt @@ -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))) diff --git a/collects/racket/draw/post-script-dc.rkt b/collects/racket/draw/post-script-dc.rkt index 4856660d85..ec7609faeb 100644 --- a/collects/racket/draw/post-script-dc.rkt +++ b/collects/racket/draw/post-script-dc.rkt @@ -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%)) diff --git a/collects/racket/draw/ps-setup.rkt b/collects/racket/draw/ps-setup.rkt index 5b1b65e9ae..4d75931b74 100644 --- a/collects/racket/draw/ps-setup.rkt +++ b/collects/racket/draw/ps-setup.rkt @@ -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]) diff --git a/collects/scribblings/gui/ps-setup-class.scrbl b/collects/scribblings/gui/ps-setup-class.scrbl index fd0f49b9a4..6f98a77657 100644 --- a/collects/scribblings/gui/ps-setup-class.scrbl +++ b/collects/scribblings/gui/ps-setup-class.scrbl @@ -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. }