2005-02-02 19:50:13 -05:00
|
|
|
! Copyright (C) 2005 Slava Pestov.
|
|
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
|
|
IN: gadgets
|
2005-06-28 16:25:27 -04:00
|
|
|
USING: errors generic hashtables kernel lists math matrices
|
|
|
|
namespaces sdl sequences ;
|
2005-02-02 19:50:13 -05:00
|
|
|
|
2005-02-03 19:11:06 -05:00
|
|
|
: layout ( gadget -- )
|
|
|
|
#! Set the gadget's width and height to its preferred width
|
|
|
|
#! and height. The gadget's children are laid out first.
|
|
|
|
#! Note that nothing is done if the gadget does not need to
|
|
|
|
#! be laid out.
|
|
|
|
dup gadget-relayout? [
|
2005-04-30 17:17:10 -04:00
|
|
|
f over set-gadget-relayout?
|
2005-07-13 21:03:34 -04:00
|
|
|
dup layout*
|
|
|
|
gadget-children [ layout ] each
|
2005-02-03 19:11:06 -05:00
|
|
|
] [
|
|
|
|
drop
|
|
|
|
] ifte ;
|
|
|
|
|
2005-07-06 03:29:42 -04:00
|
|
|
TUPLE: pack align fill vector ;
|
|
|
|
|
2005-06-29 00:33:07 -04:00
|
|
|
: pref-dims ( gadget -- list )
|
2005-07-24 22:59:23 -04:00
|
|
|
gadget-children [ pref-dim ] map ;
|
2005-06-29 00:33:07 -04:00
|
|
|
|
2005-06-29 19:40:44 -04:00
|
|
|
: orient ( gadget list1 list2 -- list )
|
2005-07-06 01:57:58 -04:00
|
|
|
zip >r pack-vector r> [ uncons rot set-axis ] map-with ;
|
2005-06-29 19:40:44 -04:00
|
|
|
|
|
|
|
: packed-dim-2 ( gadget sizes -- list )
|
2005-07-06 01:57:58 -04:00
|
|
|
[
|
2005-07-19 04:23:33 -04:00
|
|
|
over rectangle-dim { 1 1 1 } vmax over v-
|
2005-07-06 01:57:58 -04:00
|
|
|
rot pack-fill v*n v+
|
|
|
|
] map-with ;
|
2005-06-29 19:40:44 -04:00
|
|
|
|
2005-07-24 22:59:23 -04:00
|
|
|
: (packed-dims) ( gadget sizes -- seq )
|
2005-06-29 19:40:44 -04:00
|
|
|
2dup packed-dim-2 swap orient ;
|
|
|
|
|
2005-07-24 22:59:23 -04:00
|
|
|
: packed-dims ( gadget sizes -- seq )
|
|
|
|
over gadget-children >r (packed-dims) r>
|
|
|
|
[ set-gadget-dim ] 2each ;
|
2005-06-29 19:40:44 -04:00
|
|
|
|
2005-07-24 22:59:23 -04:00
|
|
|
: packed-loc-1 ( sizes -- seq )
|
2005-06-29 19:40:44 -04:00
|
|
|
{ 0 0 0 } [ v+ ] accumulate ;
|
|
|
|
|
2005-07-24 22:59:23 -04:00
|
|
|
: packed-loc-2 ( gadget sizes -- seq )
|
2005-07-19 04:23:33 -04:00
|
|
|
>r dup rectangle-dim { 1 1 1 } vmax over r>
|
2005-07-06 01:57:58 -04:00
|
|
|
packed-dim-2 [ v- ] map-with
|
2005-07-19 04:23:33 -04:00
|
|
|
>r dup pack-align swap rectangle-dim { 1 1 1 } vmax r>
|
2005-06-29 19:40:44 -04:00
|
|
|
[ >r 2dup r> v- n*v ] map 2nip ;
|
|
|
|
|
2005-07-24 22:59:23 -04:00
|
|
|
: (packed-locs) ( gadget sizes -- seq )
|
2005-06-29 19:40:44 -04:00
|
|
|
dup packed-loc-1 >r dupd packed-loc-2 r> orient ;
|
|
|
|
|
|
|
|
: packed-locs ( gadget sizes -- )
|
2005-07-24 22:59:23 -04:00
|
|
|
over gadget-children >r (packed-locs) r>
|
|
|
|
[ set-rectangle-loc ] 2each ;
|
2005-06-29 19:40:44 -04:00
|
|
|
|
|
|
|
: packed-layout ( gadget sizes -- )
|
|
|
|
2dup packed-locs packed-dims ;
|
|
|
|
|
|
|
|
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.
|
2005-07-13 21:03:34 -04:00
|
|
|
[ <gadget> swap set-delegate ] keep
|
2005-06-29 19:40:44 -04:00
|
|
|
[ set-pack-vector ] keep
|
|
|
|
[ set-pack-fill ] keep
|
|
|
|
[ set-pack-align ] keep ;
|
|
|
|
|
|
|
|
: <pile> { 0 1 0 } <pack> ;
|
|
|
|
|
2005-07-04 18:36:07 -04:00
|
|
|
: <line-pile> 0 0 <pile> ;
|
2005-06-29 19:40:44 -04:00
|
|
|
|
|
|
|
: <shelf> { 1 0 0 } <pack> ;
|
|
|
|
|
2005-07-04 18:36:07 -04:00
|
|
|
: <line-shelf> 0 0 <shelf> ;
|
2005-06-29 19:40:44 -04:00
|
|
|
|
2005-07-01 19:52:08 -04:00
|
|
|
M: pack pref-dim ( pack -- dim )
|
|
|
|
[
|
|
|
|
pref-dims
|
|
|
|
[ { 0 0 0 } [ vmax ] reduce ] keep
|
|
|
|
{ 0 0 0 } [ v+ ] reduce
|
2005-07-06 01:57:58 -04:00
|
|
|
] keep pack-vector set-axis ;
|
2005-06-29 19:40:44 -04:00
|
|
|
|
2005-07-06 01:57:58 -04:00
|
|
|
M: pack layout* ( pack -- ) dup pref-dims packed-layout ;
|
2005-06-29 19:40:44 -04:00
|
|
|
|
|
|
|
: <stack> ( list -- gadget )
|
|
|
|
#! A stack lays out all its children on top of each other.
|
2005-07-01 19:52:08 -04:00
|
|
|
0 1 { 0 0 1 } <pack> swap [ over add-gadget ] each ;
|