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

cocoa: printer-dc%

Browse Source 
original commit: b4fafc1888795b4e6be8072db4cb7e81fa1395a6
This commit is contained in:
Matthew Flatt 2010-10-14 16:43:41 -06:00
parent 13831d20c0
commit 93339923eb
4 changed files with 171 additions and 10 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]

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