2dup mod dup 0 number= [ 2drop ] [ - + ] ifte ;
: (repeat) ( i n quot -- )
- pick pick >= [
- 3drop
- ] [
- [ swap >r call 1 + r> ] keep (repeat)
- ] ifte ; inline
+ pick pick >=
+ [ 3drop ] [ [ swap >r call 1 + r> ] keep (repeat) ] ifte ;
+ inline
-: repeat ( n quot -- )
- #! Execute a quotation n times. The loop counter is kept on
- #! the stack, and ranges from 0 to n-1.
+: repeat ( n quot -- | quot: n -- n )
+ #! The loop counter is kept on the stack, and ranges from
+ #! 0 to n-1.
0 -rot (repeat) ; inline
-: times ( n quot -- )
- #! Evaluate a quotation n times.
+: times ( n quot -- | quot: -- )
swap [ >r dup slip r> ] repeat drop ; inline
: 2repeat ( i j quot -- | quot: i j -- i j )
] with-scope
] unit-test
-[
- 300 620
-] [
- 0 { 10 10 10 } 0 <pile> "pile" set
- 0 0 100 100 <rectangle> <gadget> "pile" get add-gadget
- 0 0 200 200 <rectangle> <gadget> "pile" get add-gadget
- 0 0 300 300 <rectangle> <gadget> "pile" get add-gadget
- "pile" get pref-size
-] unit-test
-
[ ] [ "pile" get layout* ] unit-test
[
! 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 vectors ;
+USING: errors generic hashtables kernel lists math matrices
+namespaces sdl vectors ;
! A border lays out its children on top of each other, all with
! a 5-pixel padding.
gadget-child resize-gadget ;
M: border pref-dim ( border -- dim )
- [ border-size 2 * ] keep
- gadget-child pref-size >r over + r> rot + 0 3vector ;
+ [ border-size dup dup 3vector 2 v*n ] keep
+ gadget-child pref-dim v+ ;
M: border layout* ( border -- )
dup layout-border-x/y layout-border-w/h ;
[ checkbox-bevel button-update ] [ mouse-enter ] set-action ;
C: checkbox ( label -- checkbox )
- <default-shelf> over set-delegate
+ <line-shelf> over set-delegate
[ f line-border swap init-checkbox-bevel ] keep
[ >r <label> r> add-gadget ] keep
dup checkbox-actions
frame-bottom pos-frame-bottom ;
M: frame layout* ( frame -- )
- [ dup setup-frame layout-frame ] with-layout ;
+ [ 0 x set 0 y set dup setup-frame layout-frame ] with-scope ;
[[ font-style plain ]]
}} world get set-gadget-paint
- 1024 768 world get resize-gadget
+ { 1024 768 0 } world get set-gadget-dim
- <plain-gadget> world get add-gadget
+ <plain-gadget> add-layer
<console> "Stack display goes here" <label> <y-splitter>
3/4 over set-splitter-split add-layer
drop
] ifte ;
-: with-pref-size ( quot -- )
- [
- 0 width set 0 height set call width get height get
- ] with-scope ; inline
-
-: with-layout ( quot -- )
- [ 0 x set 0 y set call ] with-scope ; inline
+GENERIC: alignment
+GENERIC: filling
+GENERIC: orientation
: pref-dims ( gadget -- list )
gadget-children [ pref-dim ] map ;
-: packed-pref-dim ( gadget gap axis -- dim )
+: packed-pref-dim ( gadget -- dim )
#! The preferred size of the gadget, if all children are
#! packed in the direction of the given axis.
- >r
- over length 0 max v*n >r pref-dims r>
- 2dup [ v+ ] reduce >r [ vmax ] reduce r>
- r> set-axis ;
+ [
+ pref-dims
+ [ { 0 0 0 } [ vmax ] reduce ] keep
+ { 0 0 0 } [ v+ ] reduce
+ ] keep orientation set-axis ;
+
+: orient ( gadget list1 list2 -- list )
+ zip >r orientation r> [ uncons rot set-axis ] map-with ;
+
+: packed-dim-2 ( gadget sizes -- list )
+ [ over shape-dim over v- rot filling v*n v+ ] map-with ;
+
+: (packed-dims) ( gadget sizes -- list )
+ 2dup packed-dim-2 swap orient ;
+
+: packed-dims ( gadget sizes -- list )
+ over gadget-children >r (packed-dims) r>
+ zip [ uncons set-gadget-dim ] each ;
+
+: packed-loc-1 ( sizes -- list )
+ { 0 0 0 } [ v+ ] accumulate ;
+
+: packed-loc-2 ( gadget sizes -- list )
+ >r dup shape-dim over r> packed-dim-2 [ v- ] map-with
+ >r dup alignment swap shape-dim r>
+ [ >r 2dup r> v- n*v ] map 2nip ;
+
+: (packed-locs) ( gadget sizes -- list )
+ dup packed-loc-1 >r dupd packed-loc-2 r> orient ;
+
+: packed-locs ( gadget sizes -- )
+ over gadget-children >r (packed-locs) r>
+ zip [ uncons set-gadget-loc ] each ;
+
+: packed-layout ( gadget sizes -- )
+ 2dup packed-locs packed-dims ;
+
+TUPLE: pack align fill vector ;
+
+C: pack ( align fill vector -- pack )
+ #! align: 0 left aligns, 1/2 center, 1 right.
+ #! gap: between each child.
+ #! fill: 0 leaves default width, 1 fills to pack width.
+ [ <empty-gadget> swap set-delegate ] keep
+ [ set-pack-vector ] keep
+ [ set-pack-fill ] keep
+ [ set-pack-align ] keep ;
+
+: <pile> { 0 1 0 } <pack> ;
+
+: <line-pile> 0 1 <pile> ;
+
+: <shelf> { 1 0 0 } <pack> ;
+
+: <line-shelf> 0 1 <shelf> ;
+
+M: pack orientation pack-vector ;
+
+M: pack filling pack-fill ;
+
+M: pack alignment pack-align ;
+
+M: pack pref-dim packed-pref-dim ;
+
+M: pack layout* ( pack -- )
+ dup pref-dims packed-layout ;
+
+: <stack> ( list -- gadget )
+ #! A stack lays out all its children on top of each other.
+ 0 1 { 0 0 1 } <pack>
+ swap [ over add-gadget ] each ;
"/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"
hide-menu
world get
2dup set-world-menu
- 2dup world-hand screen-pos >rect rot move-gadget
+ 2dup world-hand screen-loc swap set-gadget-loc
show-glass ;
: menu-item-border ( child -- border )
+++ /dev/null
-! 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 sequences vectors ;
-
-! pile-align
-!
-! if the component is smaller than its allocated space, where to
-! place the component inside the allocated space.
-!
-! pile-gap
-!
-! amount of space, in pixels, between components.
-!
-! pile-fill
-!
-! if the component is smaller than its allocated space, how much
-! to scale the size, where a value of 0 represents no scaling, and
-! a value of 1 represents resizing to fully fill allocated space.
-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 ;
-
-: <line-pile> 0 { 0 0 0 } 1 <pile> ;
-
-M: pile pref-dim ( pile -- dim )
- dup pile-gap { 0 1 0 } packed-pref-dim ;
-
-: 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 first 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 ;
USING: hashtables io kernel lists namespaces parser prettyprint
sequences ;
+DEFER: pane-eval
+
: actions-menu ( pane actions -- menu )
[ uncons rot [ pane-eval ] cons cons cons ] map-with <menu> ;
: set-viewport-x [ viewport-y 0 3vector ] keep set-viewport-origin ;
: set-viewport-y [ viewport-x swap 0 3vector ] keep set-viewport-origin ;
-: viewport-h ( viewport -- h ) gadget-child pref-size nip ;
-
: viewport-dim ( viewport -- h ) gadget-child pref-dim ;
: fix-scroll ( origin viewport -- origin )
: scroll ( origin viewport -- )
[ fix-scroll ] keep [ set-viewport-origin ] keep relayout ;
-: scroll-viewport ( y viewport -- )
- #! y is a number between -1 and 0..
- [ viewport-h * >fixnum ] keep
- [ viewport-x swap 0 3vector ] keep
- scroll ;
-
C: viewport ( content -- viewport )
[ <empty-gadget> swap set-delegate ] keep
[ add-gadget ] keep
+++ /dev/null
-! 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 sequences vectors ;
-
-! A shelf is a box that lays out its contents horizontally.
-TUPLE: shelf gap align fill ;
-
-C: shelf ( align gap fill -- shelf )
- #! 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> over set-delegate
- [ set-shelf-fill ] keep
- [ set-shelf-gap ] keep
- [ set-shelf-align ] keep ;
-
-: <default-shelf> 1/2 { 3 3 3 } 0 <shelf> ;
-: <line-shelf> 0 0 1 <shelf> ;
-
-M: shelf pref-dim ( pile -- dim )
- [
- dup shelf-gap swap gadget-children
- [ length 1 - 0 max * width set ] keep
- [
- pref-size
- height [ max ] change
- width [ + ] change
- ] each
- ] with-pref-size 0 3vector ;
-
-: 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 ;
: <y-splitter> { 1 0 0 } <splitter> ;
-M: splitter pref-dim
- { 0 0 0 } over splitter-vector packed-pref-dim ;
+M: splitter orientation splitter-vector ;
+
+M: splitter filling drop 1 ;
+
+M: splitter alignment drop 0 ;
+
+M: splitter pref-dim packed-pref-dim ;
: splitter-part ( splitter -- vec )
dup splitter-split swap shape-dim n*v divider-size 1/2 v*n v- ;
dup shape-dim swap splitter-part v- ,
] make-list ;
-: packed-locs ( axis sizes gadget -- )
- >r
- { 0 0 0 } [ v+ ] accumulate
- [ { 0 0 0 } swap rot set-axis ] map-with
- r> gadget-children zip [ uncons set-gadget-loc ] each ;
-
-: packed-dims ( axis sizes gadget -- dims )
- [
- shape-dim swap [ >r 2dup r> rot set-axis ] map 2nip
- ] keep gadget-children zip [ uncons set-gadget-dim ] each ;
-
-: layout-divider ( assoc -- )
- [ uncons set-gadget-dim ] each ;
-
-: packed-layout ( axis sizes gadgets -- )
- 3dup packed-locs packed-dims ;
-
M: splitter layout* ( splitter -- )
- dup splitter-vector over splitter-layout rot packed-layout ;
+ dup splitter-layout packed-layout ;
+++ /dev/null
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: errors generic hashtables kernel lists math matrices
-namespaces sdl sequences ;
-
-! 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-dim ( shapelist -- dim )
- { 0 0 0 } [ shape-dim vmax ] reduce ;
-
-M: stack pref-dim gadget-children max-dim ;
-
-M: stack layout* ( stack -- )
- dup shape-dim swap gadget-children
- [ set-gadget-dim ] each-with ;