From b4fafc1888795b4e6be8072db4cb7e81fa1395a6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 14 Oct 2010 16:43:41 -0600 Subject: [PATCH] cocoa: printer-dc% --- collects/mred/private/wx/cocoa/cg.rkt | 1 + collects/mred/private/wx/cocoa/printer-dc.rkt | 170 ++++++++++++- collects/mred/private/wx/cocoa/procs.rkt | 7 +- collects/mred/private/wx/common/printer.rkt | 25 ++ collects/racket/draw/dc.rkt | 20 +- collects/racket/draw/ps-setup.rkt | 36 ++- collects/racket/draw/record-dc.rkt | 232 ++++++++++++++++++ collects/racket/draw/region.rkt | 2 + collects/tests/gracket/draw.rkt | 3 + 9 files changed, 477 insertions(+), 19 deletions(-) create mode 100644 collects/mred/private/wx/common/printer.rkt create mode 100644 collects/racket/draw/record-dc.rkt diff --git a/collects/mred/private/wx/cocoa/cg.rkt b/collects/mred/private/wx/cocoa/cg.rkt index 95bd5da5fd..479a9dcd08 100644 --- a/collects/mred/private/wx/cocoa/cg.rkt +++ b/collects/mred/private/wx/cocoa/cg.rkt @@ -11,6 +11,7 @@ (define-appserv CGContextFlush (_fun _CGContextRef -> _void)) (define-appserv CGContextTranslateCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) (define-appserv CGContextScaleCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) +(define-appserv CGContextRotateCTM (_fun _CGContextRef _CGFloat -> _void)) (define-appserv CGContextSaveGState (_fun _CGContextRef -> _void)) (define-appserv CGContextRestoreGState (_fun _CGContextRef -> _void)) (define-appserv CGContextSetRGBFillColor (_fun _CGContextRef _CGFloat _CGFloat _CGFloat _CGFloat -> _void)) diff --git a/collects/mred/private/wx/cocoa/printer-dc.rkt b/collects/mred/private/wx/cocoa/printer-dc.rkt index 38819ef7bb..b56a5aec0e 100644 --- a/collects/mred/private/wx/cocoa/printer-dc.rkt +++ b/collects/mred/private/wx/cocoa/printer-dc.rkt @@ -1,14 +1,168 @@ #lang racket/base (require racket/class - racket/draw/dc) + racket/math + racket/draw/local + racket/draw/dc + racket/draw/cairo + racket/draw/bitmap + racket/draw/bitmap-dc + racket/draw/record-dc + racket/draw/ps-setup + ffi/unsafe + ffi/unsafe/objc + "dc.rkt" + "cg.rkt" + "utils.rkt" + "types.rkt") -(provide printer-dc%) +(provide printer-dc% + show-print-setup) -(define dc-backend% - (class default-dc-backend% - (init [parent #f]) - - (super-new))) +(import-class NSPrintOperation NSView NSGraphicsContext + NSPrintInfo NSDictionary NSPageLayout) + +(define NSPortraitOrientation 0) +(define NSLandscapeOrientation 1) + +(define-objc-class PrinterView NSView + [wxb] + [-a _BOOL (knowsPageRange: [_NSRange-pointer rng]) + (set-NSRange-location! rng 1) + (set-NSRange-length! rng (let ([wx (->wx wxb)]) + (if wx + (send wx get-page-count) + 0))) + #t] + [-a _NSRect (rectForPage: [_NSInteger n]) + (let ([wx (->wx wxb)]) + (if wx + (send wx get-rect-for-page n) + (make-NSRect (make-NSPoint 0 0) + (make-NSSize 10 10))))] + [-a _void (beginPageInRect: [_NSRect aRect] atPlacement: [_NSPoint location]) + (let ([wx (->wx wxb)]) + (when wx + (send wx start-page-at aRect))) + (super-tell #:type _void beginPageInRect: #:type _NSRect aRect atPlacement: #:type _NSPoint location)] + [-a _void (drawPageBorderWithSize: [_NSSize size]) + (let ([wx (->wx wxb)]) + (when wx + (send wx draw-print-page self size)))]) + +(define (make-print-info [prev #f]) + (as-objc-allocation-with-retain + (tell (tell NSPrintInfo alloc) + initWithDictionary: + (if prev + (tell prev dictionary) + (tell NSDictionary dictionary))))) + + +(define (install-pss-to-print-info pss print-info) + (tellv print-info setOrientation: #:type _int (if (eq? (send pss get-orientation) 'landscape) + NSLandscapeOrientation + NSPortraitOrientation)) + (tellv print-info setScalingFactor: #:type _CGFloat (let ([x (box 0)] + [y (box 0)]) + (send pss get-scaling x y) + (unbox y)))) + +(define (show-print-setup parent) + (let* ([pss (current-ps-setup)] + [print-info (let ([pi (send pss get-native)]) + (or pi + (let ([pi (make-print-info)]) + (send pss set-native pi make-print-info) + pi)))]) + (install-pss-to-print-info pss print-info) + (tell (tell NSPageLayout pageLayout) runModalWithPrintInfo: print-info) + (let ([o (tell #:type _int print-info orientation)]) + (send pss set-orientation (if (= o NSLandscapeOrientation) + 'landscape + 'portrait))) + (let ([s (tell #:type _CGFloat print-info scalingFactor)]) + (send pss set-scaling s s)))) (define printer-dc% - (dc-mixin dc-backend%)) + (class (record-dc-mixin (dc-mixin bitmap-dc-backend%)) + (init [parent #f]) + + (super-make-object (make-object quartz-bitmap% 1 1)) + + (inherit get-recorded-command + reset-recording) + + (define pages null) + (define/override (end-page) + (set! pages (cons (get-recorded-command) pages)) + (reset-recording)) + + (define print-info (or (let-values ([(pi copier) + (send (current-ps-setup) + get-native-copy)]) + pi) + (make-print-info))) + + (install-pss-to-print-info (current-ps-setup) print-info) + + (define-values (page-width page-height page-scaling) + (let ([s (NSRect-size (tell #:type _NSRect print-info imageablePageBounds))] + [scaling (tell #:type _CGFloat print-info scalingFactor)]) + (values (NSSize-width s) + (NSSize-height s) + scaling))) + + (define/override (get-size) + (values (/ page-width page-scaling) (/ page-height page-scaling))) + + (define current-page 0) + + (define/public (get-page-count) (length pages)) + (define/public (get-rect-for-page i) + (make-NSRect (make-NSPoint 0 (* (sub1 i) page-height)) + (make-NSSize page-width page-height))) + (define/public (start-page-at r) + (set! current-page (inexact->exact (round (/ (NSPoint-y (NSRect-origin r)) page-height))))) + (define/public (draw-print-page view-cocoa s) + (let ([f (tell #:type _NSRect view-cocoa frame)]) + (tellv view-cocoa lockFocus) + + (let ([cg (tell #:type _CGContextRef (tell NSGraphicsContext currentContext) graphicsPort)] + [s (tell #:type _NSSize print-info paperSize)] + [b (tell #:type _NSRect print-info imageablePageBounds)]) + (CGContextTranslateCTM cg 0 (/ (NSSize-height s) page-scaling)) + (CGContextScaleCTM cg 1 -1) + (CGContextTranslateCTM cg + (/ (NSPoint-x (NSRect-origin b)) page-scaling) + (/ (- (NSSize-height s) + (+ (NSPoint-y (NSRect-origin b)) + (NSSize-height (NSRect-size b)))) + page-scaling)) + (let* ([surface (cairo_quartz_surface_create_for_cg_context cg + (inexact->exact (ceiling page-width)) + (inexact->exact (ceiling page-height)))] + [cr (cairo_create surface)]) + (cairo_surface_destroy surface) + (let ([dc (make-object (dc-mixin + (class default-dc-backend% + (define/override (get-cr) cr) + (super-new))))]) + (let ([proc (list-ref (reverse pages) current-page)]) + (proc dc))) + (cairo_destroy cr))) + + (tellv view-cocoa unlockFocus))) + + (define/override (end-doc) + (define view-cocoa (as-objc-allocation-with-retain + (tell (tell PrinterView alloc) + initWithFrame: #:type _NSRect (make-NSRect + (make-NSPoint 0 0) + (make-NSSize 10 10))))) + (define op-cocoa (as-objc-allocation-with-retain + (tell NSPrintOperation printOperationWithView: view-cocoa + printInfo: print-info))) + + (set-ivar! view-cocoa wxb (->wxb this)) + + (tellv op-cocoa runOperation)))) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index cf31e6e02d..fc270957b9 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -11,6 +11,8 @@ "finfo.rkt" ; file-creator-and-type "filedialog.rkt" "dc.rkt" + "printer-dc.rkt" + "../common/printer.rkt" "menu-bar.rkt" "agl.rkt" "../../lock.rkt" @@ -72,7 +74,9 @@ (define-unimplemented send-event) (define (begin-refresh-sequence) (void)) (define (end-refresh-sequence) (void)) -(define-unimplemented run-printout) + +(define run-printout (make-run-printout printer-dc%)) + (define (get-double-click-time) 500) (define (get-control-font-size) 13) @@ -108,7 +112,6 @@ (define (get-display-depth) 32) (define-unimplemented is-color-display?) (define (id-to-menu-item id) id) -(define-unimplemented show-print-setup) (define (can-show-print-setup?) #t) (define/top (make-screen-bitmap [exact-positive-integer? w] diff --git a/collects/mred/private/wx/common/printer.rkt b/collects/mred/private/wx/common/printer.rkt new file mode 100644 index 0000000000..7f360a4647 --- /dev/null +++ b/collects/mred/private/wx/common/printer.rkt @@ -0,0 +1,25 @@ +#lang racket/base +(require racket/class) + +(provide make-run-printout) + +(define ((make-run-printout printer-dc%) + parent + interactive? ; currently ignored + fit-to-page? ; ignored + begin-doc-proc + has-page?-proc + print-page-proc + end-doc-proc) + (let ([dc (make-object printer-dc% parent)]) + (send dc start-doc "printing") + (begin-doc-proc dc) + (let loop ([i 1]) + (when (has-page?-proc dc i) + (begin + (send dc start-page) + (print-page-proc dc i) + (send dc end-page) + (loop (add1 i))))) + (end-doc-proc) + (send dc end-doc))) diff --git a/collects/racket/draw/dc.rkt b/collects/racket/draw/dc.rkt index 306f88009a..0418087b41 100644 --- a/collects/racket/draw/dc.rkt +++ b/collects/racket/draw/dc.rkt @@ -26,7 +26,13 @@ (provide dc-mixin dc-backend<%> default-dc-backend% - install-bitmap-dc-class!) + install-bitmap-dc-class! + do-set-pen! + do-set-brush!) + +(define-local-member-name + do-set-pen! + do-set-brush!) (define 2pi (* 2 pi)) @@ -505,7 +511,7 @@ (def/public (set-alpha [(real-in 0.0 1.0) n]) (set! alpha n)) - (define/private (set-pen! p) + (define/public (do-set-pen! p) (set! pen-stipple-s #f) (let ([o pen]) (send p adjust-lock 1) @@ -515,11 +521,11 @@ (define/public (set-pen . args) (case-args args - [([pen% p]) (set-pen! p) (reset-align!)] + [([pen% p]) (do-set-pen! p) (reset-align!)] [([(make-alts string? color%) col] [pen-width? width] [pen-style-symbol? style]) - (set-pen! (send the-pen-list find-or-create-pen col width style)) + (do-set-pen! (send the-pen-list find-or-create-pen col width style)) (reset-align!)] (method-name 'dc% 'set-pen))) @@ -528,7 +534,7 @@ (define/private (pen-draws?) (not (eq? (send pen get-style) 'transparent))) - (define/private (set-brush! b) + (define/public (do-set-brush! b) (set! brush-stipple-s #f) (let ([o brush]) (send b adjust-lock 1) @@ -538,10 +544,10 @@ (define/public (set-brush . args) (case-args args - [([brush% b]) (set-brush! b)] + [([brush% b]) (do-set-brush! b)] [([(make-alts string? color%) col] [brush-style-symbol? style]) - (set-brush! (send the-brush-list find-or-create-brush col style))] + (do-set-brush! (send the-brush-list find-or-create-brush col style))] (method-name 'dc% 'set-brush))) (define/public (get-brush) brush) diff --git a/collects/racket/draw/ps-setup.rkt b/collects/racket/draw/ps-setup.rkt index 4d75931b74..87d13bdec8 100644 --- a/collects/racket/draw/ps-setup.rkt +++ b/collects/racket/draw/ps-setup.rkt @@ -4,7 +4,17 @@ (provide ps-setup% current-ps-setup - paper-sizes) + paper-sizes + + get-native + get-native-copy + set-native) + +(define-local-member-name + get-native + get-native-copy + set-native + get-all-numerics) (define paper-sizes '(("A4 210 x 297\n mm" 595 842) @@ -36,6 +46,16 @@ (define trans-x 0.0) (define trans-y 0.0) + (define native #f) + (define native-copier #f) + (define/public (get-native) native) + (define/public (get-native-copy) + (values (and native (native-copier native)) + native-copier)) + (define/public (set-native n copier) + (set! native n) + (set! native-copier copier)) + (def/public (copy-from [ps-setup% source] [any? [filename? #f]]) (set! command (send source get-command)) @@ -44,7 +64,19 @@ (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))) + (set! preview-command (send source get-preview-command)) + (set!-values (native native-copier) (send source get-native-copy)) + (set!-values (editor-margin-x editor-margin-y + margin-x margin-y + scale-x scale-y + trans-x trans-y) + (send source get-all-numerics))) + + (define/public (get-all-numerics) + (values editor-margin-x editor-margin-y + margin-x margin-y + scale-x scale-y + trans-x trans-y)) (def/public (get-editor-margin [(make-box nonnegative-real?) x] [(make-box nonnegative-real?) y]) diff --git a/collects/racket/draw/record-dc.rkt b/collects/racket/draw/record-dc.rkt new file mode 100644 index 0000000000..acc2e7f4b9 --- /dev/null +++ b/collects/racket/draw/record-dc.rkt @@ -0,0 +1,232 @@ +#lang racket/base +(require mred/private/syntax + mred/private/lock + racket/class + "dc.rkt" + "bitmap.rkt" + "bitmap-dc.rkt" + "color.rkt" + "point.rkt" + "pen.rkt" + "brush.rkt" + "region.rkt" + "dc-path.rkt" + "local.ss") + +(provide record-dc-mixin + get-recorded-command + reset-recording) + +(define-local-member-name + get-recorded-command + reset-recording) + +(define black (send the-color-database find-color "black")) + +(define (clone-point p) + (make-object point% (point-x p) (point-y p))) + +(define (clone-color c) + (if (send c is-immutable?) + c + (make-object color% c))) + +(define (clone-pen p) + (let ([s (send p get-stipple)]) + (if s + (let ([p (make-object pen% + (send p get-color) + (send p get-width) + (send p get-style) + (send p get-cap) + (send p get-join))]) + (send p set-stipple (clone-bitmap s)) + p) + (send the-pen-list find-or-create-pen + (send p get-color) + (send p get-width) + (send p get-style) + (send p get-cap) + (send p get-join))))) + +(define (clone-brush b) + (let ([s (send b get-stipple)]) + (if s + (let ([b (make-object brush% + (send b get-color) + (send b get-style))]) + (send b set-stipple (clone-bitmap s)) + b) + (send the-brush-list find-or-create-brush + (send b get-color) + (send b get-style))))) + +(define (region-maker r) + (if (send r internal-get-dc) + (let ([paths (send r get-paths)]) + (lambda (dc) + (let ([new-r (make-object region% dc)]) + (send new-r set-paths! paths) + new-r))) + (let ([new-r (make-object region%)]) + (send new-r union r) + (lambda (dc) new-r)))) + +(define (clone-path p) + (let ([new-p (make-object dc-path%)]) + (send new-p append p) + p)) + +(define (clone-bitmap b) + (let* ([new-b (make-object bitmap% + (send b get-width) + (send b get-height) + (not (send b is-color?)) + (send b has-alpha-channel?))] + [dc (make-object bitmap-dc% new-b)]) + (send dc draw-bitmap b 0 0) + (send dc set-bitmap #f) + new-b)) + +(define (record-dc-mixin %) + (class % + (super-new) + + (define-syntax-rule (define/record (name arg ...)) + (define/override (name arg ...) + (super name arg ...) + (record (lambda (dc) (send dc name arg ...))))) + + (define procs null) + (define/private (record proc) + (set! procs (cons proc procs))) + + (define/public (get-recorded-command) + (let ([procs (reverse procs)]) + (lambda (dc) + (for ([proc (in-list procs)]) + (proc dc))))) + + (define/public (reset-recording) + (set! procs null)) + + (define clones (make-hasheq)) + (define/private (clone clone-x x) + (or (let ([new-x (hash-ref clones x #f)]) + (and new-x + (equal? new-x x) + new-x)) + (let ([new-x (clone-x x)]) + (hash-set! clones x new-x) + new-x))) + + (define/record (set-scale sx sy)) + + (define/record (set-origin sx sy)) + + (define/record (set-rotation r)) + + (define/override (transform mi) + (super transform mi) + (let ([mi (vector->immutable-vector mi)]) + (record (lambda (dc) (send dc transform mi))))) + + (define/override (set-initial-matrix mi) + (super set-initial-matrix mi) + (let ([mi (vector->immutable-vector mi)]) + (record (lambda (dc) (send dc set-initial-matrix mi))))) + + (define/override (set-transformation mi) + (super set-transformation mi) + (let ([mi (vector->immutable-vector mi)]) + (record (lambda (dc) (send dc set-transformation mi))))) + + (define/record (set-smoothing s)) + + (define/record (set-alpha n)) + + (define/record (set-font f)) + + (define/override (do-set-pen! p) + (super do-set-pen! p) + (let ([p (clone clone-pen p)]) + (record (lambda (dc) (send dc do-set-pen! p))))) + + (define/override (do-set-brush! b) + (super do-set-brush! b) + (let ([b (clone clone-brush b)]) + (record (lambda (dc) (send dc do-set-brush! b))))) + + (define/override (set-text-foreground c) + (super set-text-foreground c) + (let ([c (clone clone-color c)]) + (record (lambda (dc) (send dc set-text-foreground c))))) + + (define/override (set-text-background c) + (super set-text-background c) + (let ([c (clone clone-color c)]) + (record (lambda (dc) (send dc set-text-background c))))) + + (define/override (set-background c) + (super set-background c) + (let ([c (clone clone-color c)]) + (record (lambda (dc) (send dc set-background c))))) + + (define/record (set-text-mode m)) + + (define/override (set-clipping-region r) + (super set-clipping-region r) + (let ([make-r (if r + (region-maker r) + (lambda (dc) #f))]) + (record (lambda (dc) (send dc set-clipping-region (make-r dc)))))) + + (define/record (set-clipping-rect x y w h)) + + (define/record (clear)) + + (define/record (erase)) + + (define/record (draw-arc x y + width height + start-radians end-radians)) + + (define/record (draw-ellipse x y w h)) + + (define/record (draw-line x1 y1 x2 y2)) + + (define/record (draw-point x y)) + + (define/override (draw-lines pts [x 0.0] [y 0.0]) + (super draw-lines pts x y) + (let ([pts (map (lambda (p) (clone clone-point p)) pts)]) + (record (lambda (dc) (send dc draw-lines pts x y))))) + + (define/override (draw-polygon pts [x 0.0] [y 0.0] [fill-style 'odd-even]) + (super draw-polygon pts x y fill-style) + (let ([pts (map (lambda (p) (clone clone-point p)) pts)]) + (record (lambda (dc) (send dc draw-polygon pts x y fill-style))))) + + (define/record (draw-rectangle x y w h)) + + (define/override (draw-rounded-rectangle x y w h [radius -0.25]) + (super draw-rounded-rectangle x y w h radius) + (record (lambda (dc) (send dc draw-rounded-rectangle x y w h radius)))) + + (define/record (draw-spline x1 y1 x2 y2 x3 y3)) + + (define/override (draw-path path [x 0.0] [y 0.0] [fill-style 'odd-even]) + (super draw-path path x y fill-style) + (let ([path (clone clone-path path)]) + (record (lambda (dc) (send dc draw-path path x y fill-style))))) + + (define/override (draw-text s x y [combine? #f] [offset 0] [angle 0.0]) + (super draw-text s x y combine? offset angle) + (let ([s (string->immutable-string s)]) + (record (lambda (dc) (send dc draw-text s x y combine? offset angle))))) + + (define/override (draw-bitmap-section src dx dy sx sy sw sh [style 'solid] [color black] [mask #f]) + (super draw-bitmap-section src dx dy sx sy sw sh style color mask) + (let ([src (clone clone-bitmap src)] + [mask (and mask (clone clone-bitmap mask))]) + (record (lambda (dc) (send dc draw-bitmap-section src dx dy sx sy sw sh style color mask))))))) diff --git a/collects/racket/draw/region.rkt b/collects/racket/draw/region.rkt index 8d4593f106..a3c1e82633 100644 --- a/collects/racket/draw/region.rkt +++ b/collects/racket/draw/region.rkt @@ -12,6 +12,7 @@ (define-local-member-name get-paths + set-paths! internal-get-dc) (define temp-cr #f) @@ -32,6 +33,7 @@ ;; A null path list corresponds to an empty region. (define paths null) (define/public (get-paths) paths) + (define/public (set-paths! p) (set! paths p)) (define locked 0) (define/public (lock-region delta) (set! locked (+ locked delta))) diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 066da70e1e..389223493b 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -1243,6 +1243,9 @@ (send canvas refresh))))]) (set! do-clock clock) (make-object button% "Clip Clock" hp3 (lambda (b e) (clock #t))) + (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))))) (make-object slider% "Alpha" 0 10 hp4 (lambda (s e) (let ([a (/ (send s get-value) 10.0)])