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

...

Browse Source 
original commit: 7fc74ec47b682da35065802912047d54060d2b3a
This commit is contained in:
Robby Findler 1998-12-03 21:05:40 +00:00
parent d3dd112c17
commit d94bb93e0b
3 changed files with 19 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/framework/text.ss
View File

@ -166,8 +166,8 @@
(invalidate-rectangles (append old-rectangles
range-rectangles))))]
[ranges null]
[pen (make-object pen% "BLACK" 0 'stipple)]
[brush (make-object brush% "black" 'stipple)])
[pen (make-object pen% "BLACK" 0 'solid)]
[brush (make-object brush% "black" 'solid)])
(public
;; the bitmap is used in b/w and the color is used in color.
[highlight-range
@ -200,7 +200,6 @@
(unbox b4)))])
(let* ([old-pen (send dc get-pen)]
[old-brush (send dc get-brush)]
[old-logical-function (send dc get-logical-function)]
[b/w-bitmap (rectangle-b/w-bitmap rectangle)]
[color (let* ([rc (rectangle-color rectangle)]
[tmpc (make-object color% 0 0 0)])
@ -225,17 +224,11 @@
(let/ec k
(cond
[(and before color)
(send pen set-style 'solid)
(send brush set-style 'solid)
(send pen set-colour color)
(send brush set-colour color)
(send dc set-logical-function 'copy)]
(send brush set-colour color)]
[(and (not before) (not color) b/w-bitmap)
(send pen set-stipple b/w-bitmap)
(send pen set-style 'stipple)
(send brush set-stipple b/w-bitmap)
(send brush set-style 'stipple)
(send dc set-logical-function 'and)]
(send brush set-stipple b/w-bitmap)]
[else (k (void))])
(send dc set-pen pen)
(send dc set-brush brush)
@ -244,7 +237,6 @@
(+ top dy)
width
height)
(send dc set-logical-function old-logical-function)
(send dc set-pen old-pen)
(send dc set-brush old-brush)))))
range-rectangles))])

3
collects/tests/framework/README
View File

@ -42,7 +42,8 @@ tests.
- frames: |# frame.ss #|
- canvases: |# canvas.ss #|
- edits: |# edit.ss #|
- texts: |# text.ss #|
- pasteboards: |# text.ss #|
- basic connections between classes

18
collects/tests/framework/canvas.ss
View File

@ -2,9 +2,17 @@
(test
name
(lambda (x) #t)
`(let ([f (make-object frame:basic%)]
[c (make-object ,class f)])
(send f show #t))))
(lambda ()
(send-sexp-to-mred
`(let* ([f (make-object frame:basic% "test canvas" #f 300 300)]
[c (make-object ,class (send f get-area-container))])
(send c set-editor (make-object text:basic%))
(send f show #t)))
(wait-for-frame "test canvas")
(send-sexp-to-mred
`(send (get-top-level-focus-window) show #f)))))
(test-creation 'canvas:wide-snip-mixin-creation '(canvas:wide-snip-mixin editor-canvas%))
(test-creation 'canvas:wide-snip%-creation 'canvas:wide-snip%)
(test-creation '(canvas:wide-snip-mixin editor-canvas%)
'canvas:wide-snip-mixin-creation)
(test-creation 'canvas:wide-snip%
'canvas:wide-snip%-creation)