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

.

Browse Source 
original commit: 1cb49e6f33c4aea2f9140018749ab5c19caba0b9
This commit is contained in:
Matthew Flatt 2003-05-20 12:55:58 +00:00
parent b52ec6eda2
commit 2f10f9757f
2 changed files with 55 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
collects/mred/mred.ss
View File

@ -3438,11 +3438,13 @@
[l (and label
(make-object wx-message% #f proxy p label -1 -1 null))]
[c (make-object wx-text-editor-canvas% #f proxy this p
(if multi?
(if (memq 'hscroll style)
null
'(hide-hscroll))
'(hide-vscroll hide-hscroll)))])
(append
'(control-border)
(if multi?
(if (memq 'hscroll style)
null
'(hide-hscroll))
'(hide-vscroll hide-hscroll))))])
(sequence
(send c set-x-margin 2)
(send c set-y-margin 2)
@ -4704,6 +4706,10 @@
;-------------------- Canvas class constructions --------------------
(define canvas-default-size 20) ; a default size for canvases tht fits borders without losing client sizes
(define canvas-scroll-size 10)
(define canvas-control-border-extra (case (system-type)
[(windows) 2]
[else 0]))
(define canvas<%>
(interface (subwindow<%>)
@ -4750,7 +4756,7 @@
(sequence
(let ([cwho '(constructor canvas)])
(check-container-parent cwho parent)
(check-style cwho #f '(border hscroll vscroll gl deleted) style)
(check-style cwho #f '(border hscroll vscroll gl deleted control-border no-autoclear) style)
(check-callback cwho paint-callback)
(check-label-string/false cwho label)))
(public
@ -4826,9 +4832,10 @@
[wx #f])
(sequence
(super-init (lambda ()
(let ([ds (+ (if (memq 'border style)
4
0)
(let ([ds (+ (cond
[(memq 'control-border style) (+ 4 canvas-control-border-extra)]
[(memq 'border style) 4]
[else 0])
(if (or (memq 'vscroll style) (memq 'hscroll style))
canvas-default-size
1))])
@ -4861,7 +4868,7 @@
(let ([cwho '(constructor editor-canvas)])
(check-container-parent cwho parent)
(check-instance cwho internal-editor<%> "text% or pasteboard%" #t editor)
(check-style cwho #f '(hide-vscroll hide-hscroll no-vscroll no-hscroll deleted) style)
(check-style cwho #f '(hide-vscroll hide-hscroll no-vscroll no-hscroll deleted control-border) style)
(check-gauge-integer cwho scrolls-per-page)
(check-label-string/false cwho label)
(unless (eq? wheel-step no-val)
@ -4957,10 +4964,13 @@
[no-v? (or (memq 'no-hscroll style)
(memq 'hide-hscroll style))]
[get-ds (lambda (no-this? no-other?)
(cond
[(and no-this? no-other?) 14]
[no-this? canvas-default-size]
[else (+ 10 canvas-default-size)]))])
(+ (if (memq 'control-border style)
canvas-control-border-extra
0)
(cond
[(and no-this? no-other?) 14]
[no-this? canvas-default-size]
[else (+ canvas-scroll-size canvas-default-size)])))])
(set! wx (make-object wx-editor-canvas% this this
(mred->wx-container parent) -1 -1
(get-ds no-h? no-v?)

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

@ -546,7 +546,7 @@
(define fp (make-object vertical-panel% ip))
(define tp (make-object vertical-panel% fp))
(define tp (make-object group-box-panel% "Sub" fp))
(when initially-disabled?
(send tp enable #f))
@ -601,8 +601,8 @@
(basic-add-testers2 name control))
basic-add-testers2))
(define fp2 (make-object vertical-panel% ip2-0))
(define ip2 (make-object vertical-panel% fp2))
(define fp2 (make-object vertical-panel% ip2-0))
(define ip2 (make-object group-box-panel% "Sub" fp2))
(when initially-disabled?
(send ip2 enable #f))
@ -1717,6 +1717,31 @@
(send f create-status-line)
(send f show #t))
(define (no-clear-canvas-frame)
(define f (make-frame frame% "No-Clear Canvas Test" #f #f 250))
(define p (make-object vertical-panel% f))
(define c% (class canvas%
(inherit get-dc refresh)
(define/override (on-paint)
(let ([red (send the-brush-list find-or-create-brush "RED" 'solid)]
[blue (send the-brush-list find-or-create-brush "BLUE" 'solid)]
[dc (get-dc)])
(let loop ([x 0])
(unless (= x 300)
(send dc set-brush red)
(send dc draw-rectangle x 0 25 400)
(send dc set-brush blue)
(send dc draw-rectangle (+ x 25) 0 25 400)
(loop (+ x 50))))))
(define/override (on-event evt)
(when (send evt dragging?)
(refresh)))
(super-new)))
(new c% [parent p][style '(border)])
(new c% [parent p][style '(no-autoclear border)])
(send f show #t)
f)
(define (editor-canvas-oneline-frame)
(define f (make-frame frame% "x" #f 200 #f))
@ -2006,6 +2031,9 @@
(mkf '(vscroll) "V")
(mkf null "")
(make-object grow-box-spacer-pane% cnp))
(make-object button%
"Make No-Clear Canvas" cnp
(lambda (b e) (no-clear-canvas-frame)))
(define (choose-next radios)
(let loop ([l radios])