91 lines
2.3 KiB
Factor
91 lines
2.3 KiB
Factor
! Copyright (C) 2006 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
IN: gadgets
|
|
USING: arrays kernel math namespaces sequences words io ;
|
|
|
|
TUPLE: grid children gap fill? ;
|
|
|
|
: set-grid-children* ( children grid -- )
|
|
[ set-grid-children ] 2keep >r concat r> add-gadgets ;
|
|
|
|
C: grid ( children -- grid )
|
|
dup delegate>gadget
|
|
[ set-grid-children* ] keep
|
|
{ 0 0 } over set-grid-gap
|
|
t over set-grid-fill? ;
|
|
|
|
: grid-child ( grid i j -- gadget ) rot grid-children nth nth ;
|
|
|
|
: grid-add ( gadget grid i j -- )
|
|
>r >r 2dup add-gadget r> r>
|
|
3dup grid-child unparent rot grid-children nth set-nth ;
|
|
|
|
: grid, ( gadget i j -- )
|
|
\ make-gadget get -rot grid-add ;
|
|
|
|
: grid-remove ( grid i j -- )
|
|
>r >r >r <gadget> r> r> r> grid-add ;
|
|
|
|
: pref-dim-grid ( grid -- dims )
|
|
grid-children [ [ pref-dim ] map ] map ;
|
|
|
|
: (compute-grid) [ max-dim ] map ;
|
|
|
|
: compute-grid ( grid -- horiz vert )
|
|
pref-dim-grid dup flip (compute-grid) swap (compute-grid) ;
|
|
|
|
: (pair-up) ( horiz vert -- dim )
|
|
>r first r> second 2array ;
|
|
|
|
: pair-up ( horiz vert -- dims )
|
|
[ swap [ swap (pair-up) ] map-with ] map-with ;
|
|
|
|
: add-gaps ( gap seq -- newseq )
|
|
[ v+ ] map-with ;
|
|
|
|
: gap-sum ( gap seq -- newseq )
|
|
dupd add-gaps dim-sum v+ ;
|
|
|
|
M: grid pref-dim*
|
|
dup grid-gap swap compute-grid >r over r>
|
|
gap-sum >r gap-sum r> (pair-up) ;
|
|
|
|
: do-grid ( dims grid quot -- )
|
|
-rot grid-children
|
|
[ [ pick call ] 2each ] 2each
|
|
drop ; inline
|
|
|
|
: grid-positions ( grid dims -- locs )
|
|
>r grid-gap dup r> add-gaps swap [ v+ ] accumulate nip ;
|
|
|
|
: position-grid ( grid horiz vert -- )
|
|
pick >r
|
|
>r over r> grid-positions >r grid-positions r>
|
|
pair-up r> [ set-rect-loc ] do-grid ;
|
|
|
|
: resize-grid ( grid horiz vert -- )
|
|
pick grid-fill? [
|
|
pair-up swap [ set-layout-dim ] do-grid
|
|
] [
|
|
2drop grid-children [ [ prefer ] each ] each
|
|
] if ;
|
|
|
|
: grid-layout ( grid horiz vert -- )
|
|
[ position-grid ] 3keep resize-grid ;
|
|
|
|
M: grid layout* dup compute-grid grid-layout ;
|
|
|
|
M: grid children-on ( rect gadget -- seq )
|
|
dup gadget-children empty? [
|
|
2drop f
|
|
] [
|
|
{ 0 1 } swap grid-children
|
|
[ 0 <column> fast-children-on ] keep
|
|
<slice> concat
|
|
] if ;
|
|
|
|
M: grid gadget-text*
|
|
grid-children
|
|
[ [ gadget-text ] map ] map format-table
|
|
[ CHAR: \n , ] [ % ] interleave ;
|