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

...

Browse Source 
original commit: 9f11bc497c64c6979f772d4ef445892396ed9d0b
This commit is contained in:
Robby Findler 1998-12-12 03:30:55 +00:00
parent 68ef5dd718
commit 0e66be80c8
1 changed files with 8 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/framework/splash.ss
View File

@ -81,27 +81,26 @@
(send (get-dc) draw-bitmap bitmap 0 0))])
(sequence
(apply super-init args)))]
[(box1) (box 0.)]
[(box2) (box 0.)]
[(c-x-offset) 0]
[(c-y-offset) 0]
[(logo-canvas) (make-object canvas% frame)]
[(show-messages?) (let ([b (box 0)])
(if (get-resource "mred" "splashMessages" b)
(not (zero? (unbox b)))
#f))]
[(gauge) (make-object gauge% #f splash-max-width frame)]
[(logo-canvas) (make-object canvas% frame)]
[(h-panel) (make-object (if show-messages? horizontal-panel% vertical-panel%)
frame)]
[(gauge) (make-object gauge% #f splash-max-width h-panel '(vertical))]
[(v-panel) (make-object vertical-panel% h-panel)]
[(splash-messages)
(and show-messages?
(cons (make-object message% (format "Welcome to ~a" title) frame)
(cons (make-object message% (format "Welcome to ~a" title) v-panel)
(let loop ([n (- splash-max-depth 1)])
(cond
[(zero? n) null]
[else (cons (make-object message% "" frame)
[else (cons (make-object message% "" v-panel)
(loop (sub1 n)))]))))]
[(_) (begin
(send frame set-alignment 'left 'center)
(send v-panel set-alignment 'left 'top)
(send logo-canvas min-width (send bitmap get-width))
(send logo-canvas min-height (send bitmap get-height))
(send logo-canvas stretchable-width #f)