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

cocoa: printer-dc%

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-14 16:43:41 -06:00
parent 0433cd0337
commit b4fafc1888
9 changed files with 477 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/mred/private/wx/cocoa/cg.rkt
View File

@ -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))

170
collects/mred/private/wx/cocoa/printer-dc.rkt
View File

@ -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))))

7
collects/mred/private/wx/cocoa/procs.rkt
View File

@ -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]

25
collects/mred/private/wx/common/printer.rkt Normal file
View File

@ -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)))

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

@ -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)

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

@ -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])

232
collects/racket/draw/record-dc.rkt Normal file
View File

@ -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)))))))

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

@ -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)))

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

@ -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)])