fix drawing bugs and improve backward compatibility
This commit is contained in:
Matthew Flatt
parent
88606ae251
commit
dc00e22b85
|
|
@ -40,13 +40,14 @@
|
|||
(values (exact->inexact (send bm get-width))
|
||||
(exact->inexact (send bm get-height))))
|
||||
|
||||
(define last-y -1)
|
||||
(def/public (set-pixel [real? x][real? y][color% c])
|
||||
(let ([s (bytes 255 (color-red c) (color-green c) (color-blue c))])
|
||||
(set-argb-pixels x y 1 1 s)))
|
||||
|
||||
(def/public (get-pixel [real? x][real? y][color% c])
|
||||
(let ([b (make-bytes 4)])
|
||||
(get-argb-pixels x y 1 1)
|
||||
(get-argb-pixels x y 1 1 b)
|
||||
(send c set (bytes-ref b 1) (bytes-ref b 2) (bytes-ref b 3))
|
||||
#t))
|
||||
|
||||
|
|
|
|||
|
|
@ -113,6 +113,7 @@
|
|||
(let ([mask-bm
|
||||
(and s
|
||||
(not alpha?)
|
||||
(not b&w?)
|
||||
(let ([w (cairo_image_surface_get_width s)]
|
||||
[h (cairo_image_surface_get_height s)]
|
||||
[row-width (cairo_image_surface_get_stride s)]
|
||||
|
|
@ -522,13 +523,13 @@
|
|||
(cairo_surface_flush s)
|
||||
(let ([data (cairo_image_surface_get_data s)]
|
||||
[row-width (cairo_image_surface_get_stride s)])
|
||||
(let ([w (min (- width x) w)])
|
||||
(let ([w2 (+ x (min (- width x) w))])
|
||||
(for* ([j (in-range y (min (+ y h) height))])
|
||||
(let ([row (* j row-width)]
|
||||
[p (* 4 (+ x (* j w)))])
|
||||
(for ([i (in-range x w)])
|
||||
[p (* 4 (* (- j y) w))])
|
||||
(for ([i (in-range x w2)])
|
||||
(let* ([4i (* 4 i)]
|
||||
[pi (+ p 4i)]
|
||||
[pi (+ p (* 4 (- i x)))]
|
||||
[ri (+ row 4i)]
|
||||
[a (bytes-ref data (+ ri A))]
|
||||
[unmult (lambda (a v)
|
||||
|
|
@ -554,9 +555,9 @@
|
|||
(get-alphas-as-mask x y w h bstr)]
|
||||
[(and (not get-alpha?) (not alpha-channel?))
|
||||
;; For non-alpha mode or no mask; fill in 255s:
|
||||
(for ([j (in-range y (min (+ y h) height))])
|
||||
(for ([j (in-range 0 (min h (- height y)))])
|
||||
(let ([row (* j (* 4 w))])
|
||||
(for ([i (in-range x (min (+ x w) width))])
|
||||
(for ([i (in-range 0 (min w (- width x)))])
|
||||
(let ([p (+ (* 4 i) row)])
|
||||
(bytes-set! bstr p 255)))))]))
|
||||
|
||||
|
|
@ -576,14 +577,14 @@
|
|||
(cairo_surface_flush s)
|
||||
(let ([data (cairo_image_surface_get_data s)]
|
||||
[row-width (cairo_image_surface_get_stride s)])
|
||||
(let ([w (min (- width x) w)])
|
||||
(let ([w2 (+ x (min (- width x) w))])
|
||||
(for ([j (in-range y (min (+ y h) height))]
|
||||
[dj (in-naturals)])
|
||||
(let ([row (* j row-width)]
|
||||
[p (* 4 (* dj w))])
|
||||
(for ([i (in-range x w)])
|
||||
(for ([i (in-range x w2)])
|
||||
(let* ([4i (* 4 i)]
|
||||
[pi (+ p 4i)]
|
||||
[pi (+ p (* 4 (- i x)))]
|
||||
[ri (+ row 4i)])
|
||||
(if b&w?
|
||||
(let ([v (if (and (= (bytes-ref bstr (+ pi 1)) 255)
|
||||
|
|
@ -592,8 +593,8 @@
|
|||
255
|
||||
0)])
|
||||
(bytes-set! data (+ ri A) (- 255 v))
|
||||
(bytes-set! data (+ ri R) v)
|
||||
(bytes-set! data (+ ri G) v)
|
||||
(bytes-set! data (+ ri 1) v)
|
||||
(bytes-set! data (+ ri 2) v)
|
||||
(bytes-set! data (+ ri B) v))
|
||||
(begin
|
||||
(when alpha-channel?
|
||||
|
|
@ -647,14 +648,13 @@
|
|||
(let ([row (* j row-width)])
|
||||
(for ([i (in-range width)])
|
||||
(let ([q (+ row (* i 4))])
|
||||
(bytes-set! alpha-data
|
||||
(+ q A)
|
||||
(- 255
|
||||
(quotient
|
||||
(+ (+ (bytes-ref data (+ q 1))
|
||||
(bytes-ref data (+ q 2)))
|
||||
(bytes-ref data (+ q B)))
|
||||
3))))))))
|
||||
(let ([v (quotient
|
||||
(+ (+ (bytes-ref data (+ q 1))
|
||||
(bytes-ref data (+ q 2)))
|
||||
(bytes-ref data (+ q B)))
|
||||
3)])
|
||||
(bytes-set! alpha-data (+ q A) (- 255 v))))))))
|
||||
(cairo_surface_mark_dirty alpha-s)
|
||||
(set! alpha-s-up-to-date? #t))))
|
||||
|
||||
(define/public (transparent-white! s width height)
|
||||
|
|
|
|||
|
|
@ -457,7 +457,7 @@
|
|||
[else 0])))
|
||||
(cairo_set_line_cap cr
|
||||
(case (if ((send pen get-width) . <= . 1.0)
|
||||
'butt
|
||||
'round
|
||||
(send pen get-cap))
|
||||
[(butt) CAIRO_LINE_CAP_BUTT]
|
||||
[(round) CAIRO_LINE_CAP_ROUND]
|
||||
|
|
@ -516,24 +516,15 @@
|
|||
(draw-arc x y width height 0 2pi))
|
||||
|
||||
(def/public (draw-line [real? x1] [real? y1] [real? x2] [real? y2])
|
||||
(let-values ([(x1 y1 x2 y2)
|
||||
(if (and (eq? smoothing 'unsmoothed)
|
||||
(x2 . < . x1))
|
||||
(values x2 y2 x1 y1)
|
||||
(values x1 y1 x2 y2))])
|
||||
(let ([dot (if (and (= x1 x2) (= y1 y2))
|
||||
0.1
|
||||
0)])
|
||||
(with-cr
|
||||
(void)
|
||||
cr
|
||||
(cairo_new_path cr)
|
||||
(cairo_move_to cr (align-x x1) (align-y y1))
|
||||
(if #f ; (eq? smoothing 'unsmoothed)
|
||||
;; An unsmoothed line is supposed to hit the pixel to the
|
||||
;; lower right of the ending point. (We've revered the points
|
||||
;; above to ensure that the line goes left to right.)
|
||||
(if ((abs (- x2 x1)) . > . (abs (- y2 y1)))
|
||||
(cairo_line_to cr (+ (align-x x2) (sgn (- x2 x1))) (align-y y2))
|
||||
(cairo_line_to cr (align-x x2) (+ (align-y y2) (sgn (- y2 y1)))))
|
||||
(cairo_line_to cr (align-x x2) (align-y y2)))
|
||||
(cairo_line_to cr (+ (align-x x2) dot) (+ (align-y y2) dot))
|
||||
(draw cr #f #t))))
|
||||
|
||||
(def/public (draw-point [real? x] [real? y])
|
||||
|
|
@ -544,7 +535,7 @@
|
|||
(let ([x (align-x x)]
|
||||
[y (align-y y)])
|
||||
(cairo_move_to cr x y)
|
||||
(cairo_line_to cr x y)
|
||||
(cairo_line_to cr (+ 0.1 x) (+ 0.1 y))
|
||||
(draw cr #f #t))))
|
||||
|
||||
(def/public (draw-lines [(make-alts (make-list point%) list-of-pair-of-real?) pts]
|
||||
|
|
|
|||
|
|
@ -657,11 +657,11 @@
|
|||
(case mask-ex-mode
|
||||
[(plt plt-mask plt^plt mred^plt)
|
||||
(let* ([plt (get-plt)]
|
||||
[tmp-bm (make-object bitmap%
|
||||
(send mred-icon get-width)
|
||||
(send mred-icon get-height)
|
||||
#f)]
|
||||
[tmp-dc (make-object bitmap-dc% tmp-bm)])
|
||||
[ww (send mred-icon get-width)]
|
||||
[hh (send mred-icon get-height)]
|
||||
[tmp-bm (make-object bitmap% ww hh #f)]
|
||||
[tmp-dc (make-object bitmap-dc% tmp-bm)]
|
||||
[mask-bm tmp-bm])
|
||||
(send tmp-dc draw-bitmap plt
|
||||
(/ (- (send mred-icon get-width)
|
||||
(send plt get-width))
|
||||
|
|
@ -669,16 +669,33 @@
|
|||
(/ (- (send mred-icon get-height)
|
||||
(send plt get-height))
|
||||
2))
|
||||
(when (memq mask-ex-mode '(plt^plt mred^plt))
|
||||
;; Convert to grayscale
|
||||
(let ([s (make-bytes (* 4 ww hh))])
|
||||
(send tmp-bm get-argb-pixels 0 0 ww hh s)
|
||||
(for* ([i (in-range 0 ww)]
|
||||
[j (in-range 0 hh)])
|
||||
(let* ([p (* 4 (+ (* j ww) i))]
|
||||
[v (quotient (+ (bytes-ref s (+ p 1))
|
||||
(bytes-ref s (+ p 2))
|
||||
(bytes-ref s (+ p 3)))
|
||||
3)])
|
||||
(bytes-set! s (+ p 1) v)
|
||||
(bytes-set! s (+ p 2) v)
|
||||
(bytes-set! s (+ p 3) v)))
|
||||
(set! mask-bm (make-object bitmap% ww hh #f))
|
||||
(send tmp-dc set-bitmap mask-bm)
|
||||
(send tmp-dc set-argb-pixels 0 0 ww hh s)))
|
||||
(if (eq? mask-ex-mode 'mred^plt)
|
||||
(send dc draw-bitmap mred-icon x y
|
||||
'solid
|
||||
(send the-color-database find-color "BLACK")
|
||||
tmp-bm)
|
||||
mask-bm)
|
||||
(send dc draw-bitmap tmp-bm x y 'solid
|
||||
(send the-color-database find-color "BLACK")
|
||||
(cond
|
||||
[(eq? mask-ex-mode 'plt-mask) mred-icon]
|
||||
[(eq? mask-ex-mode 'plt^plt) tmp-bm]
|
||||
[(eq? mask-ex-mode 'plt^plt) mask-bm]
|
||||
[else #f]))))]
|
||||
[(mred^mred)
|
||||
(send dc draw-bitmap mred-icon x y
|
||||
|
|
@ -722,9 +739,7 @@
|
|||
(let ([start x])
|
||||
;; First three return icons:
|
||||
(do-one return 'solid black)
|
||||
(printf "HERE\n")
|
||||
(do-one return 'solid red)
|
||||
(printf "DONE\n")
|
||||
(do-one return 'opaque red)
|
||||
;; Next three, on a blue background
|
||||
(let ([end x]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user