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

...

Browse Source 
original commit: d407398428e3d3afc4b089877b0471ff0fe19631
This commit is contained in:
Mike MacHenry 2004-08-10 23:19:54 +00:00
parent 721784aa77
commit 7bae134a96
7 changed files with 174 additions and 148 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/embedded-gui/embedded-gui.ss
View File

@ -10,7 +10,8 @@
"private/tabbable-text.ss"
"private/fixed-width-label-snip.ss"
"private/grey-editor.ss"
"private/verthoriz-alignment.ss")
"private/verthoriz-alignment.ss"
"private/snip-wrapper.ss")
(provide
(all-from "private/grid-alignment.ss")
@ -22,5 +23,6 @@
(all-from "private/tabbable-text.ss")
(all-from "private/fixed-width-label-snip.ss")
(all-from "private/grey-editor.ss")
(all-from "private/verthoriz-alignment.ss"))
(all-from "private/verthoriz-alignment.ss")
(all-from "private/snip-wrapper.ss"))
)

75
collects/embedded-gui/private/aligned-pasteboard.ss
View File

@ -1,3 +1,9 @@
#| Note: It might be a good idea to override insert with an error so that people don't
insert or delete from the pasteboard without using the alignment<%>. Then the alignments
could go through a different interface for inserting the snips that would call
super-insert.
|#
(module aligned-pasteboard mzscheme
(provide aligned-pasteboard%)
@ -6,72 +12,66 @@
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "etc.ss")
(lib "list.ss")
(lib "match.ss")
(prefix a: "alignment.ss")
(lib "click-forwarding-editor.ss" "mrlib")
"on-show-pasteboard.ss"
"really-resized-pasteboard.ss"
"interface.ss"
"snip-lib.ss"
"locked-pasteboard.ss"
"verthoriz-alignment.ss"
"suppress-modify-editor.ss")
(require
(lib "print-debug.ss" "mike-lib"))
(define aligned-pasteboard%
(class (click-forwarding-editor-mixin
(on-show-pasteboard-mixin
(class* (click-forwarding-editor-mixin
(on-show-pasteboard-mixin
(suppress-modify-editor-mixin
(locked-pasteboard-mixin
(really-resized-pasteboard-mixin pasteboard%)))))
(alignment-parent<%>)
(inherit begin-edit-sequence end-edit-sequence
get-max-view-size refresh-delayed?)
(init align)
(field
[alignment (new (case align
[(horizontal) horizontal-alignment%]
[(vertical) vertical-alignment%]))]
[alignment false]
[lock-alignment? false]
[needs-alignment? false])
(define/public (get-alignment) alignment)
;;;;;;;;;;
;; alignment-parent<%>
#|
snip : snip% object
before : snip% object or #f
x : real number
y : real number
|#
(rename [super-after-insert after-insert])
(define/override (after-insert snip before x y)
(super-after-insert snip before x y)
(realign))
#;(-> (is-a?/c pasteboard%))
;; The pasteboard that this alignment is being displayed to
(define/public (get-pasteboard) this)
#|
snip : snip% object
|#
(rename [super-after-delete after-delete])
(define/override (after-delete snip)
(super-after-delete snip)
(realign))
#;((is-a?/c alignment<%>) . -> . void?)
;; Set the given alignment as a the child
(define/public (add-child child)
(if alignment
(error 'add-child "There may be only one alignment<%> of a pasteboard")
(set! alignment child)))
#|
snip : snip% object
|#
#;(-> boolean?)
;; True if the alignment is being shown (accounting for its parent being shown)
;; NOTE: Pasteboards are always shown and have no show/hide state.
(define/public (is-shown?) true)
#;((is-a?/c snip%) . -> . void?)
;; Called when a snip in the pasteboard changes its size
;; Overriden because the layout will change when a snip gets bigger.
(rename [super-really-resized really-resized])
(define/override (really-resized snip)
(super-really-resized snip)
(realign))
#;(-> void)
;; Called when the pasteboard is first shown.
;; Overriden because I need to know when the snips have their size to lay them out.
(rename [super-on-show on-show])
(define/override (on-show)
(realign)
(super-on-show))
#;(boolean? . -> . void?)
;; Locks the pasteboard so that all alignment requests are delayed until after it's done.
(define/public (lock-alignment lock?)
(set! lock-alignment? lock?)
(when (and needs-alignment? (not lock-alignment?))
@ -80,6 +80,8 @@
(begin-edit-sequence)
(end-edit-sequence)))
#;(-> void?)
;; Realigns the snips in the pasteboard according to the alignment tree.
(define/public (realign)
(if lock-alignment?
(set! needs-alignment? true)
@ -91,6 +93,5 @@
(send alignment align 0 0 width height)
(set! needs-alignment? false))))))
(super-new)
(send alignment set-pasteboard this)))
(super-new)))
)

3
collects/embedded-gui/private/grid-alignment.ss
View File

@ -17,8 +17,9 @@
(provide grid-alignment%)
;; totally broken and not up to date with last revision
(define grid-alignment%
(class* object% (alignment<%>)
(class* object% (#;alignment<%>)
(init-field
columns
(parent false))

26
collects/embedded-gui/private/interface.ss
View File

@ -3,7 +3,8 @@
(require (lib "class.ss"))
(provide stretchable-snip<%>
alignment<%>)
alignment<%>
alignment-parent<%>)
(define alignment<%>
(interface ()
@ -33,7 +34,28 @@
#;(boolean? . -> . void)
;; Tells the alignment to show or hide its children
show))
show/hide
#;(boolean? . -> . void)
;; Tells the alignment that its show state is the given value
;; and it should show or hide its children accordingly.
show
))
(define alignment-parent<%>
(interface ()
#;(-> (is-a?/c pasteboard%))
;; The pasteboard that this alignment is being displayed to
get-pasteboard
#;((is-a?/c alignment<%>) . -> . void?)
;; Add the given alignment as a child
add-child
#;(-> boolean?)
;; True if the alignment is being shown (accounting for its parent being shown)
is-shown?
))
#| the interface that must be implemented by a class to be inserted into an
aligned-pasteboard<%> and be stretched and shrunk according to the geometry managment.

22
collects/embedded-gui/private/tests/alignment-test.ss
View File

@ -2,27 +2,33 @@
(lib "class.ss")
(lib "etc.ss")
(lib "mred.ss" "mred")
(lib "print-debug.ss" "mike-lib")
"../stretchable-editor-snip.ss"
"../verthoriz-alignment.ss"
"../aligned-pasteboard.ss"
"../grid-alignment.ss"
"../snip-wrapper.ss")
(require "../snip-lib.ss")
(define f (new frame% (label "f") (height 500) (width 500)))
(send f show true)
(define a1 (new aligned-pasteboard%))
(define c (new editor-canvas% (editor a1) (parent f)))
(define p (new aligned-pasteboard%))
(define c (new editor-canvas% (editor p) (parent f)))
(define a1 (new vertical-alignment% (parent p)))
(define a2 (new horizontal-alignment% (parent a1)))
(define a3 (new horizontal-alignment% (parent a1)))
;(define a3 (new horizontal-alignment% (parent a1)))
(new snip-wrapper%
(snip (make-object string-snip% "One"))
(parent a2))
#|
(new snip-wrapper%
(snip (make-object string-snip% "Two"))
(parent a2))
(send a1 dump-sizes)
(new snip-wrapper%
(snip (make-object string-snip% "Three"))
(parent a3))
(send f show true)
(send a1 dump-sizes)
(new snip-wrapper%
(snip (make-object string-snip% "Three"))
(parent a3))
|#

4
collects/embedded-gui/private/tests/not-stetching.ss
View File

@ -10,7 +10,7 @@
(lib "verthoriz-alignment.ss" "embedded-gui"))
(define traced-ses%
(override/trace stretchable-editor-snip%
#;(override/trace stretchable-editor-snip%
(stretch
get-aligned-min-width
get-aligned-min-height
@ -28,4 +28,4 @@
(send main add (make-object string-snip% "super duper very long snip"))
(send e insert j)
(send f show true)
)
)

186
collects/embedded-gui/private/verthoriz-alignment.ss
View File

@ -17,99 +17,26 @@
vertical-alignment%)
(define (vert/horiz-alignment type)
(class* object% (alignment<%>)
(class* object% (alignment<%> alignment-parent<%>)
(init-field
[parent false]
[show? true])
(init-field parent [show? true])
(field
[pasteboard false]
[pasteboard (send parent get-pasteboard)]
[children empty]
[min-width 0]
[min-height 0])
;; STATUS: This function (through lock-alignment false) invokes a call
;; to realign of the pasteboard even when this alignment has show? = false
;; so the call is not needed.
(define/public (add child)
(set! children (append children (list child)))
(send pasteboard lock-alignment true)
(cond
[(is-a? child snip%)
(when (get-show?)
(send pasteboard insert child false))]
[(is-a? child alignment<%>)
(send child set-pasteboard pasteboard)])
(send pasteboard lock-alignment false))
(define/public (get-min-width)
(if (get-show?) min-width 0))
(define/public (get-min-height)
(if (get-show?) min-height 0))
(define/public (set-pasteboard pb) (set! pasteboard pb))
(define/public (stretchable-width?) true)
(define/public (stretchable-height?) true)
#;(boolean? . -> . void?)
;; Shows or hides the alignment
(define/public (show bool)
(set! show? bool)
(when (parent-show?)
(send pasteboard lock-alignment true)
(show/hide-snips show?)
(send pasteboard lock-alignment false)))
#;(boolean? . -> . void?)
;; Inserts or deletes all the snips in the tree.
(define/public (show/hide-snips bool)
(when (boolean=? show? bool)
(for-each (show/hide-child bool) children)))
(define ((show/hide-child show?) child)
(if (is-a? child alignment<%>)
(send child show/hide-snips show?)
(if show?
(send pasteboard insert child)
(send pasteboard release-snip child))))
(define/public (get-show?)
(and show? (parent-show?)))
(define (parent-show?)
(if (and parent (is-a? parent alignment<%>))
(send parent get-show?)
true))
(define/public (align x-offset y-offset width height)
(define move/resize
(match-lambda*
[(child ($ a:rect
($ a:dim x w stretchable-width?)
($ a:dim y h stretchable-height?)))
(let ([global-x (+ x x-offset)]
[global-y (+ y y-offset)])
(cond
[(is-a? child snip%)
(send pasteboard move-to child global-x global-y)
(when (or stretchable-width? stretchable-height?)
(send child stretch w h))]
[(is-a? child alignment<%>)
(send child align global-x global-y w h)]))]))
(when (and (get-show?) (not (empty? children)))
(for-each move/resize
children
(a:align type width height
(map build-rect children)))))
;;;;;;;;;;
;; alignment<%>
#;(-> void?)
;; Tells the alignment that its sizes should be calculated
(define/public (set-min-sizes)
(when show?
(for-each
(lambda (child)
(when (is-a? child alignment<%>)
(send child set-min-sizes)))
(send child set-min-sizes))
children)
(let-values ([(x-accum y-accum)
(if (symbol=? type 'vertical)
@ -117,31 +44,98 @@
(values + vacuous-max))])
(set! min-width
(apply x-accum
(map child-width
(map (lambda (c) (send c get-min-width))
children)))
(set! min-height
(apply y-accum
(map child-height
(map (lambda (c) (send c get-min-height))
children))))))
#;(nonnegative? nonnegative? nonnegative? nonnegative? . -> . void?)
;; Tells the alignment to align its children on the pasteboard in the given rectangle
(define/public (align x-offset y-offset width height)
(define move/resize
(match-lambda*
[(child ($ a:rect ($ a:dim x w _) ($ a:dim y h _)))
(send child align (+ x x-offset) (+ y y-offset) w h)]))
(when (and (is-shown?)
(not (empty? children))
(not (zero? width)) ; this should be handled by align later
(not (zero? height))) ; this one too
(for-each move/resize
children
(a:align type width height
(map build-rect children)))))
#;(-> nonnegative?)
;; The minimum width this alignment must be
(define/public (get-min-width)
(if (is-shown?) min-width 0))
#;(-> nonnegative?)
;; The minimum height this alignment must be
(define/public (get-min-height)
(if (is-shown?) min-height 0))
#;(-> boolean?)
;; True if the alignment can be stretched in the x dimension
(define/public (stretchable-width?) true)
#;(-> boolean?)
;; True if the alignment can be stretched in the y dimension
(define/public (stretchable-height?) true)
#;(boolean? . -> . void)
;; Tells the alignment to show or hide its children
(define/public (show/hide bool)
(when show? (show/hide-children bool)))
#;(boolean? . -> . void)
;; Tells the alignment that its show state is the given value
;; and it should show or hide its children accordingly.
(define/public (show bool)
(set! show? bool)
(show/hide-children bool))
;;;;;;;;;;
;; alignment-parent<%>
#;(-> (is-a?/c pasteboard%))
;; The pasteboard that this alignment is being displayed to
(define/public (get-pasteboard) pasteboard)
#;((is-a?/c alignment<%>) . -> . void?)
;; Add the given alignment as a child
(define/public (add-child child)
(set! children (append children (list child))))
#;(-> boolean?)
;; True if the alignment is being shown (accounting for its parent being shown)
(define/public (is-shown?)
(and show? (send parent is-shown?)))
;;;;;;;;;;
;; helpers
#;(boolean? . -> . void?)
;; Shows or hides the children
(define/private (show/hide-children bool)
(send pasteboard lock-alignment true)
(for-each (lambda (c) (send c show/hide bool)) children)
(send pasteboard lock-alignment false))
(super-new)
;; NOTE: Try to figure out how it's getting a nonalignment<%> parent
(when (and parent (is-a? parent alignment<%>))
(send parent add this))))
(send parent add-child this)))
(define vertical-alignment% (vert/horiz-alignment 'vertical))
(define horizontal-alignment% (vert/horiz-alignment 'horizontal))
;; build-rect ((is-a?/c snip%) . -> . rect?)
#;((is-a?/c alignment%) . -> . rect?)
;; makes a new default rect out of a snip
(define (build-rect item)
(cond
[(is-a? item snip%)
(a:make-rect
(a:make-dim 0 (snip-min-width item) (stretchable-width? item))
(a:make-dim 0 (snip-min-height item) (stretchable-height? item)))]
[(is-a? item alignment<%>)
(a:make-rect
(a:make-dim 0 (send item get-min-width) (send item stretchable-width?))
(a:make-dim 0 (send item get-min-height) (send item stretchable-height?)))]))
(a:make-rect
(a:make-dim 0 (send item get-min-width) (send item stretchable-width?))
(a:make-dim 0 (send item get-min-height) (send item stretchable-height?))))
)