racket/draw: add `record-dc%'
This commit is contained in:
Matthew Flatt
parent
678941ce5a
commit
645ca02e92
|
|
@ -11,6 +11,7 @@
|
|||
"draw/private/dc-path.rkt"
|
||||
"draw/private/dc-intf.rkt"
|
||||
"draw/private/bitmap-dc.rkt"
|
||||
"draw/private/record-dc.rkt"
|
||||
"draw/private/post-script-dc.rkt"
|
||||
"draw/private/ps-setup.rkt"
|
||||
"draw/private/svg-dc.rkt"
|
||||
|
|
@ -30,6 +31,7 @@
|
|||
dc-path%
|
||||
dc<%>
|
||||
bitmap-dc%
|
||||
record-dc% recorded-datum->procedure
|
||||
post-script-dc%
|
||||
pdf-dc%
|
||||
ps-setup% current-ps-setup
|
||||
|
|
|
|||
|
|
@ -14,11 +14,16 @@
|
|||
|
||||
(provide dc-path%
|
||||
(protect-out do-path
|
||||
set-text-to-path!))
|
||||
set-text-to-path!
|
||||
|
||||
get-closed-points
|
||||
get-open-points
|
||||
set-closed+open-points))
|
||||
|
||||
(define-local-member-name
|
||||
get-closed-points
|
||||
get-open-points
|
||||
set-closed+open-points
|
||||
do-path)
|
||||
|
||||
(define 2pi (* 2.0 pi))
|
||||
|
|
@ -52,8 +57,33 @@
|
|||
(define/public (get-closed-points) (flatten-closed!) closed-points)
|
||||
(define/public (get-open-points) (flatten-open!) open-points)
|
||||
|
||||
(define/public (set-closed+open-points c o)
|
||||
(define (ok-points? l)
|
||||
(let loop ([l l])
|
||||
(cond
|
||||
[(null? l) #t]
|
||||
[(pair? l)
|
||||
(let ([p (car l)])
|
||||
(if (pair? p)
|
||||
(and (real? (car p))
|
||||
(real? (cdr p))
|
||||
(loop (cdr l)))
|
||||
(and (vector? p)
|
||||
(= (vector-length p) 4)
|
||||
(real? (vector-ref p 0))
|
||||
(real? (vector-ref p 1))
|
||||
(real? (vector-ref p 2))
|
||||
(real? (vector-ref p 3))
|
||||
(pair? (cdr l))
|
||||
(pair? (cadr l))
|
||||
(loop (cdr l)))))])))
|
||||
(unless (and (andmap ok-points? c) (ok-points? o))
|
||||
(error "invalid path points"))
|
||||
(set! closed-points c)
|
||||
(set! open-points o))
|
||||
|
||||
(define/private (do-points cr l align-x align-y)
|
||||
(let loop ([l l][first? #t])
|
||||
(let loop ([l l] [first? #t])
|
||||
(cond
|
||||
[(null? l) (void)]
|
||||
[else
|
||||
|
|
|
|||
|
|
@ -575,17 +575,17 @@
|
|||
(let ([o pen])
|
||||
(send p adjust-lock 1)
|
||||
(set! pen p)
|
||||
(send o adjust-lock -1)))
|
||||
(send o adjust-lock -1))
|
||||
(reset-align!))
|
||||
|
||||
(define/public (set-pen . args)
|
||||
(case-args
|
||||
args
|
||||
[([pen% p]) (do-set-pen! p) (reset-align!)]
|
||||
[([pen% p]) (do-set-pen! p)]
|
||||
[([(make-alts string? color%) col]
|
||||
[pen-width? width]
|
||||
[pen-style-symbol? style])
|
||||
(do-set-pen! (send the-pen-list find-or-create-pen col width style))
|
||||
(reset-align!)]
|
||||
(do-set-pen! (send the-pen-list find-or-create-pen col width style))]
|
||||
(method-name 'dc<%> 'set-pen)))
|
||||
|
||||
(define/public (get-pen) pen)
|
||||
|
|
|
|||
|
|
@ -1,38 +1,61 @@
|
|||
#lang racket/base
|
||||
(require racket/class
|
||||
ffi/unsafe/atomic
|
||||
"../unsafe/cairo.rkt"
|
||||
"local.rkt"
|
||||
"syntax.rkt"
|
||||
"dc.rkt"
|
||||
"dc-intf.rkt"
|
||||
"bitmap.rkt"
|
||||
"bitmap-dc.rkt"
|
||||
"color.rkt"
|
||||
"point.rkt"
|
||||
"pen.rkt"
|
||||
"brush.rkt"
|
||||
"font.rkt"
|
||||
"region.rkt"
|
||||
"dc-path.rkt")
|
||||
"dc-path.rkt"
|
||||
"gradient.rkt"
|
||||
(for-syntax racket/base))
|
||||
|
||||
(provide record-dc-mixin
|
||||
get-recorded-command
|
||||
reset-recording
|
||||
set-recording-limit)
|
||||
(provide record-dc%
|
||||
recorded-datum->procedure
|
||||
(protect-out record-dc-mixin
|
||||
get-recorded-command
|
||||
reset-recording
|
||||
set-recording-limit))
|
||||
|
||||
(define-local-member-name
|
||||
get-recorded-command
|
||||
reset-recording
|
||||
set-recording-limit)
|
||||
set-recording-limit
|
||||
record-unconvert)
|
||||
|
||||
(define black (send the-color-database find-color "black"))
|
||||
|
||||
(define (clone-point p)
|
||||
(if (pair? p)
|
||||
p
|
||||
(make-object point% (point-x p) (point-y p))))
|
||||
(cons (point-x p) (point-y p))))
|
||||
|
||||
(define (clone-points ps)
|
||||
(map clone-point ps))
|
||||
|
||||
(define (clone-color c)
|
||||
(if (string? c)
|
||||
(string->immutable-string c)
|
||||
(color->immutable-color c)))
|
||||
|
||||
(define (convert-color c)
|
||||
(if (string? c)
|
||||
(string->immutable-string c)
|
||||
(list (color-red c) (color-green c) (color-blue c) (color-alpha c))))
|
||||
|
||||
(define (unconvert-color c)
|
||||
(if (string? c)
|
||||
(string->immutable-string c)
|
||||
(make-object color% (car c) (cadr c) (caddr c) (cadddr c))))
|
||||
|
||||
(define (clone-pen p)
|
||||
(let ([s (send p get-stipple)])
|
||||
(if s
|
||||
|
|
@ -51,6 +74,25 @@
|
|||
(send p get-cap)
|
||||
(send p get-join)))))
|
||||
|
||||
(define (convert-pen p)
|
||||
(let ([s (send p get-stipple)])
|
||||
(list (convert-color (send p get-color))
|
||||
(send p get-width)
|
||||
(send p get-style)
|
||||
(send p get-cap)
|
||||
(send p get-join)
|
||||
(and s (convert-bitmap s)))))
|
||||
|
||||
(define (unconvert-pen l)
|
||||
(define-values (c width style cap join stipple)
|
||||
(apply values l))
|
||||
(define color (unconvert-color c))
|
||||
(if stipple
|
||||
(let ([p (make-object pen% color width style cap join)])
|
||||
(send p set-stipple (unconvert-bitmap stipple))
|
||||
p)
|
||||
(send the-pen-list find-or-create-pen color width style cap join)))
|
||||
|
||||
(define (clone-brush b)
|
||||
(let ([s (send b get-stipple)])
|
||||
(if s
|
||||
|
|
@ -72,6 +114,55 @@
|
|||
(send b get-color)
|
||||
(send b get-style)))))))
|
||||
|
||||
(define (convert-brush b)
|
||||
(let ([s (send b get-stipple)]
|
||||
[g (send b get-gradient)])
|
||||
(list (convert-color (send b get-color))
|
||||
(send b get-style)
|
||||
(and s (convert-bitmap s))
|
||||
(and g (convert-gradient g))
|
||||
(send b get-transformation))))
|
||||
|
||||
(define (unconvert-brush l)
|
||||
(define-values (c style stipple gradient transformation)
|
||||
(apply values l))
|
||||
(define color (unconvert-color c))
|
||||
(if stipple
|
||||
(let ([b (make-object brush% color style)])
|
||||
(send b set-stipple (unconvert-bitmap stipple)
|
||||
transformation)
|
||||
b)
|
||||
(if gradient
|
||||
(make-object brush%
|
||||
color
|
||||
style
|
||||
#f
|
||||
(unconvert-gradient gradient)
|
||||
transformation)
|
||||
(send the-brush-list find-or-create-brush color style))))
|
||||
|
||||
(define (convert-gradient g)
|
||||
(if (g . is-a? . linear-gradient%)
|
||||
(let-values ([(x1 y1 x2 y2) (send g get-line)])
|
||||
(list x1 y1 x2 y2 (convert-stops (send g get-stops))))
|
||||
(let-values ([(x1 y1 r1 x2 y2 r2) (send g get-circles)])
|
||||
(list x1 y1 r1 x2 y2 r2 (convert-stops (send g get-stops))))))
|
||||
|
||||
(define (unconvert-gradient l)
|
||||
(if (= (length l) 5)
|
||||
(make-object linear-gradient%
|
||||
(car l) (cadr l) (caddr l) (cadddr l)
|
||||
(unconvert-stops (list-ref l 4)))
|
||||
(make-object radial-gradient%
|
||||
(car l) (cadr l) (caddr l)
|
||||
(list-ref l 3) (list-ref l 4) (list-ref l 5)
|
||||
(unconvert-stops (list-ref l 6)))))
|
||||
|
||||
(define (convert-stops s)
|
||||
(for/list ([i (in-list s)]) (cons (car i) (convert-color (cadr i)))))
|
||||
(define (unconvert-stops s)
|
||||
(for/list ([i (in-list s)]) (list (car i) (unconvert-color (cdr i)))))
|
||||
|
||||
(define (region-maker r)
|
||||
(if (send r internal-get-dc)
|
||||
(let ([paths (send r get-paths)])
|
||||
|
|
@ -83,21 +174,84 @@
|
|||
(send new-r union r)
|
||||
(lambda (dc) new-r))))
|
||||
|
||||
(define (convert-region r)
|
||||
(and r
|
||||
(cons (and (send r internal-get-dc) #t)
|
||||
(map convert-path (send r get-paths)))))
|
||||
|
||||
(define (unconvert-region l)
|
||||
(if l
|
||||
(let ()
|
||||
(define paths (map unconvert-path (cdr l)))
|
||||
(if (car l)
|
||||
(lambda (dc)
|
||||
(let ([new-r (make-object region% (and (car l) dc))])
|
||||
(send new-r set-paths! paths)
|
||||
new-r))
|
||||
(let ([new-r (make-object region%)])
|
||||
(send new-r set-paths! paths)
|
||||
(lambda (dc) new-r))))
|
||||
(lambda (dc) #f)))
|
||||
|
||||
(define (clone-path p)
|
||||
(let ([new-p (make-object dc-path%)])
|
||||
(send new-p append p)
|
||||
p))
|
||||
|
||||
(define (convert-path p)
|
||||
(cons (send p get-closed-points)
|
||||
(send p get-open-points)))
|
||||
|
||||
(define (unconvert-path l)
|
||||
(define p (new dc-path%))
|
||||
(send p set-closed+open-points (car l) (cdr l))
|
||||
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))
|
||||
(and 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 (convert-bitmap b)
|
||||
(and b
|
||||
(let ()
|
||||
(define w (send b get-width))
|
||||
(define h (send b get-height))
|
||||
(define bstr (make-bytes (* 4 w h)))
|
||||
(send b get-argb-pixels 0 0 w h bstr)
|
||||
(list w h
|
||||
(send b is-color?)
|
||||
(send b has-alpha-channel?)
|
||||
(bytes->immutable-bytes bstr)))))
|
||||
|
||||
(define (unconvert-bitmap l)
|
||||
(and l
|
||||
(let ()
|
||||
(define-values (w h color? alpha? bstr)
|
||||
(apply values l))
|
||||
(define bm (make-object bitmap% w h (not color?) alpha?))
|
||||
(send bm set-argb-pixels 0 0 w h bstr)
|
||||
bm)))
|
||||
|
||||
(define (convert-font f)
|
||||
(list (send f get-point-size)
|
||||
(send f get-face)
|
||||
(send f get-family)
|
||||
(send f get-style)
|
||||
(send f get-weight)
|
||||
(send f get-underlined)
|
||||
(send f get-smoothing)
|
||||
(send f get-size-in-pixels)))
|
||||
|
||||
(define (unconvert-font l)
|
||||
(apply make-object font% l))
|
||||
|
||||
(define (record-dc-mixin %)
|
||||
(class %
|
||||
|
|
@ -106,7 +260,8 @@
|
|||
(inherit get-origin get-scale get-rotation get-initial-matrix
|
||||
get-pen get-brush get-font
|
||||
get-smoothing get-text-mode
|
||||
get-alpha get-clipping-region)
|
||||
get-alpha get-clipping-region
|
||||
translate rotate scale)
|
||||
|
||||
(define record-limit +inf.0)
|
||||
(define current-size 0)
|
||||
|
|
@ -116,29 +271,126 @@
|
|||
(define/private (continue-recording?)
|
||||
(current-size . < . record-limit))
|
||||
|
||||
(define-syntax-rule (define/record (name arg ...))
|
||||
(define/override (name arg ...)
|
||||
(super name arg ...)
|
||||
(record (lambda (dc) (send dc name arg ...)))))
|
||||
(define-syntax (define/record stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (name arg ...))
|
||||
(let ([args (syntax->list #'(arg ...))])
|
||||
(with-syntax ([(arg-id ...)
|
||||
(map (lambda (arg)
|
||||
(syntax-case arg ()
|
||||
[([id def-val]) #'id]
|
||||
[([id def-val] clone-id convert-id unconvert-id) #'id]
|
||||
[(id clone-id convert-id unconvert-id) #'id]
|
||||
[(id clone-id) #'id]
|
||||
[else arg]))
|
||||
args)]
|
||||
[(arg-formal ...)
|
||||
(map (lambda (arg)
|
||||
(syntax-case arg ()
|
||||
[(id) #'id]
|
||||
[(id clone-id convert-id unconvert-id) #'id]
|
||||
[(id clone-id) #'id]
|
||||
[else arg]))
|
||||
args)]
|
||||
[(arg-bind ...)
|
||||
(map (lambda (arg)
|
||||
(syntax-case arg ()
|
||||
[([id def-val])
|
||||
#'[id id]]
|
||||
[([id def-val] clone-id convert-id unconvert-id)
|
||||
#'[id (clone clone-id id)]]
|
||||
[(id clone-id convert-id unconvert-id)
|
||||
#'[id (clone clone-id id)]]
|
||||
[(id clone-id)
|
||||
#'[id (clone clone-id id)]]
|
||||
[id
|
||||
#'[id id]]))
|
||||
args)]
|
||||
[((arg-convert ...) ...)
|
||||
(map (lambda (arg)
|
||||
(syntax-case arg ()
|
||||
[(formal clone-id convert-id unconvert-id)
|
||||
#'(convert convert-id)]
|
||||
[_ #'(values)]))
|
||||
args)])
|
||||
#'(define/override (name arg-formal ...)
|
||||
(super name arg-id ...)
|
||||
(when (continue-recording?)
|
||||
(let (arg-bind ...)
|
||||
(record (lambda (dc) (send dc name arg-id ...))
|
||||
(lambda () (list 'name (arg-convert ... arg-id) ...))))))))]))
|
||||
|
||||
(define-syntax (generate-record-unconvert stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ([clause-tags clause-rhs] ...) (defn (name arg ...)) ...)
|
||||
(with-syntax ([((arg-id ...) ...)
|
||||
(let ([names (syntax->list #'(name ...))]
|
||||
[argss (syntax->list #'((arg ...) ...))])
|
||||
(map (lambda (name args)
|
||||
(map (lambda (arg)
|
||||
(syntax-case arg ()
|
||||
[([id def-val]) #'id]
|
||||
[([id def-val] clone-id convert-id unconvert-id) #'id]
|
||||
[(id clone-id convert-id unconvert-id) #'id]
|
||||
[(id clone-id) #'id]
|
||||
[else arg]))
|
||||
(syntax->list args)))
|
||||
names
|
||||
argss))]
|
||||
[(((arg-bind ...) ...) ...)
|
||||
(let ([argss (syntax->list #'((arg ...) ...))])
|
||||
(map (lambda (args)
|
||||
(map (lambda (arg)
|
||||
(syntax-case arg ()
|
||||
[([id def-val] clone-id convert-id unconvert-id)
|
||||
#'([id (unconvert-id id)])]
|
||||
[(id clone-id convert-id unconvert-id)
|
||||
#'([id (unconvert-id id)])]
|
||||
[_ #'()]))
|
||||
(syntax->list args)))
|
||||
argss))])
|
||||
#'(begin
|
||||
(defn (name arg ...)) ...
|
||||
(define/public (record-unconvert cmds)
|
||||
(for/list ([cmd (in-list cmds)])
|
||||
(define cmd-tag (car cmd))
|
||||
(define cmd-args (cdr cmd))
|
||||
(case cmd-tag
|
||||
[clause-tags (apply clause-rhs cmd-args)] ...
|
||||
[(name)
|
||||
(apply (lambda (arg-id ...)
|
||||
(let (arg-bind ... ...)
|
||||
(lambda (dc) (send dc name arg-id ...))))
|
||||
cmd-args)]
|
||||
...
|
||||
[else (error 'unconvert "bad datum: ~e" cmd-tag)])))))]))
|
||||
|
||||
(define procs null)
|
||||
(define/private (record proc)
|
||||
(define converts null)
|
||||
(define/private (record proc convert)
|
||||
(when (continue-recording?)
|
||||
(start-atomic)
|
||||
(set! current-size (add1 current-size))
|
||||
(set! procs (cons proc procs))
|
||||
(set! converts (cons convert converts))
|
||||
(end-atomic)))
|
||||
|
||||
(define/public (get-recorded-command)
|
||||
(define/public (get-recorded-command [serialize? #f])
|
||||
(and (continue-recording?)
|
||||
(let ([procs (reverse procs)])
|
||||
(lambda (dc)
|
||||
(for ([proc (in-list procs)])
|
||||
(proc dc))))))
|
||||
(if serialize?
|
||||
(for/list ([convert (in-list (reverse converts))])
|
||||
(convert))
|
||||
(let ([procs (reverse procs)])
|
||||
(lambda (dc)
|
||||
(for ([proc (in-list procs)])
|
||||
(proc dc)))))))
|
||||
|
||||
(define/public (reset-recording)
|
||||
(start-atomic)
|
||||
(set! clones (make-hasheq))
|
||||
(set! converteds (make-hasheq))
|
||||
(set! procs null)
|
||||
(set! converts null)
|
||||
(set! current-size 0)
|
||||
(end-atomic)
|
||||
;; install current configuration explicitly (so it gets recorded):
|
||||
|
|
@ -152,18 +404,27 @@
|
|||
[(f) (get-font)]
|
||||
[(tm) (get-text-mode)]
|
||||
[(a) (get-alpha)]
|
||||
[(cr) (get-clipping-region)])
|
||||
(unless (and (zero? ox) (zero? oy)) (set-origin ox oy))
|
||||
(unless (and (= 1 sx) (= 1 sy)) (set-scale sx sy))
|
||||
(unless (zero? r) (set-rotation r))
|
||||
(unless (equal? m '#(1.0 0.0 0.0 1.0 0.0 0.0)) (set-initial-matrix m))
|
||||
[(cr) (get-clipping-region)]
|
||||
[(to-default?) (applies-to-default?)])
|
||||
(when to-default?
|
||||
(unless (and (zero? ox) (zero? oy)) (set-origin ox oy))
|
||||
(unless (and (= 1 sx) (= 1 sy)) (set-scale sx sy))
|
||||
(unless (zero? r) (set-rotation r))
|
||||
(unless (equal? m '#(1.0 0.0 0.0 1.0 0.0 0.0)) (set-initial-matrix m)))
|
||||
(unless to-default?
|
||||
(unless (equal? m '#(1.0 0.0 0.0 1.0 0.0 0.0)) (transform m))
|
||||
(unless (zero? r) (rotate r))
|
||||
(unless (and (= 1 sx) (= 1 sy)) (scale sx sy))
|
||||
(unless (and (zero? ox) (zero? oy)) (translate (- sx) (- sy))))
|
||||
(do-set-pen! p)
|
||||
(do-set-brush! b)
|
||||
(set-font f)
|
||||
(unless (eq? s 'unsmoothed) (set-smoothing s))
|
||||
(unless (eq? tm 'transparent) (set-text-mode tm))
|
||||
(unless (= a 1.0) (set-alpha a))
|
||||
(when cr (set-clipping-region cr))))
|
||||
(unless (and to-default? (eq? s 'unsmoothed)) (set-smoothing s))
|
||||
(unless (and to-default? (eq? tm 'transparent)) (set-text-mode tm))
|
||||
(unless (and to-default? (= a 1.0)) (set-alpha a))
|
||||
(unless (and to-default? (not cr)) (set-clipping-region cr))))
|
||||
|
||||
(define/public (applies-to-default?) #t)
|
||||
|
||||
(define clones (make-hasheq))
|
||||
(define/private (clone clone-x x)
|
||||
|
|
@ -172,69 +433,20 @@
|
|||
(equal? new-x x)
|
||||
new-x))
|
||||
(let ([new-x (clone-x x)])
|
||||
(hash-set! clones x new-x)
|
||||
(when (equal? new-x x)
|
||||
(hash-set! clones x new-x))
|
||||
new-x)))
|
||||
|
||||
(define/record (set-scale sx sy))
|
||||
(define converteds (make-hasheq))
|
||||
(define/private (convert convert-x x)
|
||||
(or (hash-ref converteds x #f)
|
||||
(let ([new-x (convert-x x)])
|
||||
(hash-set! converteds x new-x)
|
||||
new-x)))
|
||||
|
||||
(define/record (set-origin sx sy))
|
||||
|
||||
(define/record (set-rotation r))
|
||||
|
||||
(define/override (transform mi)
|
||||
(super transform mi)
|
||||
(when (continue-recording?)
|
||||
(let ([mi (vector->immutable-vector mi)])
|
||||
(record (lambda (dc) (send dc transform mi))))))
|
||||
|
||||
(define/override (set-initial-matrix mi)
|
||||
(super set-initial-matrix mi)
|
||||
(when (continue-recording?)
|
||||
(let ([mi (vector->immutable-vector mi)])
|
||||
(record (lambda (dc) (send dc set-initial-matrix mi))))))
|
||||
|
||||
(define/override (set-transformation mi)
|
||||
(super set-transformation mi)
|
||||
(when (continue-recording?)
|
||||
(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)
|
||||
(when (continue-recording?)
|
||||
(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)
|
||||
(when (continue-recording?)
|
||||
(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)
|
||||
(when (continue-recording?)
|
||||
(let ([c (clone clone-color c)])
|
||||
(record (lambda (dc) (send dc set-text-background c))))))
|
||||
|
||||
(define/override (set-background c)
|
||||
(super set-background c)
|
||||
(when (continue-recording?)
|
||||
(let ([c (clone clone-color c)])
|
||||
(record (lambda (dc) (send dc set-background c))))))
|
||||
|
||||
(define/record (set-text-mode m))
|
||||
(define/override (erase)
|
||||
(super erase)
|
||||
(reset-recording))
|
||||
|
||||
(define/override (set-clipping-region r)
|
||||
(super set-clipping-region r)
|
||||
|
|
@ -242,68 +454,157 @@
|
|||
(let ([make-r (if r
|
||||
(region-maker r)
|
||||
(lambda (dc) #f))])
|
||||
(record (lambda (dc) (send dc set-clipping-region (make-r dc)))))))
|
||||
(record (lambda (dc) (send dc set-clipping-region (make-r dc)))
|
||||
(lambda () (list 'set-clipping-region (convert-region r)))))))
|
||||
|
||||
(define/record (set-clipping-rect x y w h))
|
||||
(generate-record-unconvert
|
||||
([(set-clipping-region) (lambda (r)
|
||||
(define make-r (unconvert-region r))
|
||||
(lambda (dc)
|
||||
(send dc set-clipping-region (make-r dc))))])
|
||||
;; remaining clauses are generated:
|
||||
|
||||
(define/record (clear))
|
||||
(define/record (set-scale sx sy))
|
||||
|
||||
(define/override (erase)
|
||||
(super erase)
|
||||
(reset-recording))
|
||||
(define/record (set-origin sx sy))
|
||||
|
||||
(define/record (draw-arc x y
|
||||
width height
|
||||
start-radians end-radians))
|
||||
(define/record (set-rotation r))
|
||||
|
||||
(define/record (draw-ellipse x y w h))
|
||||
(define/record (transform [mi vector->immutable-vector]))
|
||||
|
||||
(define/record (draw-line x1 y1 x2 y2))
|
||||
(define/record (set-initial-matrix [mi vector->immutable-vector]))
|
||||
|
||||
(define/record (draw-point x y))
|
||||
(define/record (set-transformation [mi vector->immutable-vector]))
|
||||
|
||||
(define/override (draw-lines pts [x 0.0] [y 0.0])
|
||||
(super draw-lines pts x y)
|
||||
(when (continue-recording?)
|
||||
(let ([pts (map (lambda (p) (clone clone-point p)) pts)])
|
||||
(record (lambda (dc) (send dc draw-lines pts x y))))))
|
||||
(define/record (set-smoothing s))
|
||||
|
||||
(define/override (draw-polygon pts [x 0.0] [y 0.0] [fill-style 'odd-even])
|
||||
(super draw-polygon pts x y fill-style)
|
||||
(when (continue-recording?)
|
||||
(let ([pts (map (lambda (p) (clone clone-point p)) pts)])
|
||||
(record (lambda (dc) (send dc draw-polygon pts x y fill-style))))))
|
||||
(define/record (set-alpha n))
|
||||
|
||||
(define/record (draw-rectangle x y w h))
|
||||
(define/record (set-font [f values convert-font unconvert-font]))
|
||||
|
||||
(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 (do-set-pen! [p clone-pen convert-pen unconvert-pen]))
|
||||
|
||||
(define/record (draw-spline x1 y1 x2 y2 x3 y3))
|
||||
(define/record (do-set-brush! [b clone-brush convert-brush unconvert-brush]))
|
||||
|
||||
(define/override (draw-path path [x 0.0] [y 0.0] [fill-style 'odd-even])
|
||||
(super draw-path path x y fill-style)
|
||||
(when (continue-recording?)
|
||||
(let ([path (clone clone-path path)])
|
||||
(record (lambda (dc) (send dc draw-path path x y fill-style))))))
|
||||
(define/record (set-text-foreground [c clone-color convert-color unconvert-color]))
|
||||
|
||||
(define/override (draw-text s x y [combine? #f] [offset 0] [angle 0.0])
|
||||
(super draw-text s x y combine? offset angle)
|
||||
(when (continue-recording?)
|
||||
(let ([s (string->immutable-string s)])
|
||||
(record (lambda (dc) (send dc draw-text s x y combine? offset angle))))))
|
||||
(define/record (set-text-background [c clone-color convert-color unconvert-color]))
|
||||
|
||||
(define/override (draw-bitmap src dx dy [style 'solid] [color black] [mask #f])
|
||||
(super draw-bitmap src dx dy style color mask)
|
||||
(when (continue-recording?)
|
||||
(let ([src (clone clone-bitmap src)]
|
||||
[mask (and mask (clone clone-bitmap mask))])
|
||||
(record (lambda (dc) (send dc draw-bitmap src dx dy style color mask))))))
|
||||
(define/record (set-background [c clone-color convert-color unconvert-color]))
|
||||
|
||||
(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)
|
||||
(when (continue-recording?)
|
||||
(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))))))))
|
||||
(define/record (set-text-mode m))
|
||||
|
||||
(define/record (set-clipping-rect x y w h))
|
||||
|
||||
(define/record (clear))
|
||||
|
||||
(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/record (draw-lines [pts clone-points] [[x 0.0]] [[y 0.0]]))
|
||||
|
||||
(define/record (draw-polygon [pts clone-points] [[x 0.0]] [[y 0.0]] [[fill-style 'odd-even]]))
|
||||
|
||||
(define/record (draw-rectangle x y w h))
|
||||
|
||||
(define/record (draw-rounded-rectangle x y w h [[radius -0.25]]))
|
||||
|
||||
(define/record (draw-spline x1 y1 x2 y2 x3 y3))
|
||||
|
||||
(define/record (draw-path [path clone-path convert-path unconvert-path]
|
||||
[[x 0.0]] [[y 0.0]] [[fill-style 'odd-even]]))
|
||||
|
||||
(define/record (draw-text [s string->immutable-string] x y
|
||||
[[combine? #f]] [[offset 0]] [[angle 0.0]]))
|
||||
|
||||
(define/record (draw-bitmap [src clone-bitmap convert-bitmap unconvert-bitmap]
|
||||
dx dy [[style 'solid]]
|
||||
[[color black] clone-color convert-color unconvert-color]
|
||||
[[mask #f] clone-bitmap convert-bitmap unconvert-bitmap]))
|
||||
|
||||
(define/record (draw-bitmap-section [src clone-bitmap convert-bitmap unconvert-bitmap]
|
||||
dx dy sx sy sw sh [[style 'solid]]
|
||||
[[color black] clone-color convert-color unconvert-color]
|
||||
[[mask #f] clone-bitmap convert-bitmap unconvert-bitmap])))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define record-dc-backend%
|
||||
(class default-dc-backend%
|
||||
(init [[-width width] 640]
|
||||
[[-height height] 480])
|
||||
|
||||
(define-values (width height)
|
||||
(case-args
|
||||
(list -width -height)
|
||||
[([nonnegative-real? w]
|
||||
[nonnegative-real? h])
|
||||
(values w h)]
|
||||
(init-name 'record-dc%)))
|
||||
|
||||
(define/override (ok?) #t)
|
||||
|
||||
;; We need a cair context and surface to measure text:
|
||||
(define c (cairo_create (cairo_image_surface_create CAIRO_FORMAT_ARGB32 1 1)))
|
||||
(define/override (get-cr) c)
|
||||
|
||||
(def/override (get-size)
|
||||
(values (exact->inexact width)
|
||||
(exact->inexact height)))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define record-dc%
|
||||
(class (record-dc-mixin (dc-mixin record-dc-backend%))
|
||||
(inherit reset-recording
|
||||
get-recorded-command)
|
||||
|
||||
(define/public (get-recorded-procedure)
|
||||
(get-recorded-command #f))
|
||||
|
||||
(define/public (get-recorded-datum)
|
||||
(get-recorded-command #t))
|
||||
|
||||
(define/override (applies-to-default?) #f)
|
||||
|
||||
(super-new)
|
||||
(reset-recording)))
|
||||
|
||||
(define (recorded-datum->procedure d)
|
||||
(define procs (send (new record-dc%) record-unconvert d))
|
||||
(lambda (dc)
|
||||
(unless (dc . is-a? . dc<%>)
|
||||
(raise-type-error 'recorded-datum->procedure "dc<%> object" dc))
|
||||
;; save all the existing state:
|
||||
(define-values (ox oy) (send dc get-origin))
|
||||
(define-values (sx sy) (send dc get-scale))
|
||||
(define r (send dc get-rotation))
|
||||
(define m (send dc get-initial-matrix))
|
||||
(define p (send dc get-pen))
|
||||
(define b (send dc get-brush))
|
||||
(define s (send dc get-smoothing))
|
||||
(define f (send dc get-font))
|
||||
(define tm (send dc get-text-mode))
|
||||
(define a (send dc get-alpha))
|
||||
(define cr (send dc get-clipping-region))
|
||||
|
||||
(for ([proc (in-list procs)])
|
||||
(proc dc))
|
||||
|
||||
;; Restore the state:
|
||||
(send dc set-origin ox oy)
|
||||
(send dc set-scale sx sy)
|
||||
(send dc set-rotation r)
|
||||
(send dc set-initial-matrix m)
|
||||
(send dc do-set-pen! p)
|
||||
(send dc do-set-brush! b)
|
||||
(send dc set-font f)
|
||||
(send dc set-smoothing s)
|
||||
(send dc set-text-mode tm)
|
||||
(send dc set-alpha a)
|
||||
(send dc set-clipping-region cr)))
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ Drawing to a @racket[bitmap-dc%] with a color bitmap is guaranteed to
|
|||
|
||||
@defconstructor[([bitmap (or/c (is-a?/c bitmap%) #f)])]{
|
||||
|
||||
Creates a new memory DC. If @racket[bitmap] is not @racket[#f], it is
|
||||
Creates a new bitmap DC. If @racket[bitmap] is not @racket[#f], it is
|
||||
installed into the DC so that drawing commands on the DC draw to
|
||||
@racket[bitmap]. Otherwise, no bitmap is installed into the DC and
|
||||
@method[bitmap-dc% set-bitmap] must be called before any other method
|
||||
|
|
|
|||
|
|
@ -107,6 +107,11 @@ defaults @racket[kind] and @racket[complain-on-failure?] in a more
|
|||
useful way.}
|
||||
|
||||
|
||||
@defproc[(recorded-datum->procedure [datum any/c]) ((is-a?/c dc<%>) . -> . void?)]{
|
||||
|
||||
Converts a value from @xmethod[record-dc% get-recorded-datum] to a drawing procedure.}
|
||||
|
||||
|
||||
@defthing[the-brush-list (is-a?/c brush-list%)]{
|
||||
|
||||
See @racket[brush-list%].
|
||||
|
|
|
|||
|
|
@ -37,6 +37,7 @@ interface, and procedure bindings defined in this manual.}
|
|||
@include-section["post-script-dc-class.scrbl"]
|
||||
@include-section["ps-setup-class.scrbl"]
|
||||
@include-section["radial-gradient-class.scrbl"]
|
||||
@include-section["record-dc-class.scrbl"]
|
||||
@include-section["region-class.scrbl"]
|
||||
@include-section["svg-dc-class.scrbl"]
|
||||
@include-section["draw-funcs.scrbl"]
|
||||
|
|
|
|||
37
collects/scribblings/draw/record-dc-class.scrbl
Normal file
37
collects/scribblings/draw/record-dc-class.scrbl
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
#lang scribble/doc
|
||||
@(require "common.rkt")
|
||||
|
||||
@defclass/title[record-dc% object% (dc<%>)]{
|
||||
|
||||
A @racket[record-dc%] object records drawing actions for replay into
|
||||
another drawing context. The recorded drawing operations can be
|
||||
extracted as a procedure via @method[record-dc%
|
||||
get-recorded-procedure], or the actions can be extracted as a datum
|
||||
(that can be printed with @racket[write] and recreated with
|
||||
@racket[read]) via @method[record-dc% get-recorded-datum].
|
||||
|
||||
@defconstructor[([width (>=/c 0) 640]
|
||||
[height (>=/c 0) 480])]{
|
||||
|
||||
Creates a new recording DC. The optional @racket[width] and
|
||||
@racket[height] arguments determine the result of @method[dc<%>
|
||||
get-size] on the recording DC; the @racket[width] and
|
||||
@racket[height] arguments do not clip drawing.}
|
||||
|
||||
|
||||
@defmethod[(get-recorded-datum) any/c]{
|
||||
|
||||
Extracts a recorded drawing to a value that can be printed with
|
||||
@racket[write] and re-read with @racket[read]. Use
|
||||
@racket[recorded-datum->procedure] to convert the datum to a drawing
|
||||
procedure.}
|
||||
|
||||
|
||||
@defmethod[(get-recorded-procedure) ((is-a?/c dc<%>) . -> . void?)]{
|
||||
|
||||
Extracts a recorded drawing to a procedure that can be applied to
|
||||
another DC to replay the drawing commands to the given DC.
|
||||
|
||||
The @method[record-dc% get-recorded-procedure] method can be more
|
||||
efficient than composing @method[record-dc% get-recorded-datum] and
|
||||
@racket[recorded-datum->procedure].}}
|
||||
|
|
@ -220,6 +220,9 @@
|
|||
[clock-clip? #f]
|
||||
[do-clock #f]
|
||||
[use-bitmap? #f]
|
||||
[platform-bitmap? #f]
|
||||
[use-record? #f]
|
||||
[serialize-record? #f]
|
||||
[use-bad? #f]
|
||||
[depth-one? #f]
|
||||
[cyan? #f]
|
||||
|
|
@ -285,7 +288,11 @@
|
|||
[bm (if use-bitmap?
|
||||
(if use-bad?
|
||||
(make-object bitmap% "no such file")
|
||||
(make-object bitmap% (* xscale DRAW-WIDTH) (* yscale DRAW-HEIGHT) depth-one?))
|
||||
(let ([w (ceiling (* xscale DRAW-WIDTH))]
|
||||
[h (ceiling (* yscale DRAW-HEIGHT))])
|
||||
(if platform-bitmap?
|
||||
(make-platform-bitmap w h)
|
||||
(make-object bitmap% w h depth-one?))))
|
||||
#f)]
|
||||
[draw-series
|
||||
(lambda (dc pens pent penx size x y flevel last?)
|
||||
|
|
@ -996,7 +1003,17 @@
|
|||
(send dc draw-rectangle 187 310 20 20)
|
||||
(send dc set-pen p)))
|
||||
|
||||
(when (and last? (not (or kind (eq? dc can-dc)))
|
||||
(when (and last? use-record?)
|
||||
(if serialize-record?
|
||||
(let ()
|
||||
(define-values (i o) (make-pipe))
|
||||
(pretty-print (send dc get-recorded-datum))
|
||||
(write (send dc get-recorded-datum) o)
|
||||
((recorded-datum->procedure (read i)) can-dc))
|
||||
((send dc get-recorded-procedure) can-dc)))
|
||||
|
||||
(when (and last?
|
||||
(not (or kind (eq? dc can-dc)))
|
||||
(send mem-dc get-bitmap))
|
||||
(send can-dc draw-bitmap (send mem-dc get-bitmap) 0 0 'opaque)))
|
||||
|
||||
|
|
@ -1031,11 +1048,13 @@
|
|||
[as-eps (not page?)]
|
||||
[use-paper-bbox page?]))])])
|
||||
(and (send dc ok?) dc))
|
||||
(if (and use-bitmap?)
|
||||
(begin
|
||||
(send mem-dc set-bitmap bm)
|
||||
mem-dc)
|
||||
(get-dc)))])
|
||||
(if use-record?
|
||||
(make-object record-dc% (* xscale DRAW-WIDTH) (* yscale DRAW-HEIGHT))
|
||||
(if (and use-bitmap?)
|
||||
(begin
|
||||
(send mem-dc set-bitmap bm)
|
||||
mem-dc)
|
||||
(get-dc))))])
|
||||
(when dc
|
||||
(send dc start-doc "Draw Test")
|
||||
(send dc start-page)
|
||||
|
|
@ -1205,7 +1224,7 @@
|
|||
(unless (cond
|
||||
[kind #t]
|
||||
[use-bad? #t]
|
||||
[use-bitmap? (and (= w (* xscale DRAW-WIDTH)) (= h (* yscale DRAW-HEIGHT)))]
|
||||
[use-bitmap? (and (= w (ceiling (* xscale DRAW-WIDTH))) (= h (ceiling (* yscale DRAW-HEIGHT))))]
|
||||
[else (and (= w (* 2 DRAW-WIDTH)) (= h (* 2 DRAW-HEIGHT)))])
|
||||
(show-error 'x "wrong size reported by get-size: ~a ~a (not ~a)" w h
|
||||
(if use-bitmap?
|
||||
|
|
@ -1230,13 +1249,15 @@
|
|||
(super-new [parent parent][style '(hscroll vscroll)])
|
||||
(init-auto-scrollbars (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT) 0 0))
|
||||
vp)])
|
||||
(make-object radio-box% #f '("Canvas" "Pixmap" "Bitmap" "Bad") hp0
|
||||
(make-object choice% #f '("Canvas" "Pixmap" "Bitmap" "Platform" "Record" "Serialize" "Bad") hp0
|
||||
(lambda (self event)
|
||||
(set! use-bitmap? (< 0 (send self get-selection)))
|
||||
(set! depth-one? (< 1 (send self get-selection)))
|
||||
(set! use-bad? (< 2 (send self get-selection)))
|
||||
(send canvas refresh))
|
||||
'(horizontal))
|
||||
(set! platform-bitmap? (= 3 (send self get-selection)))
|
||||
(set! use-record? (<= 4 (send self get-selection) 5))
|
||||
(set! serialize-record? (= 5 (send self get-selection)))
|
||||
(set! use-bad? (< 5 (send self get-selection)))
|
||||
(send canvas refresh)))
|
||||
(make-object button% "PS" hp
|
||||
(lambda (self event)
|
||||
(send canvas on-paint 'ps)))
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@ mysterx: removed ActiveX support plus com-add-ref and
|
|||
com-ref-count
|
||||
racket/draw: treat a face as a Pango font description
|
||||
only when it contains a comma
|
||||
racket/draw: add record-dc%
|
||||
|
||||
Version 5.2.1.5
|
||||
Added racket/future to re-exports of racket
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user