UI layout management work
Slava Pestov
parent
1bcac74906
commit
181a8d9ff4
|
|
@ -88,6 +88,7 @@ cpu "x86" = "mini" get not and [
|
|||
"/library/tools/jedit-wire.factor"
|
||||
"/library/tools/profiler.factor"
|
||||
"/library/tools/walker.factor"
|
||||
"/library/tools/annotations.factor"
|
||||
"/library/tools/jedit.factor"
|
||||
"/library/bootstrap/image.factor"
|
||||
|
||||
|
|
@ -125,6 +126,11 @@ cpu "x86" = "mini" get not and [
|
|||
"/library/ui/gestures.factor"
|
||||
"/library/ui/hand.factor"
|
||||
"/library/ui/layouts.factor"
|
||||
"/library/ui/piles.factor"
|
||||
"/library/ui/shelves.factor"
|
||||
"/library/ui/borders.factor"
|
||||
"/library/ui/stacks.factor"
|
||||
"/library/ui/frames.factor"
|
||||
"/library/ui/world.factor"
|
||||
"/library/ui/labels.factor"
|
||||
"/library/ui/buttons.factor"
|
||||
|
|
|
|||
|
|
@ -9,6 +9,12 @@ USE: math-internals
|
|||
USE: lists
|
||||
USE: kernel
|
||||
|
||||
: interpret ( quot -- )
|
||||
#! The quotation is called with each word as its executed.
|
||||
done? [ drop ] [ [ next swap call ] keep interpret ] ifte ;
|
||||
|
||||
: run ( -- ) [ do ] interpret ;
|
||||
|
||||
: test-interpreter
|
||||
init-interpreter meta-cf set run meta-d get ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,26 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: words
|
||||
|
||||
! The annotation words let you flag a word for either tracing
|
||||
! or single-stepping. Note that currently, words referring to
|
||||
! annotated words cannot be compiled; and annotating a word has
|
||||
! no effect of compiled calls to that word.
|
||||
USING: interpreter kernel lists stdio strings ;
|
||||
|
||||
: annotate ( word quot -- ) #! Quotation: ( word def -- def )
|
||||
over [ word-def swap call ] keep set-word-def ;
|
||||
|
||||
: (watch) >r "==> " swap word-name cat2 \ print r> cons cons ;
|
||||
|
||||
: watch ( word -- )
|
||||
#! Cause a message to be printed out when the word is
|
||||
#! executed. To undo the effect of this, reload the
|
||||
#! word with \ foo reload.
|
||||
[ (watch) ] annotate ;
|
||||
|
||||
: (break) [ walk ] cons ;
|
||||
|
||||
: break ( word -- )
|
||||
#! Cause the word to start the code walker when executed.
|
||||
[ nip (break) ] annotate ;
|
||||
|
|
@ -5,7 +5,7 @@ USING: errors kernel lists math namespaces prettyprint stdio
|
|||
strings vectors words ;
|
||||
|
||||
! A Factor interpreter written in Factor. Used by compiler for
|
||||
! partial evaluation, also for trace and step.
|
||||
! partial evaluation, also by the walker.
|
||||
|
||||
! Meta-stacks
|
||||
SYMBOL: meta-r
|
||||
|
|
@ -36,15 +36,11 @@ SYMBOL: meta-cf
|
|||
meta-n [ ] change
|
||||
meta-c [ ] change ;
|
||||
|
||||
: done-cf? ( -- ? )
|
||||
meta-cf get not ;
|
||||
|
||||
: done? ( -- ? )
|
||||
done-cf? meta-r get vector-length 0 = and ;
|
||||
: done-cf? ( -- ? ) meta-cf get not ;
|
||||
: done? ( -- ? ) done-cf? meta-r get vector-length 0 = and ;
|
||||
|
||||
! Callframe.
|
||||
: up ( -- )
|
||||
pop-r meta-cf set ;
|
||||
: up ( -- ) pop-r meta-cf set ;
|
||||
|
||||
: next ( -- obj )
|
||||
meta-cf get [ meta-cf [ uncons ] change ] [ up next ] ifte ;
|
||||
|
|
@ -68,23 +64,14 @@ SYMBOL: meta-cf
|
|||
dup compound? [ word-def meta-call ] [ host-word ] ifte
|
||||
] ?ifte ;
|
||||
|
||||
: do ( obj -- )
|
||||
dup word? [ meta-word ] [ push-d ] ifte ;
|
||||
: do ( obj -- ) dup word? [ meta-word ] [ push-d ] ifte ;
|
||||
|
||||
: meta-word-1 ( word -- )
|
||||
dup "meta-word" word-prop [ call ] [ host-word ] ?ifte ;
|
||||
|
||||
: do-1 ( obj -- )
|
||||
dup word? [ meta-word-1 ] [ push-d ] ifte ;
|
||||
: do-1 ( obj -- ) dup word? [ meta-word-1 ] [ push-d ] ifte ;
|
||||
|
||||
: interpret ( quot -- )
|
||||
#! The quotation is called with each word as its executed.
|
||||
done? [ drop ] [ [ next swap call ] keep interpret ] ifte ;
|
||||
|
||||
: run ( -- ) [ do ] interpret ;
|
||||
|
||||
: set-meta-word ( word quot -- )
|
||||
"meta-word" set-word-prop ;
|
||||
: set-meta-word ( word quot -- ) "meta-word" set-word-prop ;
|
||||
|
||||
\ datastack [ meta-d get clone push-d ] set-meta-word
|
||||
\ set-datastack [ pop-d clone meta-d set ] set-meta-word
|
||||
|
|
@ -99,3 +86,5 @@ SYMBOL: meta-cf
|
|||
\ call [ pop-d meta-call ] set-meta-word
|
||||
\ execute [ pop-d meta-word ] set-meta-word
|
||||
\ ifte [ pop-d pop-d pop-d [ nip ] [ drop ] ifte meta-call ] set-meta-word
|
||||
|
||||
FORGET: set-meta-word
|
||||
|
|
|
|||
|
|
@ -4,8 +4,6 @@ IN: interpreter
|
|||
USING: errors kernel listener lists math namespaces prettyprint
|
||||
stdio strings vectors words ;
|
||||
|
||||
! Some useful tools
|
||||
|
||||
: &s
|
||||
#! Print stepper data stack.
|
||||
meta-d get {.} ;
|
||||
|
|
@ -23,7 +21,7 @@ stdio strings vectors words ;
|
|||
meta-c get [.] ;
|
||||
|
||||
: &get ( var -- value )
|
||||
#! Print stepper variable value.
|
||||
#! Get stepper variable value.
|
||||
meta-n get (get) ;
|
||||
|
||||
: stack-report ( -- )
|
||||
|
|
@ -41,7 +39,7 @@ stdio strings vectors words ;
|
|||
stack-report meta-cf get . ;
|
||||
|
||||
: step
|
||||
#! Step into current word.
|
||||
#! Step over current word.
|
||||
[ next do-1 report ] not-done ;
|
||||
|
||||
: into
|
||||
|
|
@ -49,23 +47,23 @@ stdio strings vectors words ;
|
|||
[ next do report ] not-done ;
|
||||
|
||||
: walk-banner ( -- )
|
||||
"The following words control the single-stepper:" print
|
||||
[ &s &r &n &c ] [ prettyprint-word " " write ] each
|
||||
"show stepper stacks." print
|
||||
\ &get prettyprint-word
|
||||
" ( var -- value ) inspects the stepper namestack." print
|
||||
\ step prettyprint-word " -- single step over" print
|
||||
\ into prettyprint-word " -- single step into" print
|
||||
\ run prettyprint-word " -- run until end" print
|
||||
\ exit prettyprint-word " -- exit single-stepper" print
|
||||
report ;
|
||||
|
||||
: walk-listener walk-banner "walk" listener-prompt set listener ;
|
||||
|
||||
: walk ( quot -- )
|
||||
#! Single-step through execution of a quotation.
|
||||
[
|
||||
"walk" listener-prompt set
|
||||
init-interpreter
|
||||
meta-cf set
|
||||
walk-banner
|
||||
listener
|
||||
] with-scope ;
|
||||
datastack meta-d set
|
||||
walk-listener
|
||||
meta-d get
|
||||
] with-scope set-datastack ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,41 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: errors generic hashtables kernel lists math namespaces
|
||||
sdl ;
|
||||
|
||||
! A border lays out its children on top of each other, all with
|
||||
! a 5-pixel padding.
|
||||
TUPLE: border size ;
|
||||
|
||||
C: border ( child delegate size -- border )
|
||||
[ set-border-size ] keep
|
||||
[ set-delegate ] keep
|
||||
[ over [ add-gadget ] [ 2drop ] ifte ] keep ;
|
||||
|
||||
: empty-border ( child -- border )
|
||||
<empty-gadget> 5 <border> ;
|
||||
|
||||
: line-border ( child -- border )
|
||||
0 0 0 0 <etched-rect> <gadget> 5 <border> ;
|
||||
|
||||
: filled-border ( child -- border )
|
||||
0 0 0 0 <plain-rect> <gadget> 5 <border> ;
|
||||
|
||||
: gadget-child gadget-children car ;
|
||||
|
||||
: layout-border-x/y ( border -- )
|
||||
dup border-size dup rot gadget-child move-gadget ;
|
||||
|
||||
: layout-border-w/h ( border -- )
|
||||
[ border-size 2 * ] keep
|
||||
[ shape-w over - ] keep
|
||||
[ shape-h rot - ] keep
|
||||
gadget-child resize-gadget ;
|
||||
|
||||
M: border pref-size ( border -- w h )
|
||||
[ border-size 2 * ] keep
|
||||
gadget-child pref-size >r over + r> rot + ;
|
||||
|
||||
M: border layout* ( border -- )
|
||||
dup layout-border-x/y layout-border-w/h ;
|
||||
|
|
@ -86,7 +86,8 @@ C: editor ( text -- )
|
|||
1 swap shape-h ;
|
||||
|
||||
M: editor user-input* ( ch field -- ? )
|
||||
[ insert-char ] with-editor t ;
|
||||
[ [ insert-char ] with-editor ] keep
|
||||
[ scroll>bottom ] swap handle-gesture drop t ;
|
||||
|
||||
M: editor layout* ( field -- )
|
||||
dup [ editor-text shape-size ] keep resize-gadget
|
||||
|
|
|
|||
|
|
@ -0,0 +1,41 @@
|
|||
USING: gadgets kernel lists math namespaces sdl ;
|
||||
|
||||
! A frame arranges left/right/top/bottom gadgets around a
|
||||
! center gadget, which gets any leftover space.
|
||||
TUPLE: frame gap left right top bottom center ;
|
||||
|
||||
C: frame ( gap center -- frame )
|
||||
[ set-frame-gap ] keep
|
||||
[ set-frame-center ] keep
|
||||
[ <empty-gadget> swap set-frame-left ] keep
|
||||
[ <empty-gadget> swap set-frame-right ] keep
|
||||
[ <empty-gadget> swap set-frame-top ] keep
|
||||
[ <empty-gadget> swap set-frame-bottom ] keep ;
|
||||
|
||||
: frame-major ( glue -- list )
|
||||
[
|
||||
dup frame-top , dup frame-center , frame-bottom ,
|
||||
] make-list ;
|
||||
|
||||
: frame-minor ( glue -- list )
|
||||
[
|
||||
dup frame-left , dup frame-center , frame-right ,
|
||||
] make-list ;
|
||||
|
||||
: max-h pref-size nip height [ max ] change ;
|
||||
: max-w pref-size drop width [ max ] change ;
|
||||
|
||||
: add-h pref-size nip height [ + ] change ;
|
||||
: add-w pref-size drop width [ + ] change ;
|
||||
|
||||
M: frame pref-size ( glue -- w h )
|
||||
[
|
||||
dup frame-major [ max-w ] each
|
||||
dup frame-minor [ max-h ] each
|
||||
dup frame-left add-w
|
||||
dup frame-right add-w
|
||||
dup frame-top add-h
|
||||
dup frame-bottom add-h
|
||||
] with-pref-size ;
|
||||
|
||||
|
||||
|
|
@ -28,138 +28,3 @@ sdl ;
|
|||
[ 0 x set 0 y set call ] with-scope ; inline
|
||||
|
||||
: default-gap 3 ;
|
||||
|
||||
! A pile is a box that lays out its contents vertically.
|
||||
TUPLE: pile align gap fill ;
|
||||
|
||||
C: pile ( align gap fill -- pile )
|
||||
#! align: 0 left aligns, 1/2 center, 1 right.
|
||||
#! gap: between each child.
|
||||
#! fill: 0 leaves default width, 1 fills to pile width.
|
||||
[ <empty-gadget> swap set-delegate ] keep
|
||||
[ set-pile-fill ] keep
|
||||
[ set-pile-gap ] keep
|
||||
[ set-pile-align ] keep ;
|
||||
|
||||
: <default-pile> 1/2 default-gap 0 <pile> ;
|
||||
: <line-pile> 0 0 1 <pile> ;
|
||||
|
||||
M: pile pref-size ( pile -- w h )
|
||||
[
|
||||
dup pile-gap swap gadget-children
|
||||
[ length 1 - 0 max * height set ] keep
|
||||
[
|
||||
pref-size
|
||||
height [ + ] change
|
||||
width [ max ] change
|
||||
] each
|
||||
] with-pref-size ;
|
||||
|
||||
: w- swap shape-w swap pref-size drop - ;
|
||||
: pile-x/y ( pile gadget offset -- )
|
||||
rot pile-align * >fixnum y get rot move-gadget ;
|
||||
: pile-w/h ( pile gadget offset -- )
|
||||
rot dup pile-gap y [ + ] change
|
||||
pile-fill * >fixnum over pref-size dup y [ + ] change
|
||||
>r + r> rot resize-gadget ;
|
||||
: vertically ( pile gadget -- ) 2dup w- 3dup pile-x/y pile-w/h ;
|
||||
|
||||
M: pile layout* ( pile -- )
|
||||
[
|
||||
dup gadget-children [ vertically ] each-with
|
||||
] with-layout ;
|
||||
|
||||
! A shelf is a box that lays out its contents horizontally.
|
||||
TUPLE: shelf gap align fill ;
|
||||
|
||||
C: shelf ( align gap fill -- shelf )
|
||||
<empty-gadget> over set-delegate
|
||||
[ set-shelf-fill ] keep
|
||||
[ set-shelf-gap ] keep
|
||||
[ set-shelf-align ] keep ;
|
||||
|
||||
: <default-shelf> 1/2 default-gap 0 <shelf> ;
|
||||
: <line-shelf> 0 0 1 <shelf> ;
|
||||
|
||||
M: shelf pref-size ( pile -- w h )
|
||||
[
|
||||
dup shelf-gap swap gadget-children
|
||||
[ length 1 - 0 max * width set ] keep
|
||||
[
|
||||
pref-size
|
||||
height [ max ] change
|
||||
width [ + ] change
|
||||
] each
|
||||
] with-pref-size ;
|
||||
|
||||
: h- swap shape-h swap pref-size nip - ;
|
||||
: shelf-x/y rot shelf-align * >fixnum >r x get r> rot move-gadget ;
|
||||
: shelf-w/h ( pile gadget offset -- )
|
||||
rot dup shelf-gap x [ + ] change
|
||||
shelf-fill * >fixnum >r dup pref-size over x [ + ] change
|
||||
r> drop rot resize-gadget ;
|
||||
: horizontally ( pile gadget -- )
|
||||
2dup h- 3dup shelf-x/y shelf-w/h ;
|
||||
|
||||
M: shelf layout* ( pile -- )
|
||||
[
|
||||
dup gadget-children [ horizontally ] each-with
|
||||
] with-layout ;
|
||||
|
||||
! A border lays out its children on top of each other, all with
|
||||
! a 5-pixel padding.
|
||||
TUPLE: border size ;
|
||||
|
||||
C: border ( child delegate size -- border )
|
||||
[ set-border-size ] keep
|
||||
[ set-delegate ] keep
|
||||
[ over [ add-gadget ] [ 2drop ] ifte ] keep ;
|
||||
|
||||
: empty-border ( child -- border )
|
||||
<empty-gadget> 5 <border> ;
|
||||
|
||||
: line-border ( child -- border )
|
||||
0 0 0 0 <etched-rect> <gadget> 5 <border> ;
|
||||
|
||||
: filled-border ( child -- border )
|
||||
0 0 0 0 <plain-rect> <gadget> 5 <border> ;
|
||||
|
||||
: gadget-child gadget-children car ;
|
||||
|
||||
: layout-border-x/y ( border -- )
|
||||
dup border-size dup rot gadget-child move-gadget ;
|
||||
|
||||
: layout-border-w/h ( border -- )
|
||||
[ border-size 2 * ] keep
|
||||
[ shape-w over - ] keep
|
||||
[ shape-h rot - ] keep
|
||||
gadget-child resize-gadget ;
|
||||
|
||||
M: border pref-size ( border -- w h )
|
||||
[ border-size 2 * ] keep
|
||||
gadget-child pref-size >r over + r> rot + ;
|
||||
|
||||
M: border layout* ( border -- )
|
||||
dup layout-border-x/y layout-border-w/h ;
|
||||
|
||||
! A stack just lays out all its children on top of each other.
|
||||
TUPLE: stack ;
|
||||
C: stack ( list -- stack )
|
||||
<empty-gadget> over set-delegate
|
||||
swap [ over add-gadget ] each ;
|
||||
|
||||
: max-size ( stack -- w h )
|
||||
[
|
||||
[
|
||||
dup
|
||||
shape-w width [ max ] change
|
||||
shape-h height [ max ] change
|
||||
] each
|
||||
] with-pref-size ;
|
||||
|
||||
M: stack pref-size gadget-children max-size ;
|
||||
|
||||
M: stack layout* ( stack -- )
|
||||
dup gadget-children [
|
||||
>r dup shape-w over shape-h r> resize-gadget
|
||||
] each drop ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,45 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: errors generic hashtables kernel lists math namespaces
|
||||
sdl ;
|
||||
|
||||
! A pile is a box that lays out its contents vertically.
|
||||
TUPLE: pile align gap fill ;
|
||||
|
||||
C: pile ( align gap fill -- pile )
|
||||
#! align: 0 left aligns, 1/2 center, 1 right.
|
||||
#! gap: between each child.
|
||||
#! fill: 0 leaves default width, 1 fills to pile width.
|
||||
[ <empty-gadget> swap set-delegate ] keep
|
||||
[ set-pile-fill ] keep
|
||||
[ set-pile-gap ] keep
|
||||
[ set-pile-align ] keep ;
|
||||
|
||||
: <default-pile> 1/2 default-gap 0 <pile> ;
|
||||
: <line-pile> 0 0 1 <pile> ;
|
||||
|
||||
M: pile pref-size ( pile -- w h )
|
||||
[
|
||||
dup pile-gap swap gadget-children
|
||||
[ length 1 - 0 max * height set ] keep
|
||||
[
|
||||
pref-size
|
||||
height [ + ] change
|
||||
width [ max ] change
|
||||
] each
|
||||
] with-pref-size ;
|
||||
|
||||
: w- swap shape-w swap pref-size drop - ;
|
||||
: pile-x/y ( pile gadget offset -- )
|
||||
rot pile-align * >fixnum y get rot move-gadget ;
|
||||
: pile-w/h ( pile gadget offset -- )
|
||||
rot dup pile-gap y [ + ] change
|
||||
pile-fill * >fixnum over pref-size dup y [ + ] change
|
||||
>r + r> rot resize-gadget ;
|
||||
: vertically ( pile gadget -- ) 2dup w- 3dup pile-x/y pile-w/h ;
|
||||
|
||||
M: pile layout* ( pile -- )
|
||||
[
|
||||
dup gadget-children [ vertically ] each-with
|
||||
] with-layout ;
|
||||
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: generic kernel lists math namespaces threads ;
|
||||
|
||||
|
|
@ -19,20 +21,13 @@ TUPLE: viewport x y ;
|
|||
[ set-viewport-y ] keep
|
||||
relayout ;
|
||||
|
||||
: scroll>bottom ( viewport -- )
|
||||
1 swap scroll-viewport ;
|
||||
|
||||
: viewport-actions ( viewport -- )
|
||||
[
|
||||
[[ [ scroll>bottom ] [ scroll>bottom ] ]]
|
||||
] swap add-actions ;
|
||||
: scroll>bottom ( viewport -- ) 1 swap scroll-viewport ;
|
||||
|
||||
C: viewport ( content -- viewport )
|
||||
[ <empty-gadget> swap set-delegate ] keep
|
||||
[ add-gadget ] keep
|
||||
0 over set-viewport-x
|
||||
0 over set-viewport-y
|
||||
dup viewport-actions ;
|
||||
0 over set-viewport-y ;
|
||||
|
||||
M: viewport pref-size gadget-child pref-size ;
|
||||
|
||||
|
|
@ -43,9 +38,6 @@ M: viewport layout* ( viewport -- )
|
|||
] keep prefer
|
||||
] each-with ;
|
||||
|
||||
: scroll>bottom ( viewport -- )
|
||||
dup viewport-h swap scroll-viewport ;
|
||||
|
||||
! A slider scrolls a viewport.
|
||||
|
||||
! The offset slot is the y co-ordinate of the mouse relative to
|
||||
|
|
@ -119,8 +111,17 @@ TUPLE: scroller viewport slider ;
|
|||
: add-viewport 2dup set-scroller-viewport add-gadget ;
|
||||
: add-slider 2dup set-scroller-slider add-gadget ;
|
||||
|
||||
: viewport>bottom 1 swap scroll-viewport ;
|
||||
: scroll>bottom ( scroller -- )
|
||||
dup scroller-slider relayout
|
||||
scroller-viewport viewport>bottom ;
|
||||
|
||||
: scroller-actions ( scroller -- )
|
||||
[ scroll>bottom ] [ scroll>bottom ] set-action ;
|
||||
|
||||
C: scroller ( gadget -- scroller )
|
||||
#! Wrap a scrolling pane around the gadget.
|
||||
[ <line-shelf> swap set-delegate ] keep
|
||||
[ >r <viewport> r> add-viewport ] keep
|
||||
[ dup scroller-viewport <slider> swap add-slider ] keep ;
|
||||
[ dup scroller-viewport <slider> swap add-slider ] keep
|
||||
dup scroller-actions ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,42 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: errors generic hashtables kernel lists math namespaces
|
||||
sdl ;
|
||||
|
||||
! A shelf is a box that lays out its contents horizontally.
|
||||
TUPLE: shelf gap align fill ;
|
||||
|
||||
C: shelf ( align gap fill -- shelf )
|
||||
<empty-gadget> over set-delegate
|
||||
[ set-shelf-fill ] keep
|
||||
[ set-shelf-gap ] keep
|
||||
[ set-shelf-align ] keep ;
|
||||
|
||||
: <default-shelf> 1/2 default-gap 0 <shelf> ;
|
||||
: <line-shelf> 0 0 1 <shelf> ;
|
||||
|
||||
M: shelf pref-size ( pile -- w h )
|
||||
[
|
||||
dup shelf-gap swap gadget-children
|
||||
[ length 1 - 0 max * width set ] keep
|
||||
[
|
||||
pref-size
|
||||
height [ max ] change
|
||||
width [ + ] change
|
||||
] each
|
||||
] with-pref-size ;
|
||||
|
||||
: h- swap shape-h swap pref-size nip - ;
|
||||
: shelf-x/y rot shelf-align * >fixnum >r x get r> rot move-gadget ;
|
||||
: shelf-w/h ( shelf gadget offset -- )
|
||||
rot dup shelf-gap x [ + ] change
|
||||
shelf-fill * >fixnum >r dup pref-size over x [ + ] change
|
||||
r> + rot resize-gadget ;
|
||||
: horizontally ( shelf gadget -- )
|
||||
2dup h- 3dup shelf-x/y shelf-w/h ;
|
||||
|
||||
M: shelf layout* ( pile -- )
|
||||
[
|
||||
dup gadget-children [ horizontally ] each-with
|
||||
] with-layout ;
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: errors generic hashtables kernel lists math namespaces
|
||||
sdl ;
|
||||
|
||||
! A stack just lays out all its children on top of each other.
|
||||
TUPLE: stack ;
|
||||
C: stack ( list -- stack )
|
||||
<empty-gadget> over set-delegate
|
||||
swap [ over add-gadget ] each ;
|
||||
|
||||
: max-size ( stack -- w h )
|
||||
[
|
||||
[
|
||||
dup
|
||||
shape-w width [ max ] change
|
||||
shape-h height [ max ] change
|
||||
] each
|
||||
] with-pref-size ;
|
||||
|
||||
M: stack pref-size gadget-children max-size ;
|
||||
|
||||
M: stack layout* ( stack -- )
|
||||
dup gadget-children [
|
||||
>r dup shape-w over shape-h r> resize-gadget
|
||||
] each drop ;
|
||||
Loading…
Reference in New Issue