steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

big cleanup of UI code

cvs
Slava Pestov 2005-06-29 23:40:44 +00:00
parent cdf58fae57
commit 2b4c49c33a
15 changed files with 101 additions and 186 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
library/math/math.factor
View File

@ -60,19 +60,16 @@ GENERIC: abs ( z -- |z| )
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 )

10
library/test/gadgets.factor
View File

@ -67,16 +67,6 @@ USING: gadgets kernel lists math namespaces test sequences ;
] 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
[

8
library/ui/borders.factor
View File

@ -1,8 +1,8 @@
! 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.
@ -34,8 +34,8 @@ C: border ( child delegate size -- border )
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 ;

2
library/ui/checkboxes.factor
View File

@ -41,7 +41,7 @@ TUPLE: checkbox bevel selected? ;
[ 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

2
library/ui/frames.factor
View File

@ -113,4 +113,4 @@ SYMBOL: frame-bottom-run
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 ;

4
library/ui/init-world.factor
View File

@ -18,9 +18,9 @@ global [
[[ 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

87
library/ui/layouts.factor
View File

@ -19,21 +19,84 @@ namespaces sdl sequences ;
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 ;

3
library/ui/load.factor
View File

@ -14,10 +14,7 @@ USING: kernel parser sequences io ;
"/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"

2
library/ui/menus.factor
View File

@ -12,7 +12,7 @@ USING: generic kernel lists math namespaces sequences ;
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 )

49
library/ui/piles.factor
View File

@ -1,49 +0,0 @@
! 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 ;

2
library/ui/presentations.factor
View File

@ -4,6 +4,8 @@ IN: gadgets
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> ;

8
library/ui/scrolling.factor
View File

@ -13,8 +13,6 @@ TUPLE: viewport origin ;
: 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 )
@ -23,12 +21,6 @@ TUPLE: 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

45
library/ui/shelves.factor
View File

@ -1,45 +0,0 @@
! 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 ;

28
library/ui/splitters.factor
View File

@ -43,8 +43,13 @@ C: splitter ( first second vector -- splitter )
: <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- ;
@ -56,22 +61,5 @@ M: splitter pref-dim
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 ;

20
library/ui/stacks.factor
View File

@ -1,20 +0,0 @@
! 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 ;