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

added stretchable-editor-snips

Browse Source 
original commit: 19ce29b34ee0fc6c9e4082c462e1cd51133c0be5
This commit is contained in:
Mike MacHenry 2003-12-16 22:05:58 +00:00
parent eda8f45e77
commit 82c83e1f83
11 changed files with 253 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/mrlib/private/aligned-pasteboard/aligned-editor-container.ss
View File

@ -11,8 +11,7 @@
(provide
aligned-editor-canvas%
aligned-editor-snip%
aligned-snip-mixin)
aligned-editor-snip%)
;; a canvas that can contain an aligned-pasteboard<%>
;; STATUS: When both min-width and min-height change the size of the canvas
@ -114,7 +113,10 @@
;; called to resize the snip
(rename [super-resize resize])
(define/override (resize width height)
(super-resize width height)
(super-resize width height))
(define/public (stretch width height)
(resize width height)
(let ([left (box 0)]
[top (box 0)]
[right (box 0)]
@ -192,7 +194,4 @@
(send ed realign w h))))
(super-new)))
;not-yet-implemented
(define aligned-snip-mixin (lambda (x) x))
)

15
collects/mrlib/private/aligned-pasteboard/alignment.ss
View File

@ -40,7 +40,8 @@
(provide/contract
(align ((symbols 'horizontal 'vertical)
positive? positive? (listof rect?)
. -> . (listof rect?))))
. -> . (listof rect?)))
(rect-print ((listof rect?) . -> . void?)))
;; align the rectangles within the given space
(define (align type width height rects)
@ -145,4 +146,16 @@
(begin
(set! n (sub1 n))
1))))
(define rect-print
(match-lambda
[() (void)]
[(($ rect
($ dim x width stretchable-width?)
($ dim y height stretchable-height?))
others ...)
(printf "(make-rect (make-dim ~s ~s ~s) (make-dim ~s ~s ~s))~n"
x width stretchable-width?
y height stretchable-height?)
(rect-print others)]))
)

22
collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss
View File

@ -7,24 +7,12 @@
(lib "etc.ss")
(lib "match.ss")
(lib "mred.ss" "mred")
"aligned-editor-container.ss"
"interface.ss"
"alignment.ss"
"snip-lib.ss"
"pasteboard-lib.ss")
(define f 0)
(define rect-print
(match-lambda
[() (void)]
[(($ rect
($ dim x width stretchable-width?)
($ dim y height stretchable-height?))
others ...)
(printf "(make-rect (make-dim ~s ~s ~s) (make-dim ~s ~s ~s))~n"
x width stretchable-width?
y height stretchable-height?)
(rect-print others)]))
(provide/contract (make-aligned-pasteboard ((symbols 'vertical 'horizontal) . -> . class?)))
;; mixin to add geometry management to pasteboard with the give type of alignement
@ -54,7 +42,7 @@
(dynamic-let ([ignore-resizing? true])
(for-each-snip
(lambda (s)
(if (is-a? s stretchable-snip<%>)
(if (is-a? s aligned-editor-snip%)
(send s set-aligned-min-sizes)))
(find-first-snip))
(set!-values (aligned-min-width aligned-min-height)
@ -103,10 +91,8 @@
($ dim x width stretchable-width?)
($ dim y height stretchable-height?)))
(move-to snip x y)
;; Maybe I don't need to resize it if it's aligned-pasteboard-parent<%> and only if it's
;; a stretchable snip.
(when (or stretchable-height? stretchable-width? (is-a? snip aligned-pasteboard-parent<%>))
(resize snip width height))]))
(when (is-a? snip stretchable-snip<%>)
(send snip stretch width height))]))
;;;;;;;;;;
;; Events

4
collects/mrlib/private/aligned-pasteboard/interface.ss
View File

@ -72,6 +72,10 @@
;; that do not implement stretchable-snip<%> will simply not be stretched.
(define stretchable-snip<%>
(interface ()
;; (positive? positive? . -> . void?)
;; called by the parent editor to stretch the snip to an specific size
stretch
;; get-aligned-min-width (-> positive?)
;; get the minimum width of the snip
get-aligned-min-width

112
collects/mrlib/private/aligned-pasteboard/stretchable-editor-snip.ss Normal file
View File

@ -0,0 +1,112 @@
(module stretchable-editor-snip mzscheme
(provide
stretchable-editor-snip%
stretchable-editor-snip-mixin)
(require
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "etc.ss")
"snip-lib.ss"
"interface.ss")
(define (stretchable-editor-snip-mixin super%)
(class* super% (stretchable-snip<%>)
(init
(stretchable-width true)
(stretchable-height true))
(field
(aligned-min-width 0)
(aligned-min-height 0)
(stretchable-width-field stretchable-width)
(stretchable-height-field stretchable-height))
(public (stretchable-width-method stretchable-width)
(stretchable-height-method stretchable-height))
;; stretchable-width (case-> (Boolean . -> . (void)) (-> Boolean))
;; get or set the stretchablity of the pasteboards width
(define stretchable-width-method
(case-lambda
[(value) (set! stretchable-width-field value)]
[() stretchable-width-field]))
;; stretchable-height (case-> (Boolean . -> .(void)) (-> Boolean))
;; get or set the stretchablity of the pasteboards height
(define stretchable-height-method
(case-lambda
[(value) (set! stretchable-height-field value)]
[() stretchable-height-field]))
(define/public (get-aligned-min-width) aligned-min-width)
(define/public (get-aligned-min-height) aligned-min-height)
(inherit get-margin get-editor get-admin)
(define/override (resize w h)
(set! aligned-min-width w)
(set! aligned-min-height h)
(super-resize w h))
(define/public (stretch w h)
(super-resize w h))
(rename [super-get-extent get-extent])
(define/override (get-extent dc x y w h descent space lspace rspace)
(super-get-extent dc x y w h descent space lspace rspace)
(when (is-a? (get-editor) text%)
(set-box! w (sub1 (unbox w))))
(go))
(define/override (set-min-width w)
;; account for margin !!!!!!
(send (get-editor) set-min-width w))
(define/override (set-min-height h)
;; account for margin !!!!!!
(send (get-editor) set-min-height h))
(rename [super-set-min-width set-min-width]
[super-set-min-height set-min-height])
(define/public (super-resize w h)
(let ((top (box 0))
(bot (box 0))
(lef (box 0))
(rit (box 0)))
(get-margin top bot lef rit)
(let ((w (max (- w (unbox lef) (unbox rit)) 0))
(h (max (- h (unbox top) (unbox bot)) 0))
(e (get-editor))
(a (get-admin)))
;; subtracting 1 from W seems to make it act more like the editor-snip
;; because the C code has a hack to sub1 to make it look better. I am not
;; sure if this change here is sound and works for every part of this
;; class.
(super-set-min-width w)
(super-set-min-height h)
(when a (send a resized this #t)))))
;; call this from within get extent and use the values it produces by subtracting the
;; margin instead of calling the editors get-extent and adding the margin.
(define (go)
(let ([w (box 0)]
[h (box 0)]
(top (box 0))
(bot (box 0))
(lef (box 0))
(rit (box 0)))
(get-margin top bot lef rit)
(send (get-editor) get-extent w h)
(set! aligned-min-width (+ (unbox w) (unbox lef) (unbox rit)))
(set! aligned-min-height (+ (unbox h) (unbox top) (unbox rit)))))
(super-new)
(inherit get-min-width get-min-height)
(set-min-width (get-min-width))
(set-min-height (get-min-height))))
(define stretchable-editor-snip%
(stretchable-editor-snip-mixin
editor-snip%)))

16
collects/mrlib/private/aligned-pasteboard/tests/example-min.ss Normal file
View File

@ -0,0 +1,16 @@
(require
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "etc.ss")
"../aligned-pasteboard.ss"
"../aligned-editor-container.ss")
(define f (new frame% (label "") (width 400) (height 400)))
(define e (new horizontal-pasteboard%))
(define c (new aligned-editor-canvas% (parent f) (editor e)))
(define vp1 (new vertical-pasteboard%))
(define ae-snip1 (new aligned-editor-snip% (editor vp1)))
(define t-snip1 (new editor-snip% (editor (new text%))))
(send e insert ae-snip1 false)
(send vp1 insert t-snip1 false)
(send f show true)

13
collects/mrlib/private/aligned-pasteboard/tests/minimal.ss
View File

@ -2,21 +2,12 @@
"../aligned-editor-container.ss"
"../aligned-pasteboard.ss")
(define my-string-snip%
(class string-snip%
(init-field label)
(rename [super-size-cache-invalid size-cache-invalid])
(define/override (size-cache-invalid)
(mytrace size-cache-invalid ()
(super-size-cache-invalid)))
(super-make-object label)))
(define f (new frame% (label "test") (width 200) (height 200)))
(define e (new vertical-pasteboard%))
(define c (new aligned-editor-canvas% (editor e) (parent f)))
(define pb (new vertical-pasteboard%))
(define s (new aligned-editor-snip% (editor pb) (stretchable-height #f) (stretchable-width #f)))
(send pb insert (new my-string-snip% (label "Long snip")))
(send pb insert (new my-string-snip% (label "Longer snip")))
(send pb insert (make-object string-snip% "Long snip"))
(send pb insert (make-object string-snip% "Longer snip"))
(send e insert s)
(send f show #t)

40
collects/mrlib/private/aligned-pasteboard/tests/more-tests-min-stretchable.ss Normal file
View File

@ -0,0 +1,40 @@
(require
"../aligned-editor-container.ss"
"../aligned-pasteboard.ss")
(define editor (new vertical-pasteboard%))
(define pb (new horizontal-pasteboard%))
(send* pb
(insert (make-object string-snip% "Call") #f)
(insert (new editor-snip% (editor (new text%))) #f))
(send editor insert (new aligned-editor-snip% (editor pb)))
(define f (new frame% (label "more-test-jacob") (width 200) (height 200)))
(define e (new vertical-pasteboard%))
(define c (new aligned-editor-canvas% (editor e) (parent f)))
(define t (new aligned-editor-snip%
(editor editor)))
(send e insert t)
(send f show #t)
;;;;;;;;;;
;; exploration
(require "../snip-lib.ss")
(define t-e (send t get-editor))
(send t-e get-aligned-min-width)
(send t get-aligned-min-width)
(define fs (send t-e find-first-snip))
(define fs (send t-e find-first-snip))
(define fs-e (send fs get-editor))
(send fs-e find-first-snip)
(send fs-e get-aligned-min-width)
(send fs get-aligned-min-width)
(define (margin snip)
(let ([left (box 0)]
[top (box 0)]
[right (box 0)]
[bottom (box 0)])
(send snip get-margin left top right bottom)
(list (cons 'left (unbox left))
(cons 'right (unbox right))
(cons 'top (unbox top))
(cons 'bottom (unbox bottom)))))

25
collects/mrlib/private/aligned-pasteboard/tests/stretchable-editor-snip-test-min.ss Normal file
View File

@ -0,0 +1,25 @@
(require
"../aligned-pasteboard.ss"
"../aligned-editor-container.ss"
"../stretchable-editor-snip.ss"
"../snip-lib.ss")
(define f (new frame% (label "") (width 500) (height 500)))
(define e (new vertical-pasteboard%))
(define c (new aligned-editor-canvas% (parent f) (editor e)))
(define pb (new vertical-pasteboard%))
(define aes (new aligned-editor-snip%
(editor pb)
(stretchable-width #f)
(stretchable-height #f)))
(define t2 (new text%))
(define ses (new stretchable-editor-snip%
(editor t2)
(min-width 100)
(stretchable-width #t)
(stretchable-height #f)))
(send e insert aes)
(send pb insert ses)
(send f show #t)

30
collects/mrlib/private/aligned-pasteboard/tests/stretchable-editor-snip-test.ss Normal file
View File

@ -0,0 +1,30 @@
(require
"../aligned-pasteboard.ss"
"../aligned-editor-container.ss"
"../stretchable-editor-snip.ss"
"../snip-lib.ss")
(define f (new frame% (label "") (width 500) (height 500)))
(define e (new vertical-pasteboard%))
(define c (new aligned-editor-canvas% (parent f) (editor e)))
(define pb (new vertical-pasteboard%))
(define aes (new aligned-editor-snip%
(editor pb)
(stretchable-width #f)
(stretchable-height #f)))
(define t1 (new text%))
(define es (new editor-snip% (editor t1)))
(define t2 (new text%))
(define ses (new stretchable-editor-snip%
(editor t2)
(stretchable-width #t)
(stretchable-height #f)))
(send t1 insert "String")
(send e insert aes)
(send pb insert es)
(send pb insert ses)
(send f show #t)
(equal? (snip-width es) (snip-width ses))

3
collects/mrlib/private/aligned-pasteboard/tests/test-snip-lib.ss
View File

@ -1,6 +1,5 @@
(require
(lib "etc.ss")
(lib "devel.ss" "mike")
(lib "class.ss")
(lib "mred.ss" "mred")
"../snip-lib.ss"
@ -205,4 +204,4 @@
(send frame show false)
)
(printf "tests done~n")
(printf "tests done~n")