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

.

Browse Source 
original commit: d60e7d60bdaaf1605beac6f5b7f9137f4dded8b6
This commit is contained in:
Matthew Flatt 1999-01-09 18:21:12 +00:00
parent 9fca3650db
commit 62eb7c0610
4 changed files with 111 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

114
collects/tests/mred/draw.ss
View File

@ -53,9 +53,8 @@
[hp2 hp]
[hp3 (make-object horizontal-pane% vp)]
[bb (make-object bitmap% (sys-path "bb.gif") 'gif)]
[return (let ([bm (make-object bitmap% (sys-path "return.xbm") 'xbm)]
[dc (make-object bitmap-dc%)])
(send dc set-bitmap bm)
[return (let* ([bm (make-object bitmap% (sys-path "return.xbm") 'xbm)]
[dc (make-object bitmap-dc% bm)])
(send dc draw-line 0 3 20 3)
(send dc set-bitmap #f)
bm)]
@ -310,51 +309,52 @@
(send dc set-brush b))))
(when last?
; Splines
(define op (send dc get-pen))
(define (draw-ess dx dy)
(send dc draw-spline
(+ dx 200) (+ dy 10)
(+ dx 218) (+ dy 12)
(+ dx 220) (+ dy 20))
(send dc draw-spline
(+ dx 220) (+ dy 20)
(+ dx 222) (+ dy 28)
(+ dx 240) (+ dy 30)))
(send dc set-pen pen0s)
(draw-ess 0 0)
(send dc set-pen (make-object pen% "RED" 0 'solid))
(draw-ess -2 2)
; Brush patterns:
(let ([pat-list (list 'bdiagonal-hatch
'crossdiag-hatch
'fdiagonal-hatch
'cross-hatch
'horizontal-hatch
'vertical-hatch)]
[b (make-object brush% "BLACK" 'solid)]
[ob (send dc get-brush)]
[obg (send dc get-background)]
[blue (make-object color% "BLUE")])
(let loop ([x 245][y 10][l pat-list])
(unless (null? l)
(send b set-color "BLACK")
(send b set-style (car l))
(send dc set-brush b)
(send dc draw-rectangle x y 20 20)
(send dc set-brush ob)
(send b set-color "GREEN")
(send dc set-brush b)
(send dc draw-rectangle (+ x 25) y 20 20)
(send dc set-background blue)
(send dc draw-rectangle (+ x 50) y 20 20)
(send dc set-background obg)
(send dc set-brush ob)
(loop x (+ y 25) (cdr l)))))
(send dc set-pen op)
(let ([op (send dc get-pen)])
; Splines
(define (draw-ess dx dy)
(send dc draw-spline
(+ dx 200) (+ dy 10)
(+ dx 218) (+ dy 12)
(+ dx 220) (+ dy 20))
(send dc draw-spline
(+ dx 220) (+ dy 20)
(+ dx 222) (+ dy 28)
(+ dx 240) (+ dy 30)))
(send dc set-pen pen0s)
(draw-ess 0 0)
(send dc set-pen (make-object pen% "RED" 0 'solid))
(draw-ess -2 2)
; Brush patterns:
(let ([pat-list (list 'bdiagonal-hatch
'crossdiag-hatch
'fdiagonal-hatch
'cross-hatch
'horizontal-hatch
'vertical-hatch)]
[b (make-object brush% "BLACK" 'solid)]
[ob (send dc get-brush)]
[obg (send dc get-background)]
[blue (make-object color% "BLUE")])
(let loop ([x 245][y 10][l pat-list])
(unless (null? l)
(send b set-color "BLACK")
(send b set-style (car l))
(send dc set-brush b)
(send dc draw-rectangle x y 20 20)
(send dc set-brush ob)
(send b set-color "GREEN")
(send dc set-brush b)
(send dc draw-rectangle (+ x 25) y 20 20)
(send dc set-background blue)
(send dc draw-rectangle (+ x 50) y 20 20)
(send dc set-background obg)
(send dc set-brush ob)
(loop x (+ y 25) (cdr l)))))
(send dc set-pen op))
; B&W 8x8 stipple:
(unless no-bitmaps?
(let ([bml (get-b&w-light-stipple)]
@ -400,6 +400,7 @@
(loop (cdr fam) (cdr stl) (cdr wgt) (cdr sze) x (+ y h))))))
(send dc set-pen save-pen)))
; Bitmap copying:
(when (and (not no-bitmaps?) last?)
(let ([x 5] [y 165])
(send dc draw-bitmap (get-icon) x y 'xor)
@ -418,11 +419,14 @@
mode color)
(set! x (+ x w 10))))
(printf "bad bitmap~n")))])
;; BB icon
(do-one bb 'solid black)
(let ([start x])
;; First three return icons:
(do-one return 'solid black)
(do-one return 'solid red)
(do-one return 'opaque red)
;; Next three, on a bluew background
(let ([end x]
[b (send dc get-brush)])
(send dc set-brush (make-object brush% "BLUE" 'solid))
@ -434,11 +438,27 @@
(do-one return 'solid red)
(do-one return 'opaque red)
(set! y (- y 18))))
;; Another BB icon, make sure color has no effect
(do-one bb 'solid red)
;; Another return, blacnk on red
(let ([bg (send dc get-background)])
(send dc set-background (send the-color-database find-color "BLACK"))
(do-one return 'opaque red)
(send dc set-background bg))
;; Return by drawing into color, copying color to monochrome, then
;; monochrome back oonto canvas:
(let* ([w (send return get-width)]
[h (send return get-height)]
[color (make-object bitmap% w h)]
[mono (make-object bitmap% w h #t)]
[cdc (make-object bitmap-dc% color)]
[mdc (make-object bitmap-dc% mono)])
(send cdc clear)
(send cdc draw-bitmap return 0 0)
(send mdc clear)
(send mdc draw-bitmap color 0 0)
(send dc draw-bitmap mono
(- x w 10) (+ y 18)))
(send dc set-pen pens))))
(when (and (not no-stipples?) last?)

21
collects/tests/mred/frame-steps.txt
View File

@ -8,12 +8,12 @@ names; they're essentially the same set of tests, but for different
sets of controls. There are just too many kinds of controls to fit in
one frame.
Note that the clock in the upper right of the "Test Selector" frame
should increment every second.
The clock in the upper right of the "Test Selector" frame should
increment every second.
The field of buttons at the bottom of the Selector frame open little
frames for testing individual control types in detail. Those frames
come with their own instructions.
The buttons at the bottom of the Selector frame open little frames for
testing individual control types in detail. Those frames come with
their own instructions.
Make XXX Frame
--------------
@ -55,13 +55,18 @@ Medium Frame should contain:
Text (a media-text)
initial & starting
The names on labels must match the above exactly (except that <>
indicates an image). Watch out for letters that are dropped or
&s that are dropped.
Make sure all the controls with moving parts work.
Tabbing and arrow keys should work correctly. The canvas in the bottom
middle area does not receive the focus via tabs in Big Frame, but it
does in Medium Frame. When it receives the focus via a tab, "Tab in"
is drawn inthe canvas; when the focus leaves the canvas for any reason
(tab out, mouse click somewhere else, etc.), "Tab in" is erased.
Window Resizing
---------------
@ -197,6 +202,10 @@ Combinations to try:
* Busy + Bull + Cross - everywhere changed
- Uncheck Busy and verify Bull + Cross
(that's enough)
Also, while the busy cursor is on, try creating a new Big/Medium Frame
and make sure that the busy cursor is active in the new frame and over
all controls in the new frame.
Popup Menus (Big Frame)
-----------

16
collects/tests/mred/item.ss
View File

@ -130,8 +130,9 @@
(define popup-test-canvas%
(class canvas% (objects names . args)
(inherit popup-menu get-dc)
(inherit popup-menu get-dc refresh)
(public
[tab-in? #f]
[last-m null]
[last-choice #f])
(override
@ -141,7 +142,9 @@
(send dc clear)
(send dc draw-text "Left: popup hide state" 0 0)
(send dc draw-text "Right: popup previous" 0 20)
(send dc draw-text (format "Last pick: ~s" last-choice) 0 40)))]
(send dc draw-text (format "Last pick: ~s" last-choice) 0 40)
(when tab-in?
(send dc draw-text "Tab in" 0 60))))]
[on-event
(lambda (e)
(if (send e button-down?)
@ -172,7 +175,12 @@
m)
last-m)])
(set! last-m m)
(popup-menu m (inexact->exact x) (inexact->exact y)))))])
(popup-menu m (inexact->exact x) (inexact->exact y)))))]
[on-tab-in (lambda () (set! tab-in? #t) (refresh))]
[on-focus (lambda (on?)
(when (and tab-in? (not on?))
(set! tab-in? #f)
(refresh)))])
(sequence
(apply super-init args))))
@ -489,7 +497,7 @@
; "text msg" "image msg"
"text")
cp2)])
(send canvas accept-tab-focus #t)
(add-focus-note f2 ep2)
(send f2 set-info ep2)

18
src/mred/wrap/mred.ss
View File

@ -746,7 +746,12 @@
(when (and (is-a? o wx-text-editor-canvas%)
(send o is-single-line?))
(let ([e (send o get-editor)])
(send e set-position 0 (send e last-position) #f #t 'local))))))))])
(as-exit
(lambda ()
(send e set-position 0 (send e last-position) #f #t 'local)))))
(when (or (is-a? o wx-canvas%)
(is-a? o wx-editor-canvas%))
(as-exit (lambda () (send o on-tab-in)))))))))])
(if (is-a? o wx:radio-box%)
(let ([n (send o number)]
[s (send o button-focus -1)]
@ -1409,6 +1414,7 @@
(private
[tabable? #f])
(public
[on-tab-in (lambda () (send (wx->mred this) on-tab-in))]
[get-tab-focus (lambda () tabable?)]
[set-tab-focus (lambda (v) (set! tabable? v))])
(override
@ -1474,6 +1480,7 @@
[(#\tab #\return escape) (not single-line-canvas?)]
[else (not meta?)]))])
(public
[on-tab-in (lambda () (send (wx->mred this) on-tab-in))]
[set-single-line (lambda () (set! single-line-canvas? #t))]
[is-single-line? (lambda () single-line-canvas?)]
[set-line-count (lambda (n)
@ -3247,6 +3254,7 @@
[on-event (lambda (e) (send wx do-on-event e))]
[on-paint (lambda () (when wx (send wx do-on-paint)))]
[on-scroll (lambda (e) (send wx do-on-scroll e))]
[on-tab-in (lambda () (void))]
[min-client-width (param (lambda () wx) 'min-client-width)]
[min-client-height (param (lambda () wx) 'min-client-height)]
@ -4585,6 +4593,14 @@
(check-instance 'unregister-collecting-blit canvas% 'canvas% #f canvas)
(wx:unregister-collecting-blit (mred->wx canvas))))
(define bitmap-dc%
(class wx:bitmap-dc% ([bm #f])
(inherit set-bitmap)
(sequence
(super-init)
(when bm
(set-bitmap bm)))))
(define (find-item-frame item)
(let loop ([i item])
(let ([p (send i get-parent)])