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

.

Browse Source 
original commit: ebfed17cbc32f1b8651557e202c3a84731231467
This commit is contained in:
Matthew Flatt 1998-11-12 18:15:22 +00:00
parent a4e59a2237
commit 0b4f4c0b1a
3 changed files with 57 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/tests/mred/draw-info.txt
View File

@ -28,6 +28,10 @@ The drawing area should have the following features:
be black for the left colum, and green for the remaining two
columns.
Under the three columns of boxes, a black box should be filled with
an 25% black B&W bitmap, and a red box frame should be draw with a
50% red stipple.
The drawings under "0 x 0" and "1 x 1" should look nearly the same:
TopLeft: h-line should be left-aligned with box below it, but

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

@ -36,6 +36,16 @@
(make-object point% 0 120)
(make-object point% 60 60)))
(define (get-b&w-light-stipple)
(make-object bitmap%
(list->string (map integer->char '(#x88 0 #x22 0 #x88 0 #x22 0)))
8 8))
(define (get-b&w-half-stipple)
(make-object bitmap%
(list->string (map integer->char '(#xcc #x33 #xcc #x33 #xcc #x33 #xcc #x33)))
8 8))
(let* ([f (make-object frame% "Graphics Test" #f 300 450)]
[vp (make-object vertical-panel% f)]
[hp0 (make-object horizontal-panel% vp)]
@ -343,8 +353,29 @@
(send dc set-brush ob)
(loop x (+ y 25) (cdr l)))))
(send dc set-pen op))
(send dc set-pen op)
; B&W 8x8 stipple:
(unless no-bitmaps?
(let ([bml (get-b&w-light-stipple)]
[bmh (get-b&w-half-stipple)]
[orig-b (send dc get-brush)]
[orig-pen (send dc get-pen)])
(send dc set-brush brusht)
(send dc set-pen pen1s)
(send dc draw-rectangle 244 164 18 18)
(send dc draw-bitmap bml 245 165)
(send dc draw-bitmap bml 245 173)
(send dc draw-bitmap bml 253 165)
(send dc draw-bitmap bml 253 173)
(let ([p (make-object pen% "RED" 1 'solid)])
(send p set-stipple bmh)
(send dc set-pen p)
(send dc draw-rectangle 270 164 18 18))
(send dc set-brush orig-b)
(send dc set-pen orig-pen))))
(when (and (not no-bitmaps?) last?)
(let ([x 5] [y 165])

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

@ -3,6 +3,7 @@
(define my-txt #f)
(define my-lb #f)
(define noisy? #f)
(define special-font (send the-font-list find-or-create-font
20 'decorative
@ -75,6 +76,19 @@
(or (and m? (send cm get-value))
(and (not m?) (send ck get-value)))))))
(define (add-enter/leave-note frame panel)
(define m (make-object message% "enter: ??????????????????????????????" panel))
(lambda (win e)
(when (memq (send e get-event-type) '(enter leave))
(let ([s (format "~a: ~a"
(send e get-event-type)
(let ([l (send win get-label)])
(if (not l)
win
l)))])
(when noisy? (printf "~a~n" s))
(send m set-label s)))))
(define (add-cursors frame panel ctls)
(let ([old #f]
[f-old #f]
@ -174,10 +188,13 @@
(define active-frame%
(class-asi frame%
(private (pre-on void))
(private
[pre-on void]
[el void])
(rename [super-on-subwindow-event on-subwindow-event]
[super-on-subwindow-char on-subwindow-char])
(override [on-subwindow-event (lambda args
(apply el args)
(or (apply pre-on args)
(apply super-on-subwindow-event args)))]
[on-subwindow-char (lambda args
@ -187,7 +204,8 @@
[on-size (lambda (x y) (printf "sized: ~a ~a~n" x y))])
(public [set-info
(lambda (ep)
(set! pre-on (add-pre-note this ep)))])))
(set! pre-on (add-pre-note this ep))
(set! el (add-enter/leave-note this ep)))])))
(define (make-ctls ip cp lp add-testers ep radio-h? label-h? null-label? stretchy?)
@ -1561,7 +1579,7 @@
(make-object radio-box% "Label Font" '("Normal" "Big")
p1 void))
(define button-font-radio
(make-object radio-box% "Button Font" '("Normal" "Big")
(make-object radio-box% "Control Font" '("Normal" "Big")
p1 void))
(define next-button
(make-next-button p2 (list radio-h-radio label-h-radio label-null-radio