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

removed crashing bug from copy/paste but there are still problems

Browse Source 
svn: r5577
This commit is contained in:
Robby Findler 2007-02-08 23:33:16 +00:00
parent 276cd746df
commit ad634b20c5
1 changed files with 24 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
collects/texpict/pict-value-snip.ss
View File

@ -110,15 +110,20 @@ the user has to move the mouse first.
(let ([w (inexact->exact (ceiling (pict-width pict)))]
[h (inexact->exact (ceiling (pict-height pict)))])
(send in put h)
(let* ([bm (make-object bitmap% w h)]
[str (make-bytes (* w h 4))]
[bdc (make-object bitmap-dc% bm)])
(send bdc clear)
(send bdc set-smoothing 'aligned)
(pict-drawer bdc 0 0)
(send bdc get-argb-pixels 0 0 w h str)
(send bdc set-bitmap #f)
(send in put (+ 1 (bytes-length str)) str))))
(cond
[(or (= w 0)
(= h 0))
(send in put 1 #"")]
[else
(let* ([bm (make-object bitmap% w h)]
[str (make-bytes (* w h 4))]
[bdc (make-object bitmap-dc% bm)])
(send bdc clear)
(send bdc set-smoothing 'aligned)
(pict-drawer bdc 0 0)
(send bdc get-argb-pixels 0 0 w h str)
(send bdc set-bitmap #f)
(send in put (+ 1 (bytes-length str)) str))])))
(super-new)
(inherit set-snipclass set-flags get-flags)
@ -136,13 +141,16 @@ the user has to move the mouse first.
(cond
[(and (number? h)
(bytes? bitmap-bstr)
(zero? (modulo (bytes-length bitmap-bstr) (* 4 h))))
(let* ([w (quotient (bytes-length bitmap-bstr) (* 4 h))]
[bm (make-object bitmap% w h)]
[bdc (make-object bitmap-dc% bm)])
(send bdc set-argb-pixels 0 0 w h bitmap-bstr)
(send bdc set-bitmap #f)
(bitmap bm))]
(or (zero? h)
(zero? (modulo (bytes-length bitmap-bstr) (* 4 h)))))
(if (zero? h)
(blank)
(let* ([w (quotient (bytes-length bitmap-bstr) (* 4 h))]
[bm (make-object bitmap% w h)]
[bdc (make-object bitmap-dc% bm)])
(send bdc set-argb-pixels 0 0 w h bitmap-bstr)
(send bdc set-bitmap #f)
(bitmap bm)))]
[else (x-out (ellipse 10 10))])))
(new pict-value-snip% (pict pict)))
(super-new)))