Add ui.gadgets.tiling

db4
Eduardo Cavazos 2008-07-22 14:20:55 -05:00
parent e799acd1c3
commit a27be7daae
1 changed files with 118 additions and 0 deletions
extra/ui/gadgets/tiling

View File

@ -0,0 +1,118 @@
USING: kernel sequences math math.order
ui.gadgets ui.gadgets.tracks ui.gestures
accessors ;
IN: ui.gadgets.tiling
TUPLE: tiling < track gadgets columns first focused ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: init-tiling ( tiling -- tiling )
init-track
{ 1 0 } >>orientation
V{ } clone >>gadgets
2 >>columns
0 >>first
0 >>focused ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: <tiling> ( -- gadget )
tiling new
init-tiling ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: bounded-subseq ( seq a b -- seq )
[ 0 max ] dip
pick length [ min ] curry bi@
rot
subseq ;
: tiling-gadgets-to-map ( tiling -- gadgets )
[ gadgets>> ]
[ first>> ]
[ [ first>> ] [ columns>> ] bi + ]
tri
bounded-subseq ;
: tiling-map-gadgets ( tiling -- tiling )
dup clear-track
dup tiling-gadgets-to-map [ 1 track-add* ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: tiling-add ( tiling gadget -- tiling )
over gadgets>> push
tiling-map-gadgets ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: first-gadget ( tiling -- index ) drop 0 ;
: last-gadget ( tiling -- index ) gadgets>> length 1 - ;
: first-viewable ( tiling -- index ) first>> ;
: last-viewable ( tiling -- index ) [ first>> ] [ columns>> ] bi + 1 - ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-focused-mapped ( tiling -- tiling )
dup [ focused>> ] [ first>> ] bi <
[ dup first>> 1 - >>first ]
[ ]
if
dup [ last-viewable ] [ focused>> ] bi <
[ dup first>> 1 + >>first ]
[ ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: check-focused-bounds ( tiling -- tiling )
dup focused>> 0 max over gadgets>> length 1 - min >>focused ;
: focus-left ( tiling -- tiling )
dup focused>> 1 - >>focused
check-focused-bounds
make-focused-mapped
tiling-map-gadgets
dup request-focus ;
: focus-right ( tiling -- tiling )
dup focused>> 1 + >>focused
check-focused-bounds
make-focused-mapped
tiling-map-gadgets
dup request-focus ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: add-column ( tiling -- tiling )
dup columns>> 1 + >>columns
tiling-map-gadgets ;
: del-column ( tiling -- tiling )
dup columns>> 1 - 1 max >>columns
tiling-map-gadgets ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M: tiling focusable-child* ( tiling -- child/t )
[ focused>> ] [ gadgets>> ] bi nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
tiling
H{
{ T{ key-down f { A+ } "LEFT" } [ focus-left drop ] }
{ T{ key-down f { A+ } "RIGHT" } [ focus-right drop ] }
{ T{ key-down f { C+ } "[" } [ del-column drop ] }
{ T{ key-down f { C+ } "]" } [ add-column drop ] }
}
set-gestures