281 lines
9.8 KiB
Scheme
281 lines
9.8 KiB
Scheme
(module gdi mzscheme
|
|
(require (lib "class.ss")
|
|
(lib "class100.ss")
|
|
(prefix wx: "kernel.ss")
|
|
"lock.ss"
|
|
"check.ss"
|
|
"wx.ss"
|
|
"mrtop.ss"
|
|
"mrcanvas.ss")
|
|
|
|
(provide register-collecting-blit
|
|
unregister-collecting-blit
|
|
bitmap-dc%
|
|
post-script-dc%
|
|
printer-dc%
|
|
get-window-text-extent
|
|
get-family-builtin-face
|
|
normal-control-font
|
|
small-control-font
|
|
tiny-control-font
|
|
view-control-font
|
|
menu-control-font)
|
|
|
|
(define register-collecting-blit
|
|
(case-lambda
|
|
[(canvas x y w h on off) (register-collecting-blit canvas x y w h on off 0 0 0 0)]
|
|
[(canvas x y w h on off on-x) (register-collecting-blit canvas x y w h on off on-x 0 0 0)]
|
|
[(canvas x y w h on off on-x on-y) (register-collecting-blit canvas x y w h on off on-x on-y 0 0)]
|
|
[(canvas x y w h on off on-x on-y off-x) (register-collecting-blit canvas x y w h on off on-x on-y off-x 0)]
|
|
[(canvas x y w h on off on-x on-y off-x off-y)
|
|
(check-instance 'register-collecting-blit canvas% 'canvas% #f canvas)
|
|
(wx:register-collecting-blit (mred->wx canvas) x y w h on off on-x on-y off-x off-y)]))
|
|
|
|
(define unregister-collecting-blit
|
|
(lambda (canvas)
|
|
(check-instance 'unregister-collecting-blit canvas% 'canvas% #f canvas)
|
|
(wx:unregister-collecting-blit (mred->wx canvas))))
|
|
|
|
(define bitmap-dc%
|
|
(class100 wx:bitmap-dc% ([bitmap #f])
|
|
(inherit set-bitmap)
|
|
(sequence
|
|
(super-init)
|
|
(when bitmap
|
|
(set-bitmap bitmap)))))
|
|
|
|
(define-syntax check-page-active
|
|
(syntax-rules ()
|
|
[(_ check-page-status (id . args) ...) (begin (check-one-page-active check-page-status id args) ...)]))
|
|
(define-syntax check-one-page-active
|
|
(syntax-rules ()
|
|
[(_ check-page-status id simple ... (arg ... [opt ...]))
|
|
(check-one-page-active
|
|
check-page-status id
|
|
simple ...
|
|
(arg ...)
|
|
(arg ... opt ...))]
|
|
[(_ check-page-status id (arg ...) ...)
|
|
(define/override id
|
|
(case-lambda
|
|
[(arg ...) (check-page-status 'id) (super id arg ...)]
|
|
...))]))
|
|
|
|
(define-local-member-name multiple-pages-ok?)
|
|
|
|
(define (doc+page-check-mixin % class-name)
|
|
(class %
|
|
(define status #f)
|
|
(define did-one-page? #f)
|
|
|
|
(define/public (multiple-pages-ok?) #t)
|
|
|
|
(define/override (start-doc s)
|
|
(when status
|
|
(raise-mismatch-error (who->name (list 'method class-name 'start-doc))
|
|
(case status
|
|
[(done)
|
|
"document has already been ended: "]
|
|
[else
|
|
"document has already been started: "])
|
|
this))
|
|
(set! status 'doc)
|
|
(super start-doc s))
|
|
|
|
(define/override (end-doc)
|
|
(unless (eq? status 'doc)
|
|
(raise-mismatch-error (who->name (list 'method class-name 'end-doc))
|
|
(case status
|
|
[(page)
|
|
"current page has not been ended: "]
|
|
[(done)
|
|
"document is already ended: "]
|
|
[(#f)
|
|
"document is not started: "])
|
|
this))
|
|
(set! status 'done)
|
|
(super end-doc))
|
|
|
|
(define/override (start-page)
|
|
(unless (eq? status 'doc)
|
|
(raise-mismatch-error (who->name (list 'method class-name 'start-page))
|
|
(if (eq? status 'page)
|
|
"current page has not been ended: "
|
|
"document is not started (use the `start-doc' method): ")
|
|
this))
|
|
(when did-one-page?
|
|
(unless (multiple-pages-ok?)
|
|
(raise-mismatch-error (who->name (list 'method class-name 'start-page))
|
|
"cannot create multiple pages for EPS output: "
|
|
this)))
|
|
(set! status 'page)
|
|
(set! did-one-page? #t)
|
|
(super start-page))
|
|
|
|
(define/override (end-page)
|
|
(unless (eq? status 'page)
|
|
(raise-mismatch-error (who->name (list 'method class-name 'end-page))
|
|
"no page is currently started: "
|
|
this))
|
|
(set! status 'doc)
|
|
(super end-page))
|
|
|
|
(define/private (check-page-status method-name)
|
|
(unless (eq? status 'page)
|
|
(raise-mismatch-error (who->name (list 'method class-name method-name))
|
|
"no page is currently started (use `start-doc' and `start-page' before drawing): "
|
|
this)))
|
|
|
|
(check-page-active
|
|
check-page-status
|
|
(draw-bitmap source dest-x dest-y [style [color [mask]]])
|
|
(draw-bitmap-section source dest-x dest-y src-x src-y src-width src-height [style [color [mask]]])
|
|
(set-text-foreground c)
|
|
(set-text-background c)
|
|
(set-brush b/c [style])
|
|
(set-pen p/c [width style])
|
|
(set-font f)
|
|
(set-background c)
|
|
(set-clipping-region r)
|
|
(set-clipping-rect x y w h)
|
|
(draw-polygon pts [x [y [fill]]])
|
|
(draw-lines pts [x [y]])
|
|
(draw-path path [x [y [fill]]])
|
|
(draw-ellipse x y w h)
|
|
(draw-arc x y w h s e)
|
|
(draw-text txt x y [combine? [offset [angle]]])
|
|
(draw-spline x1 y1 x2 y2 x3 y3)
|
|
(draw-rounded-rectangle x y w h [r])
|
|
(draw-rectangle x y w h)
|
|
(draw-point x y)
|
|
(draw-line x1 y1 x2 y2)
|
|
(clear))
|
|
|
|
(super-new)))
|
|
|
|
(define post-script-dc%
|
|
(class (doc+page-check-mixin wx:post-script-dc% 'post-script-dc%)
|
|
(init [interactive #t][parent #f][use-paper-bbox #f][as-eps #t])
|
|
|
|
(check-top-level-parent/false '(constructor post-script-dc) parent)
|
|
|
|
(define is-eps? (and as-eps #t))
|
|
(define/override (multiple-pages-ok?) (not is-eps?))
|
|
|
|
(as-entry
|
|
(lambda ()
|
|
(let ([p (and parent (mred->wx parent))])
|
|
(as-exit (lambda () (super-make-object interactive p use-paper-bbox as-eps))))))))
|
|
|
|
(define printer-dc%
|
|
(class100 (doc+page-check-mixin wx:printer-dc% 'printer-dc%) ([parent #f])
|
|
(sequence
|
|
(check-top-level-parent/false '(constructor printer-dc) parent)
|
|
(as-entry
|
|
(lambda ()
|
|
(let ([p (and parent (mred->wx parent))])
|
|
(as-exit (lambda () (super-init p)))))))))
|
|
|
|
(define get-window-text-extent
|
|
(let ([bm #f][dc #f])
|
|
(case-lambda
|
|
[(string font)
|
|
(check-string 'get-window-text-extent string)
|
|
(check-instance 'get-window-text-extent wx:font% 'font% #f font)
|
|
(unless bm
|
|
(set! bm (make-object wx:bitmap% 2 2))
|
|
(set! dc (make-object wx:bitmap-dc%))
|
|
(send dc set-bitmap bm))
|
|
(unless (send bm ok?)
|
|
(error 'get-window-text-extent "couldn't allocate sizing bitmap"))
|
|
(let-values ([(w h d a) (send dc get-text-extent string font)])
|
|
(values (inexact->exact w) (inexact->exact h)))])))
|
|
|
|
(define x-has-xft? 'unknown)
|
|
(define mswin-system #f)
|
|
(define mswin-default #f)
|
|
(define (look-for-font name)
|
|
(if (ormap (lambda (n) (string-ci=? name n)) (wx:get-face-list))
|
|
name
|
|
"MS San Serif"))
|
|
|
|
(define (get-family-builtin-face family)
|
|
(unless (memq family '(default decorative roman script swiss modern system symbol))
|
|
(raise-type-error 'get-family-builtin-face "family symbol" family))
|
|
(case (system-type)
|
|
[(unix)
|
|
;; Detect Xft by looking for a font with a space in front of its name:
|
|
(when (eq? x-has-xft? 'unknown)
|
|
(set! x-has-xft? (ormap (lambda (s) (regexp-match #rx"^ " s)) (wx:get-face-list))))
|
|
(if x-has-xft?
|
|
(case family
|
|
[(system) " Sans"]
|
|
[(default) " Sans"]
|
|
[(roman) " Serif"]
|
|
[(decorative) " Nimbus Sans L"]
|
|
[(modern) " Monospace"]
|
|
[(swiss) " Nimbus Sans L"]
|
|
[(script) " URW Chancery L"]
|
|
[(symbol) " Standard Symbols L,Nimbus Sans L"])
|
|
(case family
|
|
[(system) "-b&h-lucida"]
|
|
[(default) "-b&h-lucida"]
|
|
[(roman) "-adobe-times"]
|
|
[(decorative) "-adobe-helvetica"]
|
|
[(modern) "-adobe-courier"]
|
|
[(swiss) "-b&h-lucida"]
|
|
[(script) "-itc-zapfchancery"]
|
|
[(symbol) "-adobe-symbol"]))]
|
|
[(windows)
|
|
(case family
|
|
[(system)
|
|
(unless mswin-system
|
|
(set! mswin-system (look-for-font "Tahoma")))
|
|
mswin-system]
|
|
[(default)
|
|
(unless mswin-default
|
|
(set! mswin-default (look-for-font "Microsoft Sans Serif")))
|
|
mswin-default]
|
|
[(default) "MS Sans Serif"]
|
|
[(roman) "Times New Roman"]
|
|
[(decorative) "Arial"]
|
|
[(modern) "Courier New"]
|
|
[(swiss) "Arial"]
|
|
[(script) "Arial"]
|
|
[(symbol) "Symbol"])]
|
|
[(macos)
|
|
(case family
|
|
[(system) "systemfont"]
|
|
[(default) "applicationfont"]
|
|
[(roman) "Times"]
|
|
[(decorative) "Geneva"]
|
|
[(modern) "Monaco"]
|
|
[(swiss) "Helvetica"]
|
|
[(script) "Zaph Chancery"]
|
|
[(symbol) "Symbol"])]
|
|
[(macosx)
|
|
(case family
|
|
[(system) "systemfont"]
|
|
[(default) "applicationfont"]
|
|
[(roman) "Times"]
|
|
[(decorative) "Arial"]
|
|
[(modern) "Courier New"]
|
|
[(swiss) "Helvetica"]
|
|
[(script) "Apple Chancery"]
|
|
[(symbol) "Symbol"])]))
|
|
|
|
(define small-delta (case (system-type)
|
|
[(windows) 0]
|
|
[(macosx) 2]
|
|
[else 1]))
|
|
|
|
(define normal-control-font (make-object wx:font% (wx:get-control-font-size) 'system))
|
|
(define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) 'system))
|
|
(define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) 2 small-delta) 'system))
|
|
(define view-control-font (if (eq? 'macosx (system-type))
|
|
(make-object wx:font% (- (wx:get-control-font-size) 1) 'system)
|
|
normal-control-font))
|
|
(define menu-control-font (if (eq? 'macosx (system-type))
|
|
(make-object wx:font% (+ (wx:get-control-font-size) 1) 'system)
|
|
normal-control-font)))
|